package Getopt::EX::LabeledParam; use version; our $VERSION = version->declare("2.1.1"); use v5.14; use warnings; use Carp; use Exporter 'import'; our @EXPORT = qw(); our @EXPORT_OK = qw(); our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] ); use Data::Dumper; use Getopt::EX::Module; use Getopt::EX::Func qw(parse_func); sub new { my $class = shift; my $obj = bless { NEWLABEL => 0, CONCAT => "", HASH => {}, LIST => [], }, $class; $obj->configure(@_) if @_; $obj; } sub configure { my $obj = shift; while (@_ >= 2) { my($k, $v) = splice @_, 0, 2; if ($k =~ /^\w/ and exists $obj->{$k}) { $obj->{$k} = $v; } } $obj; } sub get_hash { shift->{HASH} } sub set_hash { my $obj = shift; %{ $obj->{HASH} } = @_; $obj; } sub list { @{ shift->{LIST} } } sub push_list { my $obj = shift; push @{ $obj->{LIST} }, @_; $obj; } sub set_list { my $obj = shift; @{ $obj->{LIST} } = @_; $obj; } sub append { my $obj = shift; for my $item (@_) { if (ref $item eq 'ARRAY') { push @{$obj->{LIST}}, @$item; } elsif (ref $item eq 'HASH') { while (my($k, $v) = each %$item) { $obj->{HASH}->{$k} = $v; } } else { push @{$obj->{LIST}}, $item; } } } sub load_params { my $obj = shift; my $re_field = qr/[\w\*\?]+/; map { my $spec = pop @$_; my @spec; while ($spec =~ s/\&(\w+ (?: \( [^)]* \) )? ) ;?//x) { # &func push @spec, parse_func({ PACKAGE => 'main' }, $1); } if ($spec =~ s/\b(sub\s*{.*)//) { # sub { ... } push @spec, parse_func({ PACKAGE => 'main' }, $1); } push @spec, $spec if $spec ne ''; my $c = @spec > 1 ? [ @spec ] : @spec == 1 ? $spec[0] : ""; if (@$_ == 0) { $obj->push_list($c); } else { map { if ($c =~ /^\++(.*)/) { # LABEL=+ATTR $obj->{HASH}->{$_} .= $obj->{CONCAT} . "$1"; } elsif ($c =~ /^\-+(.*)$/i) { # LABEL=-ATTR my $chars = $1 =~ s/(?=\W)/\\/gr; $obj->{HASH}->{$_} =~ s/[$chars]+//g; } else { $obj->{HASH}->{$_} = $c; } } map { # plain label if (not /\W/) { if (exists $obj->{HASH}->{$_}) { $_; } else { if ($obj->{NEWLABEL}) { $_; } else { warn "$_: Unknown label\n"; (); } } } # wild card else { my @labels = match_glob($_, keys %{$obj->{HASH}}); if (@labels == 0) { warn "$_: Unmatched label\n"; } @labels; } } @$_; } } map { if (my @field = /\G($re_field)=/gp) { [ @field, ${^POSTMATCH} ]; } else { [ $_ ]; } } map { m/( (?: $re_field= )* (?: .* \b sub \s* \{ .* | (?: \([^)]*\) | [^,\s] )+ ) )/gx; } @_; $obj; } sub match_glob { local $_ = shift; s/\?/./g; s/\*/.*/g; my $regex = qr/^$_$/; grep { $_ =~ $regex } @_; } 1; =head1 NAME Getopt::EX::LabeledParam - Labeled parameter handling =head1 SYNOPSIS GetOptions('colormap|cm:s' => @opt_colormap); # default values my %colormap = ( FILE => 'DR', LINE => 'Y', TEXT => '' ); my @colors = qw( /544 /545 /445 /455 /545 /554 ); require Getopt::EX::LabeledParam; my $cmap = Getopt::EX::LabeledParam ->new( NEWLABEL => 0, HASH => \%colormap, LIST => \@colors ) ->load_params(@opt_colormap); =head1 DESCRIPTION This module implements super class of L. Parameters can be given in two ways: one in labeled table, and one in indexed list. Handler maintains hash and list objects, and labeled values are stored in hash, non-label values are in list automatically. User can mix both specifications. When the value field has a special form of function call, L object is created and stored for that entry. See L section in L for more detail. =head2 HASH Basically, labeled parameter is defined by B