From 34db5d046c28cbbc2b00b78a9184806961dd215f Mon Sep 17 00:00:00 2001 From: Rhesa Rozendaal Date: Thu, 23 Oct 2008 19:38:59 +0200 Subject: [PATCH] initial revision --- .cvsignore | 11 ++ Build.PL | 20 +++ Changes | 5 + MANIFEST | 15 ++ MANIFEST.SKIP | 40 ++++++ README | 56 ++++++++ lib/Method/Signatures/Simple.pm | 181 +++++++++++++++++++++++++ t/00-load.t | 9 ++ t/01-parse-proto.t | 25 ++++ t/02-use.t | 36 +++++ t/boilerplate.t | 55 ++++++++ t/pod-coverage.t | 18 +++ t/pod.t | 12 ++ xt/lib/Devel/Declare/Context/Simple.pm | 110 +++++++++++++++ xt/lib/Devel/Declare/MethodInstaller/Simple.pm | 108 +++++++++++++++ 15 files changed, 701 insertions(+) create mode 100644 .cvsignore create mode 100644 Build.PL create mode 100644 Changes create mode 100644 MANIFEST create mode 100644 MANIFEST.SKIP create mode 100644 README create mode 100644 lib/Method/Signatures/Simple.pm create mode 100644 t/00-load.t create mode 100644 t/01-parse-proto.t create mode 100644 t/02-use.t create mode 100644 t/boilerplate.t create mode 100644 t/pod-coverage.t create mode 100644 t/pod.t create mode 100644 xt/lib/Devel/Declare/Context/Simple.pm create mode 100644 xt/lib/Devel/Declare/MethodInstaller/Simple.pm diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..5c6206e --- /dev/null +++ b/.cvsignore @@ -0,0 +1,11 @@ +blib* +Makefile +Makefile.old +Build +_build* +pm_to_blib* +*.tar.gz +.lwpcookies +Method-Signatures-Simple-* +cover_db +.git* diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..384e238 --- /dev/null +++ b/Build.PL @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Module::Build; + +my $builder = Module::Build->new( + module_name => 'Method::Signatures::Simple', + license => 'perl', + dist_author => 'Rhesa Rozendaal ', + dist_version_from => 'lib/Method/Signatures/Simple.pm', + build_requires => { + 'Test::More' => 0, + }, + requires => { + 'Devel::Declare' => '0.002002_01', + }, + add_to_cleanup => [ 'Method-Signatures-Simple-*' ], + create_makefile_pl => 'traditional', +); + +$builder->create_build_script(); diff --git a/Changes b/Changes new file mode 100644 index 0000000..31b47f0 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Method-Signatures-Simple + +0.01 2008-10-23 Rhesa Rozendaal + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..0fe877d --- /dev/null +++ b/MANIFEST @@ -0,0 +1,15 @@ +Build.PL +Changes +lib/Method/Signatures/Simple.pm +MANIFEST This list of files +META.yml +README +t/00-load.t +t/01-parse-proto.t +t/02-use.t +t/boilerplate.t +t/pod-coverage.t +t/pod.t +xt/lib/Devel/Declare/Context/Simple.pm +xt/lib/Devel/Declare/MethodInstaller/Simple.pm +Makefile.PL diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..5889e8c --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,40 @@ +# Avoid version control files. +\bRCS\b +\bCVS\b +,v$ +\B\.svn\b +\B\.cvsignore$ +\B\.git\b + +# Avoid Makemaker generated and utility files. +\bMakefile$ +\bblib +\bMakeMaker-\d +\bpm_to_blib$ +\bblibdirs$ +^MANIFEST\.SKIP$ + +# Avoid Module::Build generated and utility files. +\bBuild$ +\bBuild.bat$ +\b_build + +# Avoid Devel::Cover generated files +\bcover_db + +# Avoid temp and backup files. +~$ +\.tmp$ +\.old$ +\.bak$ +\#$ +\.# +\.rej$ + +# Avoid OS-specific files/dirs +# Mac OSX metadata +\B\.DS_Store +# Mac OSX SMB mount metadata files +\B\._ +# Avoid archives of this distribution +\bMethod-Signatures-Simple-[\d\.\_]+ diff --git a/README b/README new file mode 100644 index 0000000..083dc9c --- /dev/null +++ b/README @@ -0,0 +1,56 @@ +Method-Signatures-Simple + +RATIONALE + +This module provides a basic C keyword with simple signatures. It's intentionally simple, +and is supposed to be a stepping stone for its bigger brothers L and L. +It only has a small benefit over regular subs, so if you want more features, look at those modules. +But if you're looking for a small amount of syntactic sugar, this might just be enough. + +SYNOPSIS + + use Method::Signatures::Simple; + + method foo { $self->bar } + + # with signature + method foo($bar, %opts) { + $self->bar(reverse $bar) if $opts{rev}; + } + + # attributes + method foo : lvalue { $self->{foo} } + + # change invocant name + method foo ($class: $bar) { $class->bar($bar) } + + +SUPPORT AND DOCUMENTATION + +After installing, you can find documentation for this module with the +perldoc command. + + perldoc Method::Signatures::Simple + +You can also look for information at: + + RT, CPAN's request tracker + http://rt.cpan.org/NoAuth/Bugs.html?Dist=Method-Signatures-Simple + + AnnoCPAN, Annotated CPAN documentation + http://annocpan.org/dist/Method-Signatures-Simple + + CPAN Ratings + http://cpanratings.perl.org/d/Method-Signatures-Simple + + Search CPAN + http://search.cpan.org/dist/Method-Signatures-Simple + + +COPYRIGHT AND LICENCE + +Copyright (C) 2008 Rhesa Rozendaal + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + diff --git a/lib/Method/Signatures/Simple.pm b/lib/Method/Signatures/Simple.pm new file mode 100644 index 0000000..a001673 --- /dev/null +++ b/lib/Method/Signatures/Simple.pm @@ -0,0 +1,181 @@ +package Method::Signatures::Simple; + +use warnings; +use strict; + +our $VERSION = '0.01_01'; + +use base q/Devel::Declare::MethodInstaller::Simple/; + +sub import { + my $class = shift; + my %opts = @_; + $opts{into} ||= caller; + $opts{invocant} ||= '$self'; + + $class->install_methodhandler( + name => 'method', + %opts, + ); +} + +sub parse_proto { + my $self = shift; + my ($proto) = @_; + $proto ||= ''; + $proto =~ s/[\r\n]//g; + my $invocant = $self->{invocant}; + + $invocant = $1 if $proto =~ s{^(\$\w+):\s*}{}; + + my $inject = "my ${invocant} = shift;"; + $inject .= "my ($proto) = \@_;" if defined $proto and length $proto; + + return $inject; +} + + +=head1 NAME + +Method::Signatures::Simple - Basic method declarations with signatures, without source filters + +=head1 VERSION + +Version 0.01 + +=head1 SYNOPSIS + + use Method::Signatures::Simple; + + method foo { $self->bar } + + # with signature + method foo($bar, %opts) { + $self->bar(reverse $bar) if $opts{rev}; + } + + # attributes + method foo : lvalue { $self->{foo} } + + # change invocant name + method foo ($class: $bar) { $class->bar($bar) } + +=head1 RATIONALE + +This module provides a basic C keyword with simple signatures. It's intentionally simple, +and is supposed to be a stepping stone for its bigger brothers L and L. +It only has a small benefit over regular subs, so if you want more features, look at those modules. +But if you're looking for a small amount of syntactic sugar, this might just be enough. + +=head1 FEATURES + +=over 4 + +=item * invocant + +The C keyword automatically injects the annoying C for you. You can rename +the invocant with the first argument, followed by a colon: + + method ($this:) {} + method ($this: $that) {} + +=item * signature + +The signature C<($sig)> is transformed into C<"my ($sig) = \@_;">. That way, we mimic perl's usual +argument handling. + + method foo ($bar, $baz, %opts) { + + # becomes + + sub foo { + my $self = shift; + my ($bar, $baz, %opts) = @_; + +=back + + +=begin pod-coverage + +=over 4 + +=item parse_proto + +Overridden. + +=back + +=end pod-coverage + +=head1 AUTHOR + +Rhesa Rozendaal, C<< >> + +=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 Method::Signatures::Simple + + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + +=head1 ACKNOWLEDGEMENTS + +=over 4 + +=item * MSTROUT + +For writing L and providing the core concepts. + +=item * MSCHWERN + +For writing L and publishing about it. This is what got my attention. + +=item * FLORA + +For helping me abstracting the Devel::Declare bits and suggesting improvements. + +=back + +=head1 SEE ALSO + +L, L, L. + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 Rhesa Rozendaal, 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 Method::Signatures::Simple diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..8f7fe8d --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,9 @@ +#!perl -T + +use Test::More tests => 1; + +BEGIN { + use_ok( 'Method::Signatures::Simple' ); +} + +diag( "Testing Method::Signatures::Simple $Method::Signatures::Simple::VERSION, Perl $], $^X" ); diff --git a/t/01-parse-proto.t b/t/01-parse-proto.t new file mode 100644 index 0000000..82fb5f7 --- /dev/null +++ b/t/01-parse-proto.t @@ -0,0 +1,25 @@ + +use strict; +use warnings; + +use Test::More tests => 10; + +my $mss = 'Method::Signatures::Simple'; +use_ok $mss; +my $inst = $mss->new(invocant => '$self'); + +my @tests = ( + ['' => [ qr'my \$self = shift;' ]], + ['$class: %opts' => [ qr'my \$class = shift;', qr'my \(\%opts\) = \@_;' ]], + ['@stuff' => [ qr'my \$self = shift;', qr'my \(\@stuff\) = \@_;' ]], + ['$foo, $bar' => [ qr'my \$self = shift;', qr'my \(\$foo, \$bar\) = \@_;' ]], + ["$/foo, $/bar$/" => [ qr'my \$self = shift;', qr'my \(foo, bar\) = \@_;' ]], +); + +for my $t (@tests) { + my $p = $inst->parse_proto($t->[0]); + for my $match (@{$t->[1]}) { + like $p, $match; # , "$t->[0] matches $match"; + } +} + diff --git a/t/02-use.t b/t/02-use.t new file mode 100644 index 0000000..3546254 --- /dev/null +++ b/t/02-use.t @@ -0,0 +1,36 @@ + +use strict; +use warnings; + +use Test::More tests => 7; +use_ok 'Method::Signatures::Simple'; + +{ + package My::Obj; + use Method::Signatures::Simple; + + method make($class: %opts) { + bless {%opts}, $class; + } + method first : lvalue { + $self->{first}; + } + method second { + $self->first + 1; + } + method nth($inc) { + $self->first + $inc; + } +} + +my $o = My::Obj->make(first => 1); +is $o->first, 1; +is $o->second, 2; +is $o->nth(10), 11; + +$o->first = 10; + +is $o->first, 10; +is $o->second, 11; +is $o->nth(10), 20; + diff --git a/t/boilerplate.t b/t/boilerplate.t new file mode 100644 index 0000000..1a6d4c2 --- /dev/null +++ b/t/boilerplate.t @@ -0,0 +1,55 @@ +#!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]/, + ); +} + +TODO: { + local $TODO = "Need to replace the boilerplate text"; + + 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/Method/Signatures/Simple.pm'); + + +} + diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..fc40a57 --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,18 @@ +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/pod.t b/t/pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/pod.t @@ -0,0 +1,12 @@ +#!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/xt/lib/Devel/Declare/Context/Simple.pm b/xt/lib/Devel/Declare/Context/Simple.pm new file mode 100644 index 0000000..7b0f740 --- /dev/null +++ b/xt/lib/Devel/Declare/Context/Simple.pm @@ -0,0 +1,110 @@ +package Devel::Declare::Context::Simple; + +use Devel::Declare (); +use B::Hooks::EndOfScope; +use strict; +use warnings; + +sub DEBUG { warn "@_" } +sub new { + my $class = shift; + bless {@_}, $class; +} + +sub init { + my $self = shift; + @{$self}{ qw(Declarator Offset) } = @_; + $self; +} + +sub offset : lvalue { shift->{Offset}; } +sub declarator { shift->{Declarator} } + +sub skip_declarator { + my $self = shift; + $self->offset += Devel::Declare::toke_move_past_token( $self->offset ); +} + +sub skipspace { + my $self = shift; + $self->offset += Devel::Declare::toke_skipspace( $self->offset ); +} + +sub strip_name { + my $self = shift; + $self->skipspace; + if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) { + my $linestr = Devel::Declare::get_linestr(); + my $name = substr( $linestr, $self->offset, $len ); + substr( $linestr, $self->offset, $len ) = ''; + Devel::Declare::set_linestr($linestr); + return $name; + } + + $self->skipspace; + return; +} + +sub strip_proto { + my $self = shift; + $self->skipspace; + + my $linestr = Devel::Declare::get_linestr(); + if (substr($linestr, $self->offset, 1) eq '(') { + my $length = Devel::Declare::toke_scan_str($self->offset); + my $proto = Devel::Declare::get_lex_stuff(); + Devel::Declare::clear_lex_stuff(); + $linestr = Devel::Declare::get_linestr(); + substr($linestr, $self->offset, $length) = ''; + Devel::Declare::set_linestr($linestr); + return $proto; + } + + return; +} + +sub get_curstash_name { + return Devel::Declare::get_curstash_name; +} + +sub shadow { + my $self = shift; + my $pack = $self->get_curstash_name; + Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] ); +} + +sub inject_if_block { + my $self = shift; + my $inject = shift; + my $before = shift || ''; + + $self->skipspace; + + my $linestr = Devel::Declare::get_linestr; + if (substr($linestr, $self->offset, 1) eq '{') { + substr($linestr, $self->offset + 1, 0) = $inject; + substr($linestr, $self->offset, 0) = $before; + Devel::Declare::set_linestr($linestr); + } +} + +sub scope_injector_call { + my $self = shift; + my $inject = shift || ''; + return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; "; +} + +sub inject_scope { + my $class = shift; + my $inject = shift; + on_scope_end { + my $linestr = Devel::Declare::get_linestr; + return unless defined $linestr; + my $offset = Devel::Declare::get_linestr_offset; + substr( $linestr, $offset, 0 ) = ';' . $inject; + Devel::Declare::set_linestr($linestr); + }; +} + +1; +# vi:sw=2 ts=2 diff --git a/xt/lib/Devel/Declare/MethodInstaller/Simple.pm b/xt/lib/Devel/Declare/MethodInstaller/Simple.pm new file mode 100644 index 0000000..96fa88c --- /dev/null +++ b/xt/lib/Devel/Declare/MethodInstaller/Simple.pm @@ -0,0 +1,108 @@ +package Devel::Declare::MethodInstaller::Simple; + +use base 'Devel::Declare::Context::Simple'; + +use Devel::Declare (); +use Sub::Name; +use strict; +use warnings; + +sub install_methodhandler { + my $class = shift; + my %args = @_; + { + no strict 'refs'; + *{$args{into}.'::'.$args{name}} = sub (&) {}; + } + + my $ctx = $class->new(%args); + Devel::Declare->setup_for( + $args{into}, + { $args{name} => { const => sub { $ctx->parser(@_) } } } + ); +} + +sub strip_attrs { + my $self = shift; + $self->skipspace; + + my $Offset = $self->offset; + my $linestr = Devel::Declare::get_linestr; + my $attrs = ''; + + if (substr($linestr, $Offset, 1) eq ':') { + while (substr($linestr, $Offset, 1) ne '{') { + if (substr($linestr, $Offset, 1) eq ':') { + substr($linestr, $Offset, 1) = ''; + Devel::Declare::set_linestr($linestr); + + $attrs .= ':'; + } + + $self->skipspace; + $Offset = $self->offset; + $linestr = Devel::Declare::get_linestr(); + + if (my $len = Devel::Declare::toke_scan_word($Offset, 0)) { + my $name = substr($linestr, $Offset, $len); + substr($linestr, $Offset, $len) = ''; + Devel::Declare::set_linestr($linestr); + + $attrs .= " ${name}"; + + if (substr($linestr, $Offset, 1) eq '(') { + my $length = Devel::Declare::toke_scan_str($Offset); + my $arg = Devel::Declare::get_lex_stuff(); + Devel::Declare::clear_lex_stuff(); + $linestr = Devel::Declare::get_linestr(); + substr($linestr, $Offset, $length) = ''; + Devel::Declare::set_linestr($linestr); + + $attrs .= "(${arg})"; + } + } + } + + $linestr = Devel::Declare::get_linestr(); + } + + return $attrs; +} + +sub parser { + my $self = shift; + $self->init(@_); + + $self->skip_declarator; + my $name = $self->strip_name; + my $proto = $self->strip_proto; + my $attrs = $self->strip_attrs; + my @decl = $self->parse_proto($proto); + my $inject = $self->inject_parsed_proto(@decl); + if (defined $name) { + $inject = $self->scope_injector_call() . $inject; + } + $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : ''); + if (defined $name) { + my $pkg = $self->get_curstash_name; + $name = join( '::', $pkg, $name ) + unless( $name =~ /::/ ); + $self->shadow( sub (&) { + my $code = shift; + # So caller() gets the subroutine name + no strict 'refs'; + *{$name} = subname $name => $code; + }); + } else { + $self->shadow(sub (&) { shift }); + } +} + +sub parse_proto { } + +sub inject_parsed_proto { + return $_[1]; +} + +1; + -- 2.11.4.GIT