X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFunction%2FParameters.pm;h=8f58d1520df5687baa164303e3fd15bcd680bbe3;hb=e158cf8f49978f42fb2380d3f84c5df963a39a3f;hp=69aa627035e72c0d7fde456eff9e54170ad77728;hpb=43aeb85887215bcd044a9b8bc0f67d8ab7beecf2;p=p5sagit%2FFunction-Parameters.git diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index 69aa627..8f58d15 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -1,40 +1,18 @@ package Function::Parameters; +use v5.14.0; + use strict; use warnings; -our $VERSION = '0.05'; - -use Carp qw(croak confess); -use Devel::Declare; -use B::Hooks::EndOfScope; - -our @CARP_NOT = qw(Devel::Declare); - - -# Make our import chainable so a wrapper module that wants to turn on F:P -# for its users can just say -# sub import { Function::Parameters->import; } -# -# To make that possible we skip all subs named 'import' in our search for the -# target package. -# -sub guess_caller { - my ($start) = @_; - $start ||= 1; +use Carp qw(confess); - my $defcaller = (caller $start)[0]; - my $caller = $defcaller; - - for (my $level = $start; ; ++$level) { - my ($pkg, $function) = (caller $level)[0, 3] or last; - $function =~ /::import\z/ or return $caller; - $caller = $pkg; - } - $defcaller +use XSLoader; +BEGIN { + our $VERSION = '0.10_01'; + XSLoader::load; } - sub _assert_valid_identifier { my ($name, $with_dollar) = @_; my $bonus = $with_dollar ? '\$' : ''; @@ -42,21 +20,63 @@ sub _assert_valid_identifier { or confess qq{"$name" doesn't look like a valid identifier}; } -# Parse import spec and make shit happen. -# +sub _assert_valid_attributes { + my ($attrs) = @_; + $attrs =~ /^\s*:\s*[^\W\d]\w*\s*(?:(?:\s|:\s*)[^\W\d]\w*\s*)*(?:\(|\z)/ + or confess qq{"$attrs" doesn't look like valid attributes}; +} + my @bare_arms = qw(function method); my %type_map = ( - function => { name => 'optional' }, - method => { name => 'optional', shift => '$self' }, + function => { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + named_parameters => 1, + }, + method => { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + named_parameters => 1, + attrs => ':method', + shift => '$self', + invocant => 1, + }, + classmethod => { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + named_parameters => 1, + attributes => ':method', + shift => '$class', + invocant => 1, + }, ); +for my $k (keys %type_map) { + $type_map{$k . '_strict'} = { + %{$type_map{$k}}, + check_argument_count => 1, + }; +} -sub import_into { - my $victim = shift; +sub import { + my $class = shift; - @_ or @_ = ('fun', 'method'); + if (!@_) { + @_ = { + fun => 'function', + method => 'method', + }; + } + if (@_ == 1 && $_[0] eq ':strict') { + @_ = { + fun => 'function_strict', + method => 'method_strict', + }; + } if (@_ == 1 && ref($_[0]) eq 'HASH') { - @_ = map [$_, $_[0]{$_}], keys %{$_[0]} - or return; + @_ = map [$_, $_[0]{$_}], keys %{$_[0]}; } my %spec; @@ -67,287 +87,81 @@ sub import_into { ? $proto : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})] ; - my ($name, $type) = @$item; + my ($name, $proto_type) = @$item; _assert_valid_identifier $name; - unless (ref $type) { - # use '||' instead of 'or' to preserve $type in the error message - $type = $type_map{$type} - || confess qq["$type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})]; + unless (ref $proto_type) { + # use '||' instead of 'or' to preserve $proto_type in the error message + $proto_type = $type_map{$proto_type} + || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})]; } - $type->{name} ||= 'optional'; - $type->{name} =~ /^(?:optional|required|prohibited)\z/ - or confess qq["$type->{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)]; - $type->{shift} - and _assert_valid_identifier $type->{shift}, 1; - - $spec{$name} = {const => mk_parse($type)}; - } - - Devel::Declare->setup_for($victim, \%spec); - for my $name (keys %spec) { - no strict 'refs'; - *{$victim . '::' . $name} = \&_declarator; - } -} - -sub import { - my $class = shift; - my $caller = guess_caller; - import_into $caller, @_; -} - -sub _declarator { - $_[0] -} - -# Wrapper around substr where param 3 is an end offset, not a length. -# -sub _substring { - @_ >= 4 - ? substr $_[0], $_[1], $_[2] - $_[1], $_[3] - : substr $_[0], $_[1], $_[2] - $_[1] -} + my %type = %$proto_type; + my %clean; -sub _skip_space { - my ($ctx, $key) = @_; - my $cur = my $start = $ctx->{offset}; - while (my $d = Devel::Declare::toke_skipspace $cur) { - $cur += $d; - } - $ctx->{space}{$key} .= _substring Devel::Declare::get_linestr, $start, $cur if $key; - $ctx->{offset} = $cur; -} - -sub _grab_name { - my ($ctx) = @_; - my $p = $ctx->{offset}; - my $namlen = Devel::Declare::toke_scan_word $p, !!'handle_package' - or return; - my $str = Devel::Declare::get_linestr; - $ctx->{name} = substr $str, $p, $namlen; - $ctx->{offset} += $namlen; - _skip_space $ctx, 'name'; -} + $clean{name} = delete $type{name} || 'optional'; + $clean{name} =~ /^(?:optional|required|prohibited)\z/ + or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)]; -sub _grab_params { - my ($ctx) = @_; - substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(' - or return; - $ctx->{offset}++; - _skip_space $ctx, 'params'; - - my $pcount = 0; - - LOOP: { - my $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1; - - if ($c =~ /^[\$\@%]\z/) { - $ctx->{offset}++; - _skip_space $ctx, "params_$pcount"; - my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package' - or croak "Missing identifier"; - my $name = substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen; - $ctx->{params} .= $c . $name . ','; - $ctx->{offset} += $namlen; - _skip_space $ctx, "params_$pcount"; - - $c = substr Devel::Declare::get_linestr, $ctx->{offset}, 1; - if ($c eq ',') { - $ctx->{offset}++; - _skip_space $ctx, "params_$pcount"; - $pcount++; - redo LOOP; - } - } + $clean{shift} = delete $type{shift} || ''; + _assert_valid_identifier $clean{shift}, 1 if $clean{shift}; - if ($c eq ')') { - $ctx->{offset}++; - _skip_space $ctx, 'params'; - return; - } + $clean{attrs} = join ' ', map delete $type{$_} || (), qw(attributes attrs); + _assert_valid_attributes $clean{attrs} if $clean{attrs}; + + $clean{default_arguments} = + exists $type{default_arguments} + ? !!delete $type{default_arguments} + : 1 + ; + $clean{check_argument_count} = !!delete $type{check_argument_count}; + $clean{invocant} = !!delete $type{invocant}; + $clean{named_parameters} = !!delete $type{named_parameters}; - if ($c eq '') { - croak "Unexpected EOF in parameter list"; - } + %type and confess "Invalid keyword property: @{[keys %type]}"; - croak "Unexpected '$c' in parameter list"; + $spec{$name} = \%clean; } -} - -sub _parse_parens { - my ($ctx) = @_; - - my $strlen = Devel::Declare::toke_scan_str $ctx->{offset}; - $strlen == 0 || $strlen == -1 and return; - - $strlen < 0 and confess "Devel::Declare::toke_scan_str done fucked up ($strlen); see https://rt.cpan.org/Ticket/Display.html?id=51679"; - - my $str = Devel::Declare::get_lex_stuff; - Devel::Declare::clear_lex_stuff; - - $ctx->{offset} += $strlen; - - $str -} - -sub _grab_proto { - my ($ctx) = @_; - - my $savepos = $ctx->{offset}; - - substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':' - or return; - $ctx->{offset}++; - _skip_space $ctx, 'proto_tmp'; + + for my $kw (keys %spec) { + my $type = $spec{$kw}; - unless (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') { - $ctx->{offset} = $savepos; - delete $ctx->{space}{proto_tmp}; - return; + my $flags = + $type->{name} eq 'prohibited' ? FLAG_ANON_OK : + $type->{name} eq 'required' ? FLAG_NAME_OK : + FLAG_ANON_OK | FLAG_NAME_OK + ; + $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments}; + $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count}; + $flags |= FLAG_INVOCANT if $type->{invocant}; + $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters}; + $^H{HINTK_FLAGS_ . $kw} = $flags; + $^H{HINTK_SHIFT_ . $kw} = $type->{shift}; + $^H{HINTK_ATTRS_ . $kw} = $type->{attrs}; + $^H{+HINTK_KEYWORDS} .= "$kw "; } - $_->{proto} .= delete $_->{proto_tmp} for $ctx->{space}; - - defined(my $str = _parse_parens $ctx) - or croak "Malformed prototype"; - $ctx->{proto} = $str; - - _skip_space $ctx, 'proto'; } -sub _grab_attr { - my ($ctx) = @_; - - my $pcount = 0; +sub unimport { + my $class = shift; - if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') { - $ctx->{offset}++; - _skip_space $ctx, "attr_$pcount"; - } elsif (!defined $ctx->{proto}) { + if (!@_) { + delete $^H{+HINTK_KEYWORDS}; return; } - while () { - my $namlen = Devel::Declare::toke_scan_word $ctx->{offset}, !'handle_package' - or return; - $ctx->{attr} .= substr Devel::Declare::get_linestr, $ctx->{offset}, $namlen; - $ctx->{offset} += $namlen; - _skip_space $ctx, "attr_$pcount"; - if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq '(') { - defined(my $str = _parse_parens $ctx) - or croak "Malformed attribute argument list"; - $ctx->{attr} .= "($str)"; - _skip_space $ctx, "attr_$pcount"; - } - $pcount++; - - if (substr(Devel::Declare::get_linestr, $ctx->{offset}, 1) eq ':') { - $ctx->{offset}++; - _skip_space $ctx, "attr_$pcount"; - } - } -} - -# IN: -# fun name (params) :(proto) :attr { ... } -# OUT: -# fun (do { sub (proto) :attr { self? my (params) = @_; ... } }) -# fun (do { sub name (proto); sub name (proto) :attr { self? my (params) = @_; ... } }); -# -sub _generate { - my ($ctx, $declarator, $shift) = @_; - - my $gen = '(do{sub'; - - my $skipped = join '', values %{$ctx->{space}}; - my $lines = $skipped =~ tr/\n//; - $gen .= "\n" x $lines; - - my $proto = defined $ctx->{proto} ? "($ctx->{proto})" : ''; - - my $is_stmt = 0; - if (defined(my $name = $ctx->{name})) { - $is_stmt = 1; - $gen .= " $name$proto;"; - $gen .= "sub $name"; - } - - $gen .= $proto; - - if (defined $ctx->{attr}) { - $gen .= ":$ctx->{attr}"; - } - - $gen .= '{'; - $gen .= "BEGIN{${\__PACKAGE__}::_fini($is_stmt)}"; - - if ($shift) { - _assert_valid_identifier $shift, 1; - $gen .= "my$shift=shift;"; - } - if (defined $ctx->{params}) { - $gen .= "my($ctx->{params})=\@_;"; - } - $gen -} - -sub mk_parse { - my ($spec) = @_; - - sub { - my ($declarator, $offset_orig) = @_; - my $ctx = { - offset => $offset_orig, - space => {}, - }; - - $ctx->{offset} += Devel::Declare::toke_move_past_token($ctx->{offset}); - _skip_space $ctx; - - my $start = $ctx->{offset}; - - _grab_name $ctx unless $spec->{name} eq 'prohibited'; - $ctx->{name} or croak qq[I was expecting a function name, not "${\substr Devel::Declare::get_linestr, $ctx->{offset}}"] if $spec->{name} eq 'required'; - my $fname = $ctx->{name} || '(anon)'; - _grab_params $ctx; - if ($ctx->{params} && $ctx->{params} =~ /([\@%]\w+),([\$\@%]\w+)/) { - my ($slurpy, $after) = ($1, $2); - croak qq[In $declarator $fname: I was expecting ")" after "$slurpy", not "$after"]; - } - _grab_proto $ctx; - _grab_attr $ctx; - - my $offset = $ctx->{offset}; - - my $linestr = Devel::Declare::get_linestr; - substr($linestr, $offset, 1) eq '{' - or croak qq[In $declarator $fname: I was expecting a function body, not "${\substr $linestr, $offset}"]; - - my $gen = _generate $ctx, $declarator, $spec->{shift}; - my $oldlen = $offset + 1 - $start; - _substring $linestr, $start, $offset + 1, (' ' x $oldlen) . $gen; - Devel::Declare::set_linestr $linestr; + for my $kw (@_) { + $^H{+HINTK_KEYWORDS} =~ s/(?($_); @@ -370,15 +188,51 @@ Function::Parameters - subroutine definitions with parameter lists print "$_\n" for mymap { $_ * 2 } 1 .. 4; + # method with implicit $self method set_name($name) { $self->{name} = $name; } + + # method with explicit invocant + method new($class: %init) { + return bless { %init }, $class; + } + + # function with default arguments + fun search($haystack, $needle = qr/^(?!)/, $offset = 0) { + ... + } + + # method with default arguments + method skip($amount = 1) { + $self->{position} += $amount; + } + +=cut + +=pod + + use Function::Parameters qw(:strict); + + fun greet($x) { + print "Hello, $x\n"; + } + + greet "foo", "bar"; + # Dies at runtime with "Too many arguments for fun greet" + + greet; + # Dies at runtime with "Not enough arguments for fun greet" =cut =pod - use Function::Parameters 'proc', 'meth'; + # use different keywords + use Function::Parameters { + proc => 'function', + meth => 'method', + }; my $f = proc ($x) { $x * 2 }; meth get_age() { @@ -388,12 +242,7 @@ Function::Parameters - subroutine definitions with parameter lists =head1 DESCRIPTION This module lets you use parameter lists in your subroutines. Thanks to -L it works without source filters. - -WARNING: This is my first attempt at using L and I have -almost no experience with perl's internals. So while this module might -appear to work, it could also conceivably make your programs segfault. -Consider this module alpha quality. +L it works without source filters. =head2 Basic stuff @@ -405,7 +254,7 @@ list consists of comma-separated variables. The effect of C is as if you'd written C, i.e. the parameter list is simply -copied into C and initialized from L<@_|perlvar/"@_">. +copied into L and initialized from L<@_|perlvar/"@_">. In addition you can use C, which understands the same syntax as C but automatically creates a C<$self> variable for you. So by writing @@ -414,19 +263,31 @@ C. =head2 Customizing the generated keywords -You can customize the names of the keywords injected in your package. To do that -you pass a hash reference in the import list: +You can customize the names of the keywords injected into your scope. To do +that you pass a reference to a hash mapping keywords to types in the import +list: + + use Function::Parameters { + KEYWORD1 => TYPE1, + KEYWORD2 => TYPE2, + ... + }; + +Or more concretely: use Function::Parameters { proc => 'function', meth => 'method' }; # -or- use Function::Parameters { proc => 'function' }; # -or- - use Function::Parameters { meth => 'method' }; + use Function::Parameters { meth => 'method' }; # etc. The first line creates two keywords, C and C (for defining functions and methods, respectively). The last two lines only create one -keyword. Generally the hash keys can be any identifiers you want while the -values have to be either C, C, or a hash reference (see -below). The difference between C and C is that Cs -automatically L their first argument into C<$self>. +keyword. Generally the hash keys (keywords) can be any identifiers you want +while the values (types) have to be either a hash reference (see below) or +C<'function'>, C<'method'>, C<'classmethod'>, C<'function_strict'>, +C<'method_strict'>, or C<'classmethod_strict'>. The main difference between +C<'function'> and C<'method'> is that C<'method'>s automatically +L their first argument into C<$self> (C<'classmethod'>s +are similar but shift into C<$class>). The following shortcuts are available: @@ -438,6 +299,16 @@ The following shortcuts are available: =pod + use Function::Parameters ':strict'; + # is equivalent to # + use Function::Parameters { fun => 'function_strict', method => 'method_strict' }; + +=pod + +The following shortcuts are deprecated and may be removed from a future version +of this module: + + # DEPRECATED use Function::Parameters 'foo'; # is equivalent to # use Function::Parameters { 'foo' => 'function' }; @@ -446,12 +317,16 @@ The following shortcuts are available: =pod + # DEPRECATED use Function::Parameters 'foo', 'bar'; # is equivalent to # use Function::Parameters { 'foo' => 'function', 'bar' => 'method' }; -You can customize things even more by passing a hashref instead of C -or C. This hash can have the following keys: +That is, if you want to create custom keywords with L, +use a hashref, not a list of strings. + +You can tune the properties of the generated keywords even more by passing +a hashref instead of a string. This hash can have the following keys: =over @@ -466,47 +341,213 @@ only be used for defining anonymous functions. Valid values: strings that look like a scalar variable. Any function created by this keyword will automatically L its first argument into -a local variable with the name specified here. +a local variable whose name is specified here. + +=item C + +Valid values: booleans. This lets users of this keyword specify an explicit +invocant, that is, the first parameter may be followed by a C<:> (colon) +instead of a comma and will by initialized by shifting the first element off +C<@_>. + +You can combine C and C, in which case the variable named in +C serves as a default shift target for functions that don't specify an +explicit invocant. + +=item C, C + +Valid values: strings that are valid source code for attributes. Any value +specified here will be inserted as a subroutine attribute in the generated +code. Thus: + + use Function::Parameters { sub_l => { attributes => ':lvalue' } }; + sub_l foo() { + ... + } + +turns into + + sub foo :lvalue { + ... + } + +It is recommended that you use C in new code but C is also +accepted for now. + +=item C + +Valid values: booleans. This property is on by default, so you have to pass +C<< default_arguments => 0 >> to turn it off. If it is disabled, using C<=> in +a parameter list causes a syntax error. Otherwise it lets you specify +default arguments directly in the parameter list: + + fun foo($x, $y = 42, $z = []) { + ... + } + +turns into + + sub foo { + my ($x, $y, $z) = @_; + $y = 42 if @_ < 2; + $z = [] if @_ < 3; + ... + } + +You can even refer to previous parameters in the same parameter list: + + print fun ($x, $y = $x + 1) { "$x and $y" }->(9); # "9 and 10" + +This also works with the implicit first parameter of methods: + + method scale($factor = $self->default_factor) { + $self->{amount} *= $factor; + } + +=item C + +Valid values: booleans. This property is off by default. If it is enabled, the +generated code will include checks to make sure the number of passed arguments +is correct (and otherwise throw an exception via L): + + fun foo($x, $y = 42, $z = []) { + ... + } + +turns into + + sub foo { + Carp::croak "Not enough arguments for fun foo" if @_ < 1; + Carp::croak "Too many arguments for fun foo" if @_ > 3; + my ($x, $y, $z) = @_; + $y = 42 if @_ < 2; + $z = [] if @_ < 3; + ... + } =back -Plain C is equivalent to C<< { name => 'optional' } >>, and plain -C is equivalent to C<< { name => 'optional', shift => '$self'} >>. +Plain C<'function'> is equivalent to: + + { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + } + +(These are all default values so C<'function'> is also equivalent to C<{}>.) + +C<'function_strict'> is like C<'function'> but with +C<< check_argument_count => 1 >>. + +C<'method'> is equivalent to: + + { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + attributes => ':method', + shift => '$self', + invocant => 1, + } + +C<'method_strict'> is like C<'method'> but with +C<< check_argument_count => 1 >>. + +C<'classmethod'> is equivalent to: + + { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + attributes => ':method', + shift => '$class', + invocant => 1, + } -=head2 Other advanced stuff +C<'classmethod_strict'> is like C<'classmethod'> but with +C<< check_argument_count => 1 >>. + +=head2 Syntax and generated code Normally, Perl subroutines are not in scope in their own body, meaning the -parser doesn't know the name C or its prototype while processing -C, parsing it as +parser doesn't know the name C or its prototype while processing the body +of C, parsing it as C<$bar-Efoo([1], $bar[0])>. Yes. You can add parens to change the interpretation of this code, but C will only trigger a I warning. This module attempts -to fix all of this by adding a subroutine declaration before the definition, +to fix all of this by adding a subroutine declaration before the function body, so the parser knows the name (and possibly prototype) while it processes the body. Thus C really turns into -C. +C. -If you need L, you can +If you need L, you can put them after the parameter list with their usual syntax. Syntactically, these new parameter lists live in the spot normally occupied by L. However, you can include a prototype by specifying it as the first attribute (this is syntactically unambiguous -because normal attributes have to start with a letter). +because normal attributes have to start with a letter while a prototype starts +with C<(>). + +As an example, the following declaration uses every available feature +(subroutine name, parameter list, default arguments, prototype, default +attributes, attributes, argument count checks, and implicit C<$self> overriden +by an explicit invocant declaration): + + method foo($this: $x, $y, $z = sqrt 5) + :($$$;$) + :lvalue + :Banana(2 + 2) + { + ... + } -If you want to wrap C, you may find C -helpful. It lets you specify a target package for the syntax magic, as in: +And here's what it turns into: - package Some::Wrapper; - use Function::Parameters (); - sub import { - my $caller = caller; - Function::Parameters::import_into $caller; - # or Function::Parameters::import_into $caller, @other_import_args; - } + sub foo ($$$;$) :method :lvalue :Banana(2 + 2) { + sub foo ($$$;$); + Carp::croak "Not enough arguments for method foo" if @_ < 3; + Carp::croak "Too many arguments for method foo" if @_ > 4; + my $this = shift; + my ($x, $y, $z) = @_; + $z = sqrt 5 if @_ < 3; + ... + } -C is not exported by this module, so you have to use a fully -qualified name to call it. +Another example: + + my $coderef = fun ($p, $q) + :(;$$) + :lvalue + :Gazebo((>:O)) { + ... + }; + +And the generated code: + + my $coderef = sub (;$$) :lvalue :Gazebo((>:O)) { + # vvv only if check_argument_count is enabled vvv + Carp::croak "Not enough arguments for fun (anon)" if @_ < 2; + Carp::croak "Too many arguments for fun (anon)" if @_ > 2; + # ^^^ ^^^ + my ($p, $q) = @_; + ... + }; + +=head2 Wrapping Function::Parameters + +If you want to wrap L, you just have to call its +C method. It always applies to the file that is currently being parsed +and its effects are L (i.e. it works like L or +L). + + package Some::Wrapper; + use Function::Parameters (); + sub import { + Function::Parameters->import; + # or Function::Parameters->import(@custom_import_args); + } =head1 AUTHOR @@ -514,7 +555,7 @@ Lukas Mai, C<< >> =head1 COPYRIGHT & LICENSE -Copyright 2010, 2011 Lukas Mai. +Copyright 2010, 2011, 2012 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published