X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFunction%2FParameters.pm;h=c87f78eecd2f2d0ab62b9409554eb61ec89ec571;hb=929a23c5b4a988198111135a0922625ab77e5cd9;hp=ac410dff37cffce0eba473ae52ba520634eea8fe;hpb=4316201eec152b4dcf3895358df5633cf0151a2a;p=p5sagit%2FFunction-Parameters.git diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index ac410df..c87f78e 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -1,258 +1,151 @@ package Function::Parameters; +use v5.14.0; + use strict; use warnings; -our $VERSION = '0.04'; - -use Devel::Declare; -use B::Hooks::EndOfScope; -use B::Compiling; - -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; - #warn "? $pkg, $function"; - $function =~ /::import\z/ or return $caller; - $caller = $pkg; - } - $defcaller +use XSLoader; +BEGIN { + our $VERSION = '0.09'; + XSLoader::load; } -sub _fun ($) { $_[0] } - -sub _croak { - require Carp; - { - no warnings qw(redefine); - *_croak = \&Carp::croak; - } - goto &Carp::croak; +sub _assert_valid_identifier { + my ($name, $with_dollar) = @_; + my $bonus = $with_dollar ? '\$' : ''; + $name =~ /^${bonus}[^\W\d]\w*\z/ + or confess qq{"$name" doesn't look like a valid identifier}; } -sub import_into { - my $victim = shift; - my $keyword = @_ ? shift : 'fun'; - - _croak qq["$_" is not exported by the ${\__PACKAGE__} module] for @_; - - $keyword =~ /^[[:alpha:]_]\w*\z/ or _croak qq{"$keyword" does not look like a valid identifier}; - - Devel::Declare->setup_for( - $victim, - { $keyword => { const => \&parser } } - ); +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}; +} - no strict 'refs'; - *{$victim . '::' . $keyword} = \&_fun; +my @bare_arms = qw(function method); +my %type_map = ( + function => { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + }, + method => { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + attrs => ':method', + shift => '$self', + }, + classmethod => { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + attributes => ':method', + shift => '$class', + }, +); +for my $k (keys %type_map) { + $type_map{$k . '_strict'} = { + %{$type_map{$k}}, + check_argument_count => 1, + }; } sub import { my $class = shift; - - my $caller = guess_caller; - #warn "caller = $caller"; - - import_into $caller, @_; -} - -sub report_pos { - my ($offset, $name) = @_; - $name ||= ''; - my $line = Devel::Declare::get_linestr(); - substr $line, $offset + 1, 0, "\x{20de}\e[m"; - substr $line, $offset, 0, "\e[31;1m"; - print STDERR "$name($offset)>> $line\n"; -} -sub parser { - my ($declarator, $start) = @_; - my $offset = $start; - my $line = Devel::Declare::get_linestr(); - - my $fail = do { - my $_file = PL_compiling->file; - my $_line = PL_compiling->line; - sub { - my $n = $_line + substr($line, $start, $offset - $start) =~ tr[\n][]; - die join('', @_) . " at $_file line $n\n"; - } + @_ or @_ = { + fun => 'function', + method => 'method', }; - - my $atomically = sub { - my ($pars) = @_; - sub { - my $tmp = $offset; - my @ret = eval { $pars->(@_) }; - if ($@) { - $offset = $tmp; - die $@; - } - wantarray ? @ret : $ret[0] - } - }; - - my $try = sub { - my ($pars) = @_; - my @ret = eval { $pars->() }; - if ($@) { - return; - } - wantarray ? @ret : $ret[0] - }; - - my $skipws = sub { - #warn ">> $line"; - my $skip = Devel::Declare::toke_skipspace($offset); - if ($skip < 0) { - $skip == -$offset or die "Internal error: offset=$offset, skip=$skip"; - Devel::Declare::set_linestr($line); - return; - } - $line = Devel::Declare::get_linestr(); - #warn "toke_skipspace($offset) = $skip\n== $line"; - $offset += $skip; - }; - - $offset += Devel::Declare::toke_move_past_token($offset); - $skipws->(); - my $manip_start = $offset; - - my $name; - if (my $len = Devel::Declare::toke_scan_word($offset, 1)) { - $name = substr $line, $offset, $len; - $offset += $len; - $skipws->(); + if (@_ == 1 && ref($_[0]) eq 'HASH') { + @_ = map [$_, $_[0]{$_}], keys %{$_[0]} + or return; } - my $scan_token = sub { - my ($str) = @_; - my $len = length $str; - substr($line, $offset, $len) eq $str or $fail->(qq{Missing "$str"}); - $offset += $len; - $skipws->(); - }; + my %spec; + + my $bare = 0; + for my $proto (@_) { + my $item = ref $proto + ? $proto + : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})] + ; + my ($name, $proto_type) = @$item; + _assert_valid_identifier $name; + + 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})]; + } - my $scan_id = sub { - my $len = Devel::Declare::toke_scan_word($offset, 0) or $fail->('Missing identifier'); - my $name = substr $line, $offset, $len; - $offset += $len; - $skipws->(); - $name - }; + my %type = %$proto_type; + my %clean; - my $scan_var = $atomically->(sub { - (my $sigil = substr($line, $offset, 1)) =~ /^[\$\@%]\z/ or $fail->('Missing [$@%]'); - $offset += 1; - $skipws->(); - my $name = $scan_id->(); - $sigil . $name - }); - - my $separated_by = $atomically->(sub { - my ($sep, $pars) = @_; - my $len = length $sep; - defined(my $x = $try->($pars)) or return; - my @res = $x; - while () { - substr($line, $offset, $len) eq $sep or return @res; - $offset += $len; - $skipws->(); - push @res, $pars->(); - } - }); - - my $many_till = $atomically->(sub { - my ($end, $pars) = @_; - my $len = length $end; - my @res; - until (substr($line, $offset, $len) eq $end) { - push @res, $pars->(); - } - @res - }); - - my $scan_params = $atomically->(sub { - if ($try->(sub { $scan_token->('('); 1 })) { - my @param = $separated_by->(',', $scan_var); - $scan_token->(')'); - return @param; - } - $try->($scan_var) - }); - - my @param = $scan_params->(); - - my $scan_pargroup_opt = sub { - substr($line, $offset, 1) eq '(' or return ''; - my $len = Devel::Declare::toke_scan_str($offset); - my $res = Devel::Declare::get_lex_stuff(); - Devel::Declare::clear_lex_stuff(); - $res eq '' and $fail->(qq{Can't find ")" anywhere before EOF}); - $offset += $len; - $skipws->(); - "($res)" - }; + $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)]; - my $scan_attr = sub { - my $name = $scan_id->(); - my $param = $scan_pargroup_opt->() || ''; - $name . $param - }; + $clean{shift} = delete $type{shift} || ''; + _assert_valid_identifier $clean{shift}, 1 if $clean{shift}; - my $scan_attributes = $atomically->(sub { - $try->(sub { $scan_token->(':'); 1 }) or return '', []; - my $proto = $scan_pargroup_opt->(); - my @attrs = $many_till->('{', $scan_attr); - ' ' . $proto, \@attrs - }); + $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}; - my ($proto, $attributes) = $scan_attributes->(); - my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : ''; + %type and confess "Invalid keyword property: @{[keys %type]}"; - $scan_token->('{'); + $spec{$name} = \%clean; + } + + for my $kw (keys %spec) { + my $type = $spec{$kw}; + + 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}; + $^H{HINTK_FLAGS_ . $kw} = $flags; + $^H{HINTK_SHIFT_ . $kw} = $type->{shift}; + $^H{HINTK_ATTRS_ . $kw} = $type->{attrs}; + $^H{+HINTK_KEYWORDS} .= "$kw "; + } +} - my $manip_end = $offset; - my $manip_len = $manip_end - $manip_start; - #print STDERR "($manip_start:$manip_len:$manip_end)\n"; +sub unimport { + my $class = shift; - my $params = @param ? 'my (' . join(', ', @param) . ') = @_;' : ''; - #report_pos $offset; - $proto =~ tr[\n][ ]; + if (!@_) { + delete $^H{+HINTK_KEYWORDS}; + return; + } - if (defined $name) { - my $pkg = __PACKAGE__; - #print STDERR "($manip_start:$manip_len) [$line]\n"; - substr $line, $manip_start, $manip_len, " do { sub $name$proto; sub $name$proto$attr { BEGIN { ${pkg}::terminate_me(q[$name]); } $params "; - } else { - substr $line, $manip_start, $manip_len, " sub$proto$attr { $params "; + for my $kw (@_) { + $^H{+HINTK_KEYWORDS} =~ s/(? $line\n"; - Devel::Declare::set_linestr($line); } -sub terminate_me { - my ($name) = @_; - on_scope_end { - my $line = Devel::Declare::get_linestr(); - #print STDERR "~~> $line\n"; - my $offset = Devel::Declare::get_linestr_offset(); - substr $line, $offset, 0, " \\&$name };"; - Devel::Declare::set_linestr($line); - #print STDERR "??> $line\n"; - }; -} -1 +'ok' __END__ +=encoding UTF-8 + =head1 NAME Function::Parameters - subroutine definitions with parameter lists @@ -261,11 +154,15 @@ Function::Parameters - subroutine definitions with parameter lists use Function::Parameters; + # simple function fun foo($bar, $baz) { return $bar + $baz; } - fun mymap($fun, @args) :(&@) { + # function with prototype + fun mymap($fun, @args) + :(&@) + { my @res; for (@args) { push @res, $fun->($_); @@ -274,16 +171,43 @@ 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; + } - use Function::Parameters 'proc'; - my $f = proc ($x) { $x * 2 }; + # 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 different keywords + use Function::Parameters { + proc => 'function', + meth => 'method', + }; + my $f = proc ($x) { $x * 2 }; + meth get_age() { + return $self->{age}; + } + =head1 DESCRIPTION This module lets you use parameter lists in your subroutines. Thanks to -L it works without source filters. +L it works without source filters. -WARNING: This is my first attempt at using L and I have +WARNING: This is my first attempt at writing 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. @@ -293,53 +217,285 @@ Consider this module alpha quality. To use this new functionality, you have to use C instead of C - C continues to work as before. The syntax is almost the same as for C, but after the subroutine name (or directly after C if you're -writing an anonymous sub) you can write a parameter list in parens. This +writing an anonymous sub) you can write a parameter list in parentheses. This 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/"@_">. -=head2 Advanced stuff +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 +C you get the same effect as +C. -You can change the name of the new keyword from C to anything you want by -specifying it in the import list, i.e. C lets -you write C instead of C. +=head2 Customizing the generated keywords -If you need L, you can -put them after the parameter list with their usual syntax. There's one -exception, though: you can only use one colon (to start the attribute list); -multiple attributes have to be separated by spaces. +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: -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). + 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' }; # 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 (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: + + use Function::Parameters; + # is equivalent to # + use Function::Parameters { fun => 'function', method => 'method' }; + +=cut + +=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' }; + +=cut + +=pod + + # DEPRECATED + use Function::Parameters 'foo', 'bar'; + # is equivalent to # + use Function::Parameters { 'foo' => 'function', 'bar' => 'method' }; + +That is, if you want to pass arguments to L, use a +hashref, not a list of strings. + +You can customize the properties of the generated keywords even more by passing +a hashref instead of a string. This hash can have the following keys: + +=over + +=item C + +Valid values: C (default), C (all uses of this keyword must +specify a function name), and C (all uses of this keyword must not +specify a function name). This means a C<< name => 'prohibited' >> keyword can +only be used for defining anonymous functions. + +=item C + +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 whose name is specified here. + +=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<'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', + } + +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', + } + +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 when 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 want to wrap C, you may find C -helpful. It lets you specify a target package for the syntax magic, as in: +If you need L, you can +put them after the parameter list with their usual syntax. - package Some::Wrapper; - use Function::Parameters (); - sub import { - my $caller = caller; - Function::Parameters::import_into $caller; - # or Function::Parameters::import_into $caller, 'other_keyword'; - } +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 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>): + + method foo($x, $y, $z = sqrt 5) + :($$$;$) + :lvalue + :Banana(2 + 2) + { + ... + } -C is not exported by this module, so you have to use a fully -qualified name to call it. +And here's what it turns into: + + sub foo ($$$;$) :method :lvalue :Banana(2 + 2) { + sub foo ($$$;$); + Carp::croak "Not enough arguments for method foo" if @_ < 2; + Carp::croak "Too many arguments for method foo" if @_ > 4; + my $self = shift; + my ($x, $y, $z) = @_; + $z = sqrt 5 if @_ < 3; + ... + } + +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 @@ -347,7 +503,7 @@ Lukas Mai, C<< >> =head1 COPYRIGHT & LICENSE -Copyright 2010 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