From 08ff138dc0c1cdf425c051c295eab8d1f59c736a Mon Sep 17 00:00:00 2001 From: Ilya Zakharevich Date: Sun, 3 Mar 2002 21:25:52 -0500 Subject: [PATCH] xsubpp Message-Id: <20020304022552.A14106@math.ohio-state.edu> p4raw-link: @14577 on //depot/perl: 0ad5258ff3f3328f321188cbb4fcd6a74b365431 p4raw-id: //depot/perl@14986 --- lib/ExtUtils/xsubpp | 66 ++++++++++++++++++++++++++++++++++++++--------------- pod/perlxs.pod | 25 ++++++++++++++++++++ 2 files changed, 73 insertions(+), 18 deletions(-) diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 98bb739..a12272c 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -410,6 +410,14 @@ sub INPUT_handler { # remove trailing semicolon if no initialisation s/\s*;$//g unless /[=;+].*\S/ ; + # Process the length(foo) declarations + if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { + print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; + $lengthof{$2} = $name; + # $islengthof{$name} = $1; + $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;"; + } + # check for optional initialisation code my $var_init = '' ; $var_init = $1 if s/\s*([=;+].*)$//s ; @@ -422,7 +430,7 @@ sub INPUT_handler { # Check for duplicate definitions blurt ("Error: duplicate definition of argument '$var_name' ignored"), next if $arg_list{$var_name}++ - or defined $arg_types{$var_name} and not $processing_arg_with_types; + or defined $argtype_seen{$var_name} and not $processing_arg_with_types; $thisdone |= $var_name eq "THIS"; $retvaldone |= $var_name eq "RETVAL"; @@ -1005,11 +1013,14 @@ while (fetch_para()) { undef($RETVAL_no_return) ; undef(%arg_list) ; undef(@proto_arg) ; - undef(@arg_with_types) ; + undef(@fake_INPUT_pre) ; # For length(s) generated variables + undef(@fake_INPUT) ; undef($processing_arg_with_types) ; - undef(%arg_types) ; + undef(%argtype_seen) ; undef(@outlist) ; undef(%in_out) ; + undef(%lengthof) ; + # undef(%islengthof) ; undef($proto_in_this_xsub) ; undef($scope_in_this_xsub) ; undef($interface); @@ -1074,7 +1085,7 @@ while (fetch_para()) { $orig_args =~ s/\\\s*/ /g; # process line continuations - my %only_outlist; + my %only_C_inlist; # Not in the signature of Perl function if ($process_argtypes and $orig_args =~ /\S/) { my $args = "$orig_args ,"; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @@ -1082,10 +1093,10 @@ while (fetch_para()) { for ( @args ) { s/^\s+//; s/\s+$//; - my $arg = $_; - my $default; - ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; - my ($pre, $name) = ($arg =~ /(.*?) \s* \b(\w+) \s* $ /x); + my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; + my ($pre, $name) = ($arg =~ /(.*?) \s* + \b ( \w+ | length\( \s*\w+\s* \) ) + \s* $ /x); next unless length $pre; my $out_type; my $inout_var; @@ -1093,14 +1104,26 @@ while (fetch_para()) { my $type = $1; $out_type = $type if $type ne 'IN'; $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; + $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; + } + my $islength; + if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { + $name = "XSauto_length_of_$1"; + $islength = 1; + die "Default value on length() argument: `$_'" + if length $default; } - if (/\W/) { # Has a type - push @arg_with_types, $arg; + if (length $pre or $islength) { # Has a type + if ($islength) { + push @fake_INPUT_pre, $arg; + } else { + push @fake_INPUT, $arg; + } # warn "pushing '$arg'\n"; - $arg_types{$name} = $arg; - $_ = "$name$default"; + $argtype_seen{$name}++; + $_ = "$name$default"; # Assigns to @args } - $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$name} = $out_type if $out_type; } @@ -1114,7 +1137,7 @@ while (fetch_para()) { if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { my $out_type = $1; next if $out_type eq 'IN'; - $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$_} = $out_type; } @@ -1139,7 +1162,7 @@ while (fetch_para()) { last; } } - if ($only_outlist{$args[$i]}) { + if ($only_C_inlist{$args[$i]}) { push @args_num, undef; } else { push @args_num, ++$num_args; @@ -1284,8 +1307,8 @@ EOF if $WantOptimize and $targetable{$type_kind{$ret_type}}; } - if (@arg_with_types) { - unshift @line, @arg_with_types, $_; + if (@fake_INPUT or @fake_INPUT_pre) { + unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; $_ = ""; $processing_arg_with_types = 1; INPUT_handler() ; @@ -1621,6 +1644,13 @@ sub generate_init { ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; $tk = $type_kind{$type}; $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; + if ($tk eq 'T_PV' and exists $lengthof{$var}) { + print "\t$var" unless $name_printed; + print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; + die "default value not supported with length(NAME) supplied" + if defined $defaults{$var}; + return; + } $type =~ tr/:/_/; blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return unless defined $input_expr{$tk} ; @@ -1657,7 +1687,7 @@ sub generate_init { $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; } warn $@ if $@; - } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) { + } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { if ($name_printed) { print ";\n"; } else { diff --git a/pod/perlxs.pod b/pod/perlxs.pod index c9f7cc8..78e3e7c 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -839,6 +839,31 @@ However, the generated Perl function is called in very C-ish style: my ($day, $month); day_month($day, time, $month); +=head2 The C Keyword + +If one of the input arguments to the C function is the length of a string +argument C, one can substitute the name of the length-argument by +C in the XSUB declaration. This argument must be omited when +the generated Perl function is called. E.g., + + void + dump_chars(char *s, short l) + { + short n = 0; + while (n < l) { + printf("s[%d] = \"\\%#03o\"\n", n, (int)s[n]); + n++; + } + } + + MODULE = x PACKAGE = x + + void dump_chars(char *s, short length(s)) + +should be called as C. + +This directive is supported with ANSI-type function declarations only. + =head2 Variable-length Parameter Lists XSUBs can have variable-length parameter lists by specifying an ellipsis -- 2.7.4