xsubpp

   Message-Id: <20020304022552.A14106@math.ohio-state.edu>
p4raw-link: @14577 on //depot/perl: 0ad5258ff3f3328f321188cbb4fcd6a74b365431

p4raw-id: //depot/perl@14986

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 98bb739..a12272c 100755 (executable)
--- 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 (file)
--- 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<length(NAME)> Keyword
+
+If one of the input arguments to the C function is the length of a string
+argument C<NAME>, one can substitute the name of the length-argument by
+C<length(NAME)> 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<dump_chars($string)>.
+
+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