package Function::Parameters;
+use v5.14.0;
+
use strict;
use warnings;
-our $VERSION = '0.03';
-
-use Devel::Declare;
-use B::Hooks::EndOfScope;
-use B::Compiling;
-
-sub guess_caller {
- my ($start) = @_;
- $start ||= 1;
-
- 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.05_03';
+ XSLoader::load;
}
-sub _fun ($) { $_[0] }
+use Carp qw(confess);
-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 {
- my $class = shift;
- my $keyword = @_ ? shift : 'fun';
- my $caller = guess_caller;
- #warn "caller = $caller";
-
- _croak qq{"$_" is not exported by the $class module} for @_;
-
- $keyword =~ /^[[:alpha:]_]\w*\z/ or _croak qq{"$keyword" does not look like a valid identifier};
-
- Devel::Declare->setup_for(
- $caller,
- { $keyword => { const => \&parser } }
- );
-
- no strict 'refs';
- *{$caller . '::' . $keyword} = \&_fun;
+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};
}
-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";
-}
+my @bare_arms = qw(function method);
+my %type_map = (
+ function => { name => 'optional' },
+ method => {
+ name => 'optional',
+ shift => '$self',
+ attrs => ':method',
+ },
+ classmethod => {
+ name => 'optional',
+ shift => '$class',
+ attrs => ':method',
+ },
+);
-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";
- }
- };
-
- 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]
- };
+sub import {
+ my $class = shift;
- 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;
+ @_ or @_ = {
+ fun => 'function',
+ method => 'method',
};
-
- $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 $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 $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 %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 $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)"
- };
- my $scan_attr = sub {
- my $name = $scan_id->();
- my $param = $scan_pargroup_opt->() || '';
- $name . $param
- };
+ my %type = %$proto_type;
+ my %clean;
- 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{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 ($proto, $attributes) = $scan_attributes->();
- my $attr = @$attributes ? ' : ' . join(' ', @$attributes) : '';
+ $clean{shift} = delete $type{shift} || '';
+ _assert_valid_identifier $clean{shift}, 1 if $clean{shift};
- $scan_token->('{');
+ $clean{attrs} = delete $type{attrs} || '';
+ _assert_valid_attributes $clean{attrs} if $clean{attrs};
+
+ %type and confess "Invalid keyword property: @{[keys %type]}";
- my $manip_end = $offset;
- my $manip_len = $manip_end - $manip_start;
- #print STDERR "($manip_start:$manip_len:$manip_end)\n";
+ $spec{$name} = \%clean;
+ }
+
+ for my $kw (keys %spec) {
+ my $type = $spec{$kw};
+
+ $^H{HINTK_SHIFT_ . $kw} = $type->{shift};
+ $^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
+ $^H{HINTK_NAME_ . $kw} =
+ $type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED :
+ $type->{name} eq 'required' ? FLAG_NAME_REQUIRED :
+ FLAG_NAME_OPTIONAL
+ ;
+ $^H{+HINTK_KEYWORDS} .= "$kw ";
+ }
+}
- my $params = @param ? 'my (' . join(', ', @param) . ') = @_;' : '';
- #report_pos $offset;
- $proto =~ tr[\n][ ];
+sub unimport {
+ my $class = shift;
- 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 ";
+ if (!@_) {
+ delete $^H{+HINTK_KEYWORDS};
+ return;
}
- #print STDERR ".> $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";
- };
+ for my $kw (@_) {
+ $^H{+HINTK_KEYWORDS} =~ s/(?<![^ ])\Q$kw\E //g;
+ }
}
-1
+
+'ok'
__END__
}
print "$_\n" for mymap { $_ * 2 } 1 .. 4;
+
+ method set_name($name) {
+ $self->{name} = $name;
+ }
- use Function::Parameters 'proc';
- my $f = proc ($x) { $x * 2 };
+=cut
+
+=pod
+
+ 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<Devel::Declare> it works without source filters.
+L<PL_keyword_plugin|perlapi/PL_keyword_plugin> it works without source filters.
-WARNING: This is my first attempt at using L<Devel::Declare> and I have
+WARNING: This is my first attempt at writing L<XS code|perlxs> 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.
To use this new functionality, you have to use C<fun> instead of C<sub> -
C<sub> continues to work as before. The syntax is almost the same as for
C<sub>, but after the subroutine name (or directly after C<fun> 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<fun foo($bar, $baz) {> is as if you'd written
C<sub foo { my ($bar, $baz) = @_; >, i.e. the parameter list is simply
copied into C<my> and initialized from L<@_|perlvar/"@_">.
-=head2 Advanced stuff
+In addition you can use C<method>, which understands the same syntax as C<fun>
+but automatically creates a C<$self> variable for you. So by writing
+C<method foo($bar, $baz) {> you get the same effect as
+C<sub foo { my $self = shift; my ($bar, $baz) = @_; >.
-You can change the name of the new keyword from C<fun> to anything you want by
-specifying it in the import list, i.e. C<use Function::Parameters 'spork'> lets
-you write C<spork> instead of C<fun>.
+=head2 Customizing the generated keywords
-If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, 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 hash reference in the import list:
-Syntactically, these new parameter lists live in the spot normally occupied
-by L<prototypes|perlsub/"Prototypes">. 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 { proc => 'function', meth => 'method' }; # -or-
+ use Function::Parameters { proc => 'function' }; # -or-
+ use Function::Parameters { meth => 'method' }; # etc.
+
+The first line creates two keywords, C<proc> and C<meth> (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<function>, C<method>, C<classmethod> or a hash
+reference (see below). The difference between C<function> and C<method> is that
+C<method>s automatically L<shift|perlfunc/shift> 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 the 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<Function::Parameters>, use a
+hashref, not a list of strings.
+
+You can customize things even more by passing a hashref instead of C<function>
+or C<method>. This hash can have the following keys:
+
+=over
+
+=item C<name>
+
+Valid values: C<optional> (default), C<required> (all uses of this keyword must
+specify a function name), and C<prohibited> (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<shift>
+
+Valid values: strings that look like a scalar variable. Any function created by
+this keyword will automatically L<shift|perlfunc/shift> its first argument into
+a local variable whose name is specified here.
+
+=item C<attrs>
+
+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 => { attrs => ':lvalue' } };
+ sub_l foo() {
+ ...
+ }
+
+turns into
+
+ sub foo :lvalue {
+ ...
+ }
+
+=back
+
+Plain C<'function'> is equivalent to C<< { name => 'optional' } >>, plain
+C<'method'> is equivalent to
+C<< { name => 'optional', shift => '$self', attrs => ':method' } >>, and plain
+C<'classmethod'> is equivalent to
+C<< { name => 'optional', shift => '$class', attrs => ':method' } >>.
+
+=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<foo> or its prototype when processing
-C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
+parser doesn't know the name C<foo> or its prototype while processing the body
+of C<sub foo ($) { foo $bar[1], $bar[0]; }>, parsing it as
C<$bar-E<gt>foo([1], $bar[0])>. Yes. You can add parens to change the
interpretation of this code, but C<foo($bar[1], $bar[0])> will only trigger
a I<foo() called too early to check prototype> warning. This module attempts
body. Thus C<fun foo($x) :($) { $x }> really turns into
C<sub foo ($); sub foo ($) { my ($x) = @_; $x }>.
+If you need L<subroutine attributes|perlsub/"Subroutine Attributes">, 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<prototypes|perlsub/"Prototypes">. 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 feature available
+(subroutine name, parameter list, prototype, attributes, and implicit
+C<$self>):
+
+ method foo($x, $y, @z) :($;$@) :lvalue :Banana(2 + 2) {
+ ...
+ }
+
+And here's what it turns into:
+
+ sub foo ($;$@); sub foo ($;$@) :lvalue :Banana(2 + 2) { my $self = shift; my ($x, $y, @z) = @_;
+ ...
+ }
+
+Another example:
+
+ my $coderef = fun ($p, $q) :(;$$)
+ :lvalue
+ :Gazebo((>:O)) {
+ ...
+ };
+
+And the generated code:
+
+ my $coderef = sub (;$$) :lvalue :Gazebo((>:O)) { my ($p, $q) = @_;
+ ...
+ };
+
+=head2 Wrapping Function::Parameters
+
+If you want to wrap L<Function::Parameters>, you just have to call its
+C<import> method. It always applies to the file that is currently being parsed
+and its effects are lexical (i.e. it works like L<warnings> or L<strict>):
+
+ package Some::Wrapper;
+ use Function::Parameters ();
+ sub import {
+ Function::Parameters->import;
+ # or Function::Parameters->import(@other_import_args);
+ }
+
=head1 AUTHOR
Lukas Mai, C<< <l.mai at web.de> >>
=head1 COPYRIGHT & LICENSE
-Copyright 2009 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