Skip to content
Browse files

r22319@knight: rjbs | 2006-06-08 22:27:52 -0400

 tag
  • Loading branch information...
0 parents commit b25daf35c72b76c99e8feff97a705cf47dba06cd @rjbs committed Jun 9, 2006
Showing with 488 additions and 0 deletions.
  1. +17 −0 Changes
  2. +14 −0 MANIFEST
  3. +15 −0 Makefile.PL
  4. +228 −0 lib/Data/OptList.pm
  5. +87 −0 t/hash.t
  6. +127 −0 t/mkopt.t
17 Changes
@@ -0,0 +1,17 @@
+Revision history for Sub-Exporter
+
+0.100 2006-06-05
+ broken out of Sub-Exporter into its own dist
+ renamed routines to be easier to type
+
+
+0.040 2006-05-11 (in Sub-Exporter)
+ tweaks to Data::OptList, moving toward its own dist: now it exports
+ expand_opt_list is now opt_list_as_hash
+
+0.??? 2006-05-10 (in Sub-Exporter)
+ require Params::Util for craftier opt list validation
+
+0.??? 2006-04-26 (in Sub-Exporter)
+ broken out of Sub::Exporter module
+ remove an "optimization" that broke expand_opt_list
14 MANIFEST
@@ -0,0 +1,14 @@
+inc/Module/Install.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/Data/OptList.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+t/mkopt.t
+t/hash.t
15 Makefile.PL
@@ -0,0 +1,15 @@
+use strict;
+use warnings;
+
+use inc::Module::Install;
+
+name ('Data-OptList');
+author ('Ricardo SIGNES <rjbs@cpan.org>');
+license ('perl');
+version_from ('lib/Data/OptList.pm');
+
+requires('Sub::Install' => 0.92); # exporter, needed by Data::OptList
+requires('List::Util' => 0.00); # unknown minimum; used for "first"
+requires('Params::Util' => 0.14); # _HASHLIKE, _ARRAYLIKE, _CODELIKE
+
+WriteAll();
228 lib/Data/OptList.pm
@@ -0,0 +1,228 @@
+
+package Data::OptList;
+use strict;
+use warnings;
+
+=head1 NAME
+
+Data::OptList - parse and validate simple name/value option pairs
+
+=head1 VERSION
+
+version 0.100
+
+ $Id$
+
+=cut
+
+our $VERSION = '0.100';
+
+=head1 SYNOPSIS
+
+ use Data::OptList;
+
+ my $options = Data::Optlist::mkopt([
+ qw(key1 key2 key3 key4),
+ key5 => { ... },
+ key6 => [ ... ],
+ key7 => sub { ... },
+ key8 => { ... },
+ key8 => [ ... ],
+ ]);
+
+...is the same thing, more or less, as:
+
+ my $options = [
+ [ key1 => undef, ],
+ [ key2 => undef, ],
+ [ key3 => undef, ],
+ [ key4 => undef, ],
+ [ key5 => { ... }, ],
+ [ key6 => [ ... ], ],
+ [ key7 => sub { ... }, ],
+ [ key8 => { ... }, ],
+ [ key8 => [ ... ], ],
+ ]);
+
+=head1 DESCRIPTION
+
+Hashes are great for storing named data, but if you want more than one entry
+for a name, you have to use a list of pairs. Even then, this is really boring
+to write:
+
+ @values = (
+ foo => undef,
+ bar => undef,
+ baz => undef,
+ xyz => { ... },
+ );
+
+Just look at all those undefs! Don't worry, we can get rid of those:
+
+ @values = (
+ map { $_ => undef } qw(foo bar baz),
+ xyz => { ... },
+ );
+
+Aaaauuugh! We've saved a little typing, but now it requires thought to read,
+and thinking is even worse than typing.
+
+With Data::OptList, you can do this instead:
+
+ Data::OptList::mkopt([
+ qw(foo bar baz),
+ xyz => { ... },
+ ]);
+
+This works by assuming that any defined scalar is a name and any reference
+following a name is its value.
+
+=cut
+
+use List::Util ();
+use Params::Util ();
+use Sub::Install 0.92 ();
+
+=head1 FUNCTIONS
+
+=head2 mkopt
+
+ my $opt_list = Data::OptList::mkopt(
+ $input,
+ $moniker,
+ $require_unique,
+ $must_be,
+ );
+
+This produces an array of arrays; the inner arrays are name/value pairs.
+Values will be either "undef" or a reference.
+
+Valid inputs:
+
+ undef -> []
+ hashref -> [ [ key1 => value1 ] ... ] # non-ref values become undef
+ arrayref -> every value followed by a ref becomes a pair: [ value => ref ]
+ every value followed by undef becomes a pair: [ value => undef ]
+ otherwise, it becomes [ value => undef ] like so:
+ [ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ]
+
+C<$moniker> is a name describing the data, which will be used in error
+messages.
+
+If C<$require_unique> is true, an error will be thrown if any name is given
+more than once.
+
+C<$must_be> is either a scalar or array of scalars; it defines what kind(s) of
+refs may be values. If an invalid value is found, an exception is thrown. If
+no value is passed for this argument, any reference is valid.
+
+=cut
+
+my %test_for;
+BEGIN {
+ %test_for = (
+ CODE => \&Params::Util::_CODELIKE,
+ HASH => \&Params::Util::_HASHLIKE,
+ ARRAY => \&Params::Util::_ARRAYLIKE,
+ SCALAR => \&Params::Util::_SCALAR0,
+ );
+}
+
+sub __is_a {
+ my ($got, $expected) = @_;
+
+ return List::Util::first { __is_a($got, $_) } @$expected if ref $expected;
+
+ return defined
+ (exists($test_for{$expected}) ? $test_for{$expected}->($got)
+ : Params::Util::_INSTANCE($got, $expected));
+}
+
+sub mkopt {
+ my ($opt_list, $moniker, $require_unique, $must_be) = @_;
+
+ return [] unless $opt_list;
+
+ $opt_list = [
+ map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list
+ ] if ref $opt_list eq 'HASH';
+
+ my @return;
+ my %seen;
+
+ for (my $i = 0; $i < @$opt_list; $i++) {
+ my $name = $opt_list->[$i];
+ my $value;
+
+ if ($require_unique) {
+ Carp::croak "multiple definitions provided for $name" if $seen{$name}++;
+ }
+
+ if ($i == $#$opt_list) { $value = undef; }
+ elsif (not defined $opt_list->[$i+1]) { $value = undef; $i++ }
+ elsif (ref $opt_list->[$i+1]) { $value = $opt_list->[++$i] }
+ else { $value = undef; }
+
+ if ($must_be and defined $value) {
+ unless (__is_a($value, $must_be)) {
+ my $ref = ref $value;
+ Carp::croak "$ref-ref values are not valid in $moniker opt list";
+ }
+ }
+
+ push @return, [ $name => $value ];
+ }
+
+ return \@return;
+}
+
+=head2 mkopt_hash
+
+ my $opt_hash = Data::OptList::mkopt_hash($input, $moniker, $must_be);
+
+Given valid C<mkopt> input, this routine returns a hash. It will throw an
+exception if any name has more than one value.
+
+=cut
+
+sub mkopt_hash {
+ my ($opt_list, $moniker, $must_be) = @_;
+ return {} unless $opt_list;
+
+ $opt_list = mkopt($opt_list, $moniker, 1, $must_be);
+ my %hash = map { $_->[0] => $_->[1] } @$opt_list;
+ return \%hash;
+}
+
+=head1 EXPORTS
+
+Both C<mkopt> and C<mkopt_hash> may be exported on
+request.
+
+=cut
+
+BEGIN {
+ *import = Sub::Install::exporter {
+ exports => [qw(mkopt mkopt_hash)],
+ };
+}
+
+=head1 AUTHOR
+
+Ricardo SIGNES, C<< <rjbs@cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-sub-exporter@rt.cpan.org>,
+or through the web interface at L<http://rt.cpan.org>. I will be notified, and
+then you'll automatically be notified of progress on your bug as I make
+changes.
+
+=head1 COPYRIGHT
+
+Copyright 2006 Ricardo SIGNES. This program is free software; you can
+redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
87 t/hash.t
@@ -0,0 +1,87 @@
+#!perl -T
+use strict;
+use warnings;
+
+=head1 TEST PURPOSE
+
+These tests test option list expansion (from an option list into a hashref).
+
+=cut
+
+use Sub::Install;
+use Test::More tests => 13;
+
+BEGIN { use_ok('Data::OptList'); }
+
+# let's get a convenient copy to use:
+Sub::Install::install_sub({
+ code => 'mkopt_hash',
+ from => 'Data::OptList',
+ as => 'OPTH',
+});
+
+is_deeply(
+ OPTH(),
+ {},
+ "empty opt list expands properly",
+);
+
+is_deeply(
+ OPTH(undef),
+ {},
+ "undef opt list expands properly",
+);
+
+is_deeply(
+ OPTH([]),
+ {},
+ "empty arrayref opt list expands properly",
+);
+
+is_deeply(
+ OPTH({}),
+ {},
+ "empty hashref opt list expands properly",
+);
+
+is_deeply(
+ OPTH([ qw(foo bar baz) ]),
+ { foo => undef, bar => undef, baz => undef },
+ "opt list of just names expands",
+);
+
+is_deeply(
+ OPTH([ qw(foo :bar baz) ]),
+ { foo => undef, ':bar' => undef, baz => undef },
+ "opt list of names expands with :group names",
+);
+
+is_deeply(
+ OPTH([ foo => { a => 1 }, ':bar', 'baz' ]),
+ { foo => { a => 1 }, ':bar' => undef, baz => undef },
+ "opt list of names and values expands",
+);
+
+is_deeply(
+ OPTH([ foo => { a => 1 }, ':bar' => undef, 'baz' ]),
+ { foo => { a => 1 }, ':bar' => undef, baz => undef },
+ "opt list of names and values expands, ignoring undef",
+);
+
+is_deeply(
+ OPTH({ foo => { a => 1 }, -bar => undef, baz => undef }, 0, 'HASH'),
+ { foo => { a => 1 }, -bar => undef, baz => undef },
+ "opt list of names and values expands with must_be",
+);
+
+is_deeply(
+ OPTH({ foo => { a => 1 }, -bar => undef, baz => undef }, 0, ['HASH']),
+ { foo => { a => 1 }, -bar => undef, baz => undef },
+ "opt list of names and values expands with [must_be]",
+);
+
+eval { OPTH({ foo => { a => 1 }, -bar => undef, baz => undef }, 0, 'ARRAY'); };
+like($@, qr/HASH-ref values are not/, "exception tossed on invaild ref value");
+
+eval { OPTH({ foo => { a => 1 }, -bar => undef, baz => undef }, 0, ['ARRAY']); };
+like($@, qr/HASH-ref values are not/, "exception tossed on invaild ref value");
127 t/mkopt.t
@@ -0,0 +1,127 @@
+#!perl -T
+use strict;
+use warnings;
+
+=head1 TEST PURPOSE
+
+These tests test option list cannonization (from an option list into a aref).
+
+=cut
+
+use Sub::Install;
+use Test::More tests => 19;
+
+BEGIN { use_ok('Data::OptList'); }
+
+# let's get a convenient copy to use:
+Sub::Install::install_sub({
+ code => 'mkopt',
+ from => 'Data::OptList',
+});
+
+sub OPT {
+ # specifying moniker is tedious (also, these tests predate them)
+ splice @_, 1, 0, 'test' if @_ > 1;
+ &mkopt;
+}
+
+is_deeply(
+ OPT([]),
+ [],
+ "empty opt list expands properly",
+);
+
+is_deeply(
+ OPT(),
+ [],
+ "undef expands into []",
+);
+
+is_deeply(
+ OPT([ qw(foo bar baz) ]),
+ [ [ foo => undef ], [ bar => undef ], [ baz => undef ] ],
+ "opt list of just names expands",
+);
+
+{
+ my $options = OPT({ foo => undef, bar => 10, baz => [] });
+ $options = [ sort { $a->[0] cmp $b->[0] } @$options ];
+
+ is_deeply(
+ $options,
+ [ [ bar => undef ], [ baz => [] ], [ foo => undef ] ],
+ "hash opt list expands properly"
+ );
+}
+
+is_deeply(
+ OPT([ qw(foo bar baz) ], 0, "ARRAY"),
+ [ [ foo => undef ], [ bar => undef ], [ baz => undef ] ],
+ "opt list of just names expands with must_be",
+);
+
+is_deeply(
+ OPT([ qw(foo :bar baz) ]),
+ [ [ foo => undef ], [ ':bar' => undef ], [ baz => undef ] ],
+ "opt list of names expands with :group names",
+);
+
+is_deeply(
+ OPT([ foo => { a => 1 }, ':bar', 'baz' ]),
+ [ [ foo => { a => 1 } ], [ ':bar' => undef ], [ baz => undef ] ],
+ "opt list of names and values expands",
+);
+
+is_deeply(
+ OPT([ foo => { a => 1 }, ':bar', 'baz' ], 0, 'HASH'),
+ [ [ foo => { a => 1 } ], [ ':bar' => undef ], [ baz => undef ] ],
+ "opt list of names and values expands with must_be",
+);
+
+is_deeply(
+ OPT([ foo => { a => 1 }, ':bar', 'baz' ], 0, ['HASH']),
+ [ [ foo => { a => 1 } ], [ ':bar' => undef ], [ baz => undef ] ],
+ "opt list of names and values expands with [must_be]",
+);
+
+{
+ bless((my $object = {}), 'Test::DOL::Obj');
+ is_deeply(
+ OPT([ foo => $object, ':bar', 'baz' ], 0, 'Test::DOL::Obj'),
+ [ [ foo => $object ], [ ':bar' => undef ], [ baz => undef ] ],
+ "opt list of names and values expands with must_be, must_be object",
+ );
+
+ is_deeply(
+ OPT([ foo => $object, ':bar', 'baz' ], 0, ['Test::DOL::Obj']),
+ [ [ foo => $object ], [ ':bar' => undef ], [ baz => undef ] ],
+ "opt list of names and values expands with [must_be], must_be object",
+ );
+}
+
+eval { OPT([ foo => { a => 1 }, ':bar', 'baz' ], 0, 'ARRAY'); };
+like($@, qr/HASH-ref values are not/, "exception tossed on invaild ref value");
+
+eval { OPT([ foo => { a => 1 }, ':bar', 'baz' ], 0, ['ARRAY']); };
+like($@, qr/HASH-ref values are not/, "exception tossed on invaild ref value");
+
+eval { OPT([ foo => { a => 1 }, ':bar', 'baz' ], 0, 'Test::DOL::Obj'); };
+like($@, qr/HASH-ref values are not/, "exception tossed on invaild ref value");
+
+eval { OPT([ foo => { a => 1 }, ':bar', 'baz' ], 0, ['Test::DOL::Obj']); };
+like($@, qr/HASH-ref values are not/, "exception tossed on invaild ref value");
+
+is_deeply(
+ OPT([ foo => { a => 1 }, ':bar' => undef, 'baz' ]),
+ [ [ foo => { a => 1 } ], [ ':bar' => undef ], [ baz => undef ] ],
+ "opt list of names and values expands, ignoring undef",
+);
+
+eval { OPT([ foo => { a => 1 }, ':bar' => undef, ':bar' ], 1); };
+like($@, qr/multiple definitions/, "require_unique constraint catches repeat");
+
+is_deeply(
+ OPT([ foo => { a => 1 }, ':bar' => undef, 'baz' ], 1),
+ [ [ foo => { a => 1 } ], [ ':bar' => undef ], [ baz => undef ] ],
+ "previously tested expansion OK with require_unique",
+);

0 comments on commit b25daf3

Please sign in to comment.
Something went wrong with that request. Please try again.