OptList.pm
Go to the documentation of this file.
00001 # Original package Data::OptList downloaded from CPAN on 6/15/2012. This module 00002 # has been modified by Andreas Schuh on 6/15/2012 to make it part of BASIS. 00003 00004 use strict; 00005 use warnings; 00006 package BASIS::Data::OptList; 00007 BEGIN { 00008 $BASIS::Data::OptList::VERSION = '0.107'; 00009 } 00010 # ABSTRACT: parse and validate simple name/value option pairs 00011 00012 use List::Util (); 00013 use BASIS::Params::Util (); 00014 use BASIS::Sub::Install 0.921 (); 00015 00016 00017 my %test_for; 00018 BEGIN { 00019 %test_for = ( 00020 CODE => \&BASIS::Params::Util::_CODELIKE, ## no critic 00021 HASH => \&BASIS::Params::Util::_HASHLIKE, ## no critic 00022 ARRAY => \&BASIS::Params::Util::_ARRAYLIKE, ## no critic 00023 SCALAR => \&BASIS::Params::Util::_SCALAR0, ## no critic 00024 ); 00025 } 00026 00027 sub __is_a { 00028 my ($got, $expected) = @_; 00029 00030 return List::Util::first { __is_a($got, $_) } @$expected if ref $expected; 00031 00032 return defined ( 00033 exists($test_for{$expected}) 00034 ? $test_for{$expected}->($got) 00035 : BASIS::Params::Util::_INSTANCE($got, $expected) ## no critic 00036 ); 00037 } 00038 00039 sub mkopt { 00040 my ($opt_list) = shift; 00041 00042 my ($moniker, $require_unique, $must_be); # the old positional args 00043 my $name_test; 00044 00045 if (@_ == 1 and BASIS::Params::Util::_HASHLIKE($_[0])) { 00046 my $arg = $_[0]; 00047 ($moniker, $require_unique, $must_be, $name_test) 00048 = @$arg{ qw(moniker require_unique must_be name_test) }; 00049 } else { 00050 ($moniker, $require_unique, $must_be) = @_; 00051 } 00052 00053 $moniker = 'unnamed' unless defined $moniker; 00054 00055 return [] unless $opt_list; 00056 00057 $name_test ||= sub { ! ref $_[0] }; 00058 00059 $opt_list = [ 00060 map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list 00061 ] if ref $opt_list eq 'HASH'; 00062 00063 my @return; 00064 my %seen; 00065 00066 for (my $i = 0; $i < @$opt_list; $i++) { ## no critic 00067 my $name = $opt_list->[$i]; 00068 my $value; 00069 00070 if ($require_unique) { 00071 Carp::croak "multiple definitions provided for $name" if $seen{$name}++; 00072 } 00073 00074 if ($i == $#$opt_list) { $value = undef; } 00075 elsif (not defined $opt_list->[$i+1]) { $value = undef; $i++ } 00076 elsif ($name_test->($opt_list->[$i+1])) { $value = undef; } 00077 else { $value = $opt_list->[++$i] } 00078 00079 if ($must_be and defined $value) { 00080 unless (__is_a($value, $must_be)) { 00081 my $ref = ref $value; 00082 Carp::croak "$ref-ref values are not valid in $moniker opt list"; 00083 } 00084 } 00085 00086 push @return, [ $name => $value ]; 00087 } 00088 00089 return \@return; 00090 } 00091 00092 00093 sub mkopt_hash { 00094 my ($opt_list, $moniker, $must_be) = @_; 00095 return {} unless $opt_list; 00096 00097 $opt_list = mkopt($opt_list, $moniker, 1, $must_be); 00098 my %hash = map { $_->[0] => $_->[1] } @$opt_list; 00099 return \%hash; 00100 } 00101 00102 00103 BEGIN { 00104 *import = BASIS::Sub::Install::exporter { 00105 exports => [qw(mkopt mkopt_hash)], 00106 }; 00107 } 00108 00109 1; 00110 00111 __END__ 00112 =pod 00113 00114 =head1 NAME 00115 00116 BASIS::Data::OptList - parse and validate simple name/value option pairs 00117 00118 =head1 VERSION 00119 00120 version 0.107 00121 00122 =head1 SYNOPSIS 00123 00124 use BASIS::Data::OptList; 00125 00126 my $options = BASIS::Data::OptList::mkopt([ 00127 qw(key1 key2 key3 key4), 00128 key5 => { ... }, 00129 key6 => [ ... ], 00130 key7 => sub { ... }, 00131 key8 => { ... }, 00132 key8 => [ ... ], 00133 ]); 00134 00135 ...is the same thing, more or less, as: 00136 00137 my $options = [ 00138 [ key1 => undef, ], 00139 [ key2 => undef, ], 00140 [ key3 => undef, ], 00141 [ key4 => undef, ], 00142 [ key5 => { ... }, ], 00143 [ key6 => [ ... ], ], 00144 [ key7 => sub { ... }, ], 00145 [ key8 => { ... }, ], 00146 [ key8 => [ ... ], ], 00147 ]); 00148 00149 =head1 DESCRIPTION 00150 00151 Hashes are great for storing named data, but if you want more than one entry 00152 for a name, you have to use a list of pairs. Even then, this is really boring 00153 to write: 00154 00155 $values = [ 00156 foo => undef, 00157 bar => undef, 00158 baz => undef, 00159 xyz => { ... }, 00160 ]; 00161 00162 Just look at all those undefs! Don't worry, we can get rid of those: 00163 00164 $values = [ 00165 map { $_ => undef } qw(foo bar baz), 00166 xyz => { ... }, 00167 ]; 00168 00169 Aaaauuugh! We've saved a little typing, but now it requires thought to read, 00170 and thinking is even worse than typing... and it's got a bug! It looked right, 00171 didn't it? Well, the C<< xyz => { ... } >> gets consumed by the map, and we 00172 don't get the data we wanted. 00173 00174 With BASIS::Data::OptList, you can do this instead: 00175 00176 $values = BASIS::Data::OptList::mkopt([ 00177 qw(foo bar baz), 00178 xyz => { ... }, 00179 ]); 00180 00181 This works by assuming that any defined scalar is a name and any reference 00182 following a name is its value. 00183 00184 =head1 FUNCTIONS 00185 00186 =head2 mkopt 00187 00188 my $opt_list = BASIS::Data::OptList::mkopt($input, \%arg); 00189 00190 Valid arguments are: 00191 00192 moniker - a word used in errors to describe the opt list; encouraged 00193 require_unique - if true, no name may appear more than once 00194 must_be - types to which opt list values are limited (described below) 00195 name_test - a coderef used to test whether a value can be a name 00196 (described below, but you probably don't want this) 00197 00198 This produces an array of arrays; the inner arrays are name/value pairs. 00199 Values will be either "undef" or a reference. 00200 00201 Positional parameters may be used for compability with the old C<mkopt> 00202 interface: 00203 00204 my $opt_list = BASIS::Data::OptList::mkopt($input, $moniker, $req_uni, $must_be); 00205 00206 Valid values for C<$input>: 00207 00208 undef -> [] 00209 hashref -> [ [ key1 => value1 ] ... ] # non-ref values become undef 00210 arrayref -> every name followed by a non-name becomes a pair: [ name => ref ] 00211 every name followed by undef becomes a pair: [ name => undef ] 00212 otherwise, it becomes [ name => undef ] like so: 00213 [ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ] 00214 00215 By default, a I<name> is any defined non-reference. The C<name_test> parameter 00216 can be a code ref that tests whether the argument passed it is a name or not. 00217 This should be used rarely. Interactions between C<require_unique> and 00218 C<name_test> are not yet particularly elegant, as C<require_unique> just tests 00219 string equality. B<This may change.> 00220 00221 The C<must_be> parameter is either a scalar or array of scalars; it defines 00222 what kind(s) of refs may be values. If an invalid value is found, an exception 00223 is thrown. If no value is passed for this argument, any reference is valid. 00224 If C<must_be> specifies that values must be CODE, HASH, ARRAY, or SCALAR, then 00225 BASIS::Params::Util is used to check whether the given value can provide that 00226 interface. Otherwise, it checks that the given value is an object of the kind. 00227 00228 In other words: 00229 00230 [ qw(SCALAR HASH Object::Known) ] 00231 00232 Means: 00233 00234 _SCALAR0($value) or _HASH($value) or _INSTANCE($value, 'Object::Known') 00235 00236 =head2 mkopt_hash 00237 00238 my $opt_hash = BASIS::Data::OptList::mkopt_hash($input, $moniker, $must_be); 00239 00240 Given valid C<L</mkopt>> input, this routine returns a reference to a hash. It 00241 will throw an exception if any name has more than one value. 00242 00243 =head1 EXPORTS 00244 00245 Both C<mkopt> and C<mkopt_hash> may be exported on request. 00246 00247 =head1 AUTHOR 00248 00249 Ricardo Signes <rjbs@cpan.org> 00250 00251 Modified by Andreas Schuh on 6/15/2012 in order to make it a subpackage 00252 of the SBIA namespace for inclusion with the BASIS package. 00253 00254 =head1 COPYRIGHT AND LICENSE 00255 00256 This software is copyright (c) 2006 by Ricardo Signes. 00257 00258 This is free software; you can redistribute it and/or modify it under 00259 the same terms as the Perl 5 programming language system itself. 00260 00261 =cut 00262