X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFunction%2FParameters.pm;h=8af625e6db77c55b95060540e48e5f56015806d3;hb=59f51b8bd14b6b5ab68b3375f00cb122f0cfacba;hp=d7e6ddd0aeb82c98c04fc6ebc50e4c4c905cf664;hpb=5d0dba1f26174026cb2c838ef568816f43c3fad1;p=p5sagit%2FFunction-Parameters.git

diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm
index d7e6ddd..8af625e 100644
--- a/lib/Function/Parameters.pm
+++ b/lib/Function/Parameters.pm
@@ -5,15 +5,14 @@ use v5.14.0;
 use strict;
 use warnings;
 
+use Carp qw(confess);
+
 use XSLoader;
 BEGIN {
-	our $VERSION = '0.05_03';
+	our $VERSION = '0.06';
 	XSLoader::load;
 }
 
-use Carp qw(confess);
-use bytes ();
-
 sub _assert_valid_identifier {
 	my ($name, $with_dollar) = @_;
 	my $bonus = $with_dollar ? '\$' : '';
@@ -21,16 +20,42 @@ sub _assert_valid_identifier {
 		or confess qq{"$name" doesn't look like a valid identifier};
 }
 
+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,
+	},
+	method   => {
+		name => 'optional',
+		default_arguments => 1,
+		check_argument_count => 0,
+		attrs => ':method',
+		shift => '$self',
+	},
+	classmethod   => {
+		name => 'optional',
+		default_arguments => 1,
+		check_argument_count => 0,
+		attrs => ':method',
+		shift => '$class',
+	},
 );
 
 sub import {
 	my $class = shift;
 
-	@_ or @_ = ('fun', 'method');
+	@_ or @_ = {
+		fun => 'function',
+		method => 'method',
+	};
 	if (@_ == 1 && ref($_[0]) eq 'HASH') {
 		@_ = map [$_, $_[0]{$_}], keys %{$_[0]}
 			or return;
@@ -44,35 +69,53 @@ sub import {
 			? $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})];
-		}
-		$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)];
-		if ($type->{shift}) {
-			_assert_valid_identifier $type->{shift}, 1;
-			bytes::length($type->{shift}) < SHIFT_NAME_LIMIT
-				or confess qq["$type->{shift}" is longer than I can handle];
+		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 %type = %$proto_type;
+		my %clean;
+
+		$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)];
+
+		$clean{shift} = delete $type{shift} || '';
+		_assert_valid_identifier $clean{shift}, 1 if $clean{shift};
+
+		$clean{attrs} = delete $type{attrs} || '';
+		_assert_valid_attributes $clean{attrs} if $clean{attrs};
 		
-		$spec{$name} = $type;
+		$clean{default_arguments} =
+			exists $type{default_arguments}
+			? !!delete $type{default_arguments}
+			: 1
+		;
+		$clean{check_argument_count} = !!delete $type{check_argument_count};
+
+		%type and confess "Invalid keyword property: @{[keys %type]}";
+
+		$spec{$name} = \%clean;
 	}
 	
 	for my $kw (keys %spec) {
 		my $type = $spec{$kw};
 
-		$^H{HINTK_SHIFT_ . $kw} = $type->{shift} || '';
-		$^H{HINTK_NAME_ . $kw} =
-			$type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED :
-			$type->{name} eq 'required' ? FLAG_NAME_REQUIRED :
-			FLAG_NAME_OPTIONAL
+		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 ";
 	}
 }
@@ -95,6 +138,8 @@ sub unimport {
 
 __END__
 
+=encoding UTF-8
+
 =head1 NAME
 
 Function::Parameters - subroutine definitions with parameter lists
@@ -169,14 +214,15 @@ that you pass a hash reference in the import list:
 
  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<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>, 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>.
+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:
 
@@ -226,10 +272,30 @@ 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' } >>, and plain
-C<'method'> is equivalent to C<< { name => 'optional', shift => '$self' } >>.
+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