From: Vincent Pit Date: Sun, 29 Jun 2008 15:51:50 +0000 (+0200) Subject: Importing Sub-Prototype-Util-0.01.tar.gz X-Git-Tag: v0.01^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Prototype-Util.git;a=commitdiff_plain;h=4b145ee918e94698fe49c6e9240d50cfb2a36c75 Importing Sub-Prototype-Util-0.01.tar.gz --- 4b145ee918e94698fe49c6e9240d50cfb2a36c75 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..58ee230 --- /dev/null +++ b/.gitignore @@ -0,0 +1,16 @@ +blib* +pm_to_blib* + +Makefile{,.old} +Build +_build* + +*.tar.gz +Sub-Prototype-Util-* + +core.* +*.{c,o,so,bs,out,def,exp} + +cover_db +*.{gcda,gcov,gcno} + diff --git a/Changes b/Changes new file mode 100644 index 0000000..7f1a625 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Sub-Prototype-Util + +0.01 2008-04-06 14:00 UTC + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..d3d5726 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,16 @@ +Changes +MANIFEST +Makefile.PL +README +lib/Sub/Prototype/Util.pm +samples/try.pl +t/00-load.t +t/01-import.t +t/10-flatten.t +t/11-recall.t +t/90-boilerplate.t +t/91-pod.t +t/92-pod-coverage.t +t/95-portability-files.t +t/99-kwalitee.t +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..fae446c --- /dev/null +++ b/META.yml @@ -0,0 +1,20 @@ +--- #YAML:1.0 +name: Sub-Prototype-Util +version: 0.01 +abstract: Prototypes-related utility routines. +license: ~ +author: + - Vincent Pit +generated_by: ExtUtils::MakeMaker version 6.42 +distribution_type: module +requires: + Carp: 0 + Exporter: 0 + Scalar::Util: 0 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 +build_requires: + ExtUtils::MakeMaker: 0 + Scalar::Util: 0 + Test::More: 0 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..9decaeb --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,37 @@ +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $BUILD_REQUIRES = { + 'ExtUtils::MakeMaker' => 0, + 'Scalar::Util' => 0, + 'Test::More' => 0, +}; + +sub build_req { + my $tometa = ' >> $(DISTVNAME)/META.yml;'; + my $build_req = 'echo "build_requires:" ' . $tometa; + foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) { + my $ver = $BUILD_REQUIRES->{$mod}; + $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa; + } + return $build_req; +} + +WriteMakefile( + NAME => 'Sub::Prototype::Util', + AUTHOR => 'Vincent Pit ', + VERSION_FROM => 'lib/Sub/Prototype/Util.pm', + ABSTRACT_FROM => 'lib/Sub/Prototype/Util.pm', + PL_FILES => {}, + PREREQ_PM => { + 'Carp' => 0, + 'Exporter' => 0, + 'Scalar::Util' => 0 + }, + dist => { + PREOP => 'pod2text lib/Sub/Prototype/Util.pm > $(DISTVNAME)/README; ' . build_req, + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + clean => { FILES => 'Sub-Prototype-Util-* *.gcov *.gcda *.gcno cover_db' } +); diff --git a/README b/README new file mode 100644 index 0000000..20b9d59 --- /dev/null +++ b/README @@ -0,0 +1,76 @@ +NAME + Sub::Prototype::Util - Prototypes-related utility routines. + +VERSION + Version 0.01 + +SYNOPSIS + use Sub::Prototype::Util qw/flatten recall/; + + my @a = qw/a b c/; + my @args = ( \@a, 1, { d => 2 }, undef, 3 ); + + my @flat = flatten '\@$;$', @args; # ('a', 'b', 'c', 1, { d => 2 }) + recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3 + +DESCRIPTION + Prototypes are evil, but sometimes you just have to bear with them, + especially when messing with core functions. This module provides + several utilities aimed at faciliting "overloading" of prototyped + functions. + + They all handle 5.10's "_" prototype. + +FUNCTIONS + "flatten $proto, @args" + Flattens the array @args according to the prototype $proto. When @args + is what @_ is after calling a subroutine with prototype $proto, + "flatten" returns the list of what @_ would have been if there were no + prototype. + + "recall $name, @args" + Calls the function $name with the prototyped argument list @args. That + is, @args should be what @_ is when you define a subroutine with the + same prototype as $name. For example, + + my $a = [ ]; + recall 'CORE::push', $a, 1, 2, 3; + + will call "push @$a, 1, 2, 3" and so fill the arrayref $a with "1, 2, + 3". This is especially needed for core functions because you can't + "goto" into them. + +EXPORT + The functions "flatten" and "recall" are only exported on request, + either by providing their name or by the ':consts' and ':all' tags. + +DEPENDENCIES + Carp (core module since perl 5), Scalar::Util (since 5.7.3). + +AUTHOR + Vincent Pit, "", . + + You can contact me by mail or on #perl @ FreeNode (vincent or + Prof_Vince). + +BUGS + Please report any bugs or feature requests to "bug-sub-prototype-util at + rt.cpan.org", or through the web interface at + . I + will be notified, and then you'll automatically be notified of progress + on your bug as I make changes. + +SUPPORT + You can find documentation for this module with the perldoc command. + + perldoc Sub::Prototype::Util + + Tests code coverage report is available at + . + +COPYRIGHT & LICENSE + Copyright 2008 Vincent Pit, all rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm new file mode 100644 index 0000000..f090f87 --- /dev/null +++ b/lib/Sub/Prototype/Util.pm @@ -0,0 +1,181 @@ +package Sub::Prototype::Util; + +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +=head1 NAME + +Sub::Prototype::Util - Prototypes-related utility routines. + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +=head1 SYNOPSIS + + use Sub::Prototype::Util qw/flatten recall/; + + my @a = qw/a b c/; + my @args = ( \@a, 1, { d => 2 }, undef, 3 ); + + my @flat = flatten '\@$;$', @args; # ('a', 'b', 'c', 1, { d => 2 }) + recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3 + +=head1 DESCRIPTION + +Prototypes are evil, but sometimes you just have to bear with them, especially when messing with core functions. This module provides several utilities aimed at faciliting "overloading" of prototyped functions. + +They all handle C<5.10>'s C<_> prototype. + +=head1 FUNCTIONS + +=cut + +my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/; + +sub _check_ref { + my ($a, $p) = @_; + my $r; + if (!defined $a || !defined($r = reftype $a)) { # not defined or plain scalar + croak 'Got ' . ((defined $a) ? 'a plain scalar' : 'undef') + . ' where a reference was expected'; + } + croak 'Unexpected ' . $r . ' reference' unless exists $sigils{$r} + and $p =~ /\Q$sigils{$r}\E/; + return $r; +} + +=head2 C + +Flattens the array C<@args> according to the prototype C<$proto>. When C<@args> is what C<@_> is after calling a subroutine with prototype C<$proto>, C returns the list of what C<@_> would have been if there were no prototype. + +=cut + +sub flatten { + my $proto = shift; + return @_ unless defined $proto; + my @args; + while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) { + my $p = $2; + if ($1) { + my $a = shift; + my $r = _check_ref $a, $p; + my %deref = ( + SCALAR => sub { push @args, $$a }, + ARRAY => sub { push @args, @$a }, + HASH => sub { push @args, %$a }, + GLOB => sub { push @args, *$a }, + CODE => sub { push @args, &$a } + ); + $deref{$r}->(); + } elsif ($p =~ /[\@\%]/) { + push @args, @_; + last; + } elsif ($p eq '_') { + push @args, $_; + } else { + push @args, shift; + } + } + return @args; +} + +=head2 C + +Calls the function C<$name> with the prototyped argument list C<@args>. That is, C<@args> should be what C<@_> is when you define a subroutine with the same prototype as C<$name>. For example, + + my $a = [ ]; + recall 'CORE::push', $a, 1, 2, 3; + +will call C and so fill the arrayref C<$a> with C<1, 2, 3>. This is especially needed for core functions because you can't C into them. + +=cut + +sub recall { + my ($name, @a) = @_; + croak 'Wrong subroutine name' unless $name; + $name =~ s/^\s+//; + $name =~ s/[\s\$\@\%\*\&;].*//; + my $proto = prototype $name; + my @args; + if (defined $proto) { + my $i = 0; + while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) { + my $p = $2; + if ($1) { + my $r = _check_ref $a[$i], $p; + push @args, join '', $sigils{$r}, '{$a[', $i, ']}'; + } elsif ($p =~ /[\@\%]/) { + push @args, join '', '@a[', $i, '..', (@a - 1), ']'; + last; + } elsif ($p =~ /\&/) { + push @args, 'sub{&{$a[' . $i . ']}}'; + } elsif ($p eq '_') { + push @args, '$_'; + } else { + push @args, '$a[' . $i . ']'; + } + ++$i; + } + } else { + @args = map '$a[' . $_ . ']', 0 .. @a - 1; + } + my @ret = eval $name . '(' . join(',', @args) . ');'; + croak $@ if $@; + return @ret; +} + +=head1 EXPORT + +The functions L and L are only exported on request, either by providing their name or by the C<':consts'> and C<':all'> tags. + +=cut + +use base qw/Exporter/; + +our @EXPORT = (); +our %EXPORT_TAGS = ( + 'funcs' => [ qw/flatten recall/ ] +); +our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; +$EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; + +=head1 DEPENDENCIES + +L (core module since perl 5), L (since 5.7.3). + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Sub::Prototype::Util + +Tests code coverage report is available at L. + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; # End of Sub::Prototype::Util diff --git a/samples/try.pl b/samples/try.pl new file mode 100755 index 0000000..c9fbe07 --- /dev/null +++ b/samples/try.pl @@ -0,0 +1,23 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Data::Dumper; + +use lib qw{blib/lib}; + +use Sub::Prototype::Util qw/flatten recall/; + +my @a = qw/a b c/; +print "At the beginning, \@a contains :\n", Dumper(\@a); + +my @args = ( \@a, 1, { d => 2 }, undef, 3 ); +print "Our arguments are :\n", Dumper(\@args); + +my $proto = '\@$;$'; +my @flat = flatten $proto, @args; # ('a', 'b', 'c', 1, { d => 2 }) +print "When flatten with prototype $proto, this gives :\n", Dumper(\@flat); + +recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3 +print "After recalling CORE::push with \@args, \@a contains :\n", Dumper(\@a); diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..37608dd --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok( 'Sub::Prototype::Util' ); +} + +diag( "Testing Sub::Prototype::Util $Sub::Prototype::Util::VERSION, Perl $], $^X" ); diff --git a/t/01-import.t b/t/01-import.t new file mode 100644 index 0000000..30b94d2 --- /dev/null +++ b/t/01-import.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 2; + +require Sub::Prototype::Util; + +for (qw/flatten recall/) { + eval { Sub::Prototype::Util->import($_) }; + ok(!$@, 'import ' . $_); +} diff --git a/t/10-flatten.t b/t/10-flatten.t new file mode 100644 index 0000000..05f56e7 --- /dev/null +++ b/t/10-flatten.t @@ -0,0 +1,49 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 26; + +use Sub::Prototype::Util qw/flatten/; + +eval { flatten '\@', undef }; +like($@, qr/^Got\s+undef/, 'flatten "\@", undef croaks'); +eval { flatten '\@', 1 }; +like($@, qr/^Got\s+a\s+plain\s+scalar/, 'flatten "\@", scalar croaks'); +eval { flatten '\@', { foo => 1 } }; +like($@, qr/^Unexpected\s+HASH\s+reference/, 'flatten "\@", hashref croaks'); +eval { flatten '\@', \(\1) }; +like($@, qr/^Unexpected\s+REF\s+reference/, 'flatten "\@", double ref croaks'); + +my $a = [ 1, 2, 3 ]; +my $b = [ [ 1, 2 ], 3, { 4 => 5 }, undef, \6 ]; +sub hlagh { return 'HLAGH' }; +my @tests = ( + [ undef, 'undef prototype', $a, $a ], + [ '', 'empty prototype', $a, [ ] ], + [ '$', 'truncating to 1', $a, [ 1 ] ], + [ '$$', 'truncating to 2', $a, [ 1, 2 ] ], + [ '$;$', 'truncating to 1+1', $a, [ 1, 2 ] ], + [ '@', 'globbing with @', $a, $a ], + [ '@@', 'globbing with @@', $a, $a ], + [ '%', 'globbing with %', $a, $a ], + [ '%%', 'globbing with %%', $a, $a ], + [ '@%', 'globbing with @%', $a, $a ], + [ '%@', 'globbing with %@', $a, $a ], + [ '\@', 'arrayref and truncate to 1', $b, [ 1, 2 ] ], + [ '\@$$', 'arrayref and truncate to 3', $b, [ 1, 2, 3, { 4 => 5 } ] ], + [ '$$\%', 'hashref and truncate to 3', $b, [ [ 1, 2 ], 3, 4, 5 ] ], + [ '$$\%', 'hashref and truncate to 3', $b, [ [ 1, 2 ], 3, 4, 5 ] ], + [ '\@$\%$\$', 'all usual references', $b, [ 1, 2, 3, 4, 5, undef, 6 ] ], + [ '\*$', 'globref', [ \*main::STDOUT, 1 ], [ '*main::STDOUT', 1 ] ], + [ '\&$', 'coderef', [ \&main::hlagh, 1 ], [ 'HLAGH', 1 ] ], + [ '\[$@%]', 'class got scalarref', [ \1 ], [ 1 ] ], + [ '\[$@%]', 'class got arrayref', [ [ 1 ] ], [ 1 ] ], + [ '\[$@%]', 'class got hashref', [ { 1,2 } ], [ 1, 2 ] ] +); +my $l = [ '_', '$_', [ ] ]; +$l->[3] = [ $l ]; +push @tests, $l; + +is_deeply( [ flatten($_->[0], @{$_->[2]}) ], $_->[3], $_->[1]) for @tests; diff --git a/t/11-recall.t b/t/11-recall.t new file mode 100644 index 0000000..3e3c7a2 --- /dev/null +++ b/t/11-recall.t @@ -0,0 +1,42 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 3 + 12 + (($^V ge v5.10.0) ? 2 : 0); + +use Scalar::Util qw/set_prototype/; +use Sub::Prototype::Util qw/recall/; + +eval { recall undef }; +like($@, qr/^Wrong\s+subroutine/, 'recall undef croaks'); +eval { recall '' }; +like($@, qr/^Wrong\s+subroutine/, 'recall "" croaks'); +eval { recall 'hlagh' }; +like($@, qr/^Undefined\s+subroutine/, 'recall croaks'); + +sub noproto { $_[1], $_[0] } +sub mytrunc ($;$) { $_[1], $_[0] }; +sub mygrep1 (&@) { grep { $_[0]->() } @_[1 .. $#_] }; +sub mygrep2 (\&@) { grep { $_[0]->() } @_[1 .. $#_] }; +my $t = [ 1, 2, 3, 4 ]; +my $g = [ sub { $_ > 2 }, 1 .. 5 ]; +my @tests = ( + [ 'main::noproto', 'no prototype', $t, $t, [ 2, 1 ] ], + [ 'CORE::push', 'push', [ [ 1, 2 ], 3, 5 ], [ [ 1, 2, 3, 5 ], 3, 5 ], [ 4 ] ], + [ 'main::mytrunc', 'truncate 1', [ 1 ], [ 1 ], [ undef, 1 ] ], + [ 'main::mytrunc', 'truncate 2', $t, $t, [ 2, 1 ] ], + [ 'main::mygrep1', 'grep1', $g, $g, [ 3 .. 5 ] ], + [ 'main::mygrep2', 'grep2', $g, $g, [ 3 .. 5 ] ], +); +sub myit { push @{$_->[2]}, 1; return 2 }; +if ($^V ge v5.10.0) { + set_prototype \&myit, '_'; + push @tests, [ 'main::myit', '_ prototype', [ ], [ 1 ], [ 2 ] ]; +} + +for (@tests) { + my $r = [ recall $_->[0], @{$_->[2]} ]; + is_deeply($r, $_->[4], $_->[1] . ' return value'); + is_deeply($_->[2], $_->[3], $_->[1] . ' arguments modification'); +} diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t new file mode 100644 index 0000000..4e282ce --- /dev/null +++ b/t/90-boilerplate.t @@ -0,0 +1,49 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 3; + +sub not_in_file_ok { + my ($filename, %regex) = @_; + open( my $fh, '<', $filename ) + or die "couldn't open $filename for reading: $!"; + + my %violated; + + while (my $line = <$fh>) { + while (my ($desc, $regex) = each %regex) { + if ($line =~ $regex) { + push @{$violated{$desc}||=[]}, $.; + } + } + } + + if (%violated) { + fail("$filename contains boilerplate text"); + diag "$_ appears on lines @{$violated{$_}}" for keys %violated; + } else { + pass("$filename contains no boilerplate text"); + } +} + +sub module_boilerplate_ok { + my ($module) = @_; + not_in_file_ok($module => + 'the great new $MODULENAME' => qr/ - The great new /, + 'boilerplate description' => qr/Quick summary of what the module/, + 'stub function definition' => qr/function[12]/, + ); +} + +not_in_file_ok(README => + "The README is used..." => qr/The README is used/, + "'version information here'" => qr/to provide version information/, +); + +not_in_file_ok(Changes => + "placeholder date/time" => qr(Date/time) +); + +module_boilerplate_ok('lib/Sub/Prototype/Util.pm'); diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..62d2d7f --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..3037c13 --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,19 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; + +all_pod_coverage_ok(); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Portability::Files"; +plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@; +run_tests(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..7775e60 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,9 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval { require Test::Kwalitee; Test::Kwalitee->import() }; +plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;