# Establish set of global symbols with max length 28, since xsubpp # will later add the 'XS_' prefix. $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; # XXX left this in for compat my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs $_[0] =~ s/^\s+|\s+$//go ; # rationalise any '*' by joining them into bunches and removing whitespace # change multiple whitespace into a single space # trim leading & trailing whitespace # skip directories, binary files etc. warn("Warning: ignoring non-text typemap file '$typemap'\n"), next or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; # skip blank lines and comment lines warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; # prototype defaults to '$' $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn \s* ( (??{ $bal }) ) # Set from ( (??{ $size }) )? # Possible sizeof set-from $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Input: ($_, @line) == unparsed input. # Output: ($_, @line) == (rest of line, following lines). # Return: the matched keyword if found, otherwise 0 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; # Group in C (no support for comments or literals) # Chunk in C without comma at toplevel (no comments): | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal while ($$self =~ s/^([^\n]*\n)//) { $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; # Not necessary if we're careful to end with a "\n" # the "do" is required for right semantics do { $_ = shift(@line) } while !/\S/ && @line; blurt ("Error: `CASE:' after unconditional `CASE:'") last if /^\s*NOT_IMPLEMENTED_YET/; next unless /\S/; # skip blank lines # 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) { # check for optional initialisation code # Check for duplicate definitions # XXXX This check is a safeguard against the unfinished conversion of # generate_init(). When generate_init() is fixed, # one can use 2-args map_type() unconditionally. # Function pointers are not yet supported with &output_init! # generate initialization code if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { my $in = merge_section(); sub INTERFACE_MACRO_handler() { my $in = merge_section(); sub INTERFACE_handler() { my $in = merge_section(); foreach (split /[\s,]+/, $in) { sub CLEANUP_handler() { print_section() } sub PREINIT_handler() { print_section() } sub POSTCALL_handler() { print_section() } sub INIT_handler() { print_section() } # Parse alias definitions # alias = value alias = value ... while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { # check for optional package definition in the alias # check for duplicate alias name & duplicate value while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { # the rest of the current line should contain either TRUE, TRUE => "PL_sv_yes", 1 => "PL_sv_yes", FALSE => "PL_sv_no", 0 => "PL_sv_no", # check for valid FALLBACK value # the rest of the current line should contain a version number death ("Error: REQUIRE expects a version number") # check that the version number is of the form n.n death ("Error: REQUIRE: expected a number, got '$Ver'") # the rest of the current line should contain either ENABLE or death("Error: Only 1 PROTOTYPE definition allowed per xsub") death("Error: Invalid prototype '$_'") # If no prototype specified, then assume empty prototype "" death("Error: Only 1 SCOPE declaration allowed per xsub") # the rest of the current line should contain either ENABLE or # the rest of the current line should contain a valid filename death("INCLUDE: filename missing") death("INCLUDE: output pipe is illegal") # simple minded recursion detector death("INCLUDE loop detected") # Save the current file context. #/* INCLUDE: Including '$_' from '$filename' */ # Prime the pump by reading the first # skip leading blank lines #/* INCLUDE: Returning to '$filename' from '$ThisFile' */ if ($cpp =~ /^\#\s*if/) { print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" Warn("Warning: #if without #endif in this function") if $cpplevel; # Identify the version of xsubpp used * This file was generated automatically by xsubpp version $XSUBPP_version from the * contents of $filename. Do not edit this file, edit $filename instead. * ANY CHANGES MADE HERE WILL BE LOST! # We can't just write out a /* */ comment, as our embedded # POD might itself be in a comment. We can't put a /**/ # comment inside #if 0, as the C standard says that the source # file is decomposed into preprocessing characters in the stage # before preprocessing commands are executed. # I don't want to leave the text as barewords, because the spec # isn't clear whether macros are expanded before or after # preprocessing commands are executed, and someone pathological # may just have defined one of the 3 words as a macro that does # something strange. Multiline strings are illegal in C, so # the "" we write must be a string literal. And they aren't # concatenated until 2 steps later, so we are safe. print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); # At this point $. is at end of file so die won't state the start # of the problem, and as we haven't yet read any lines &death won't # show the correct line in the message either. # Read next xsub into @line from ($lastline, <$FH>). death ("Error: Unterminated `#if/#ifdef/#ifndef'") # ANSI: if ifdef ifndef elif else endif define undef # gcc: warning include_next # others: ident (gcc notes that some cpps have this one) $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { # Read next line and continuation lines # Print initial preprocessor statements and blank lines push(@InitFileCode, "#endif\n"); # Hide the functions defined in other #if branches, and reset. # Keep all new defined functions # We are inside an #if, but have not yet #defined its xsubpp variable. death ("Code is not inside a function" ." (maybe last function was ended by a blank line " ." followed by a statement on column one?)") # extract return type, function name and arguments # Allow one-line ANSI-like declaration # a function definition needs at least 2 lines # Check for duplicate function definition $orig_args =~ s/\\\s*/ /g; # process line continuations \b ( \w+ | length\( \s*\w+\s* \) ) $name = "XSauto_length_of_$1"; die "Default value on length() argument: `$_'" if (length $pre or $islength) { # Has a type push @fake_INPUT_pre, $arg; # warn "pushing '$arg'\n"; $_ = "$name$default"; # Assigns to @args $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; @args = split(/\s*,\s*/, $orig_args); Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); @args = split(/\s*,\s*/, $orig_args); if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { next if $out_type eq 'IN'; $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; push @outlist, $name if $out_type =~ /OUTLIST$/; my $arg0 = ((defined($static) or $func_name eq 'new') ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/; foreach $i (0 .. $#args) { if ($args[$i] =~ s/\.\.\.//) { if ($args[$i] eq '' && $i == $#args) { if ($only_C_inlist{$args[$i]}) { push @args_num, ++$num_args; $report_args .= ", $args[$i]"; if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { $defaults{$args[$i]} = $2; $defaults{$args[$i]} =~ s/"/\\"/g; $proto_arg[$i+1] = "\$" ; $min_args = $num_args - $extra_args; $report_args =~ s/"/\\"/g; $report_args =~ s/^,\s+//; shift @func_args if defined($class); $func_args = join(", ", @func_args); @args_match{@args} = @args_num; $PPCODE = grep(/^\s*PPCODE\s*:/, @line); $CODE = grep(/^\s*CODE\s*:/, @line); # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) # to set explicit return values. $EXPLICIT_RETURN = ($CODE && ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); $ALIAS = grep(/^\s*ALIAS\s*:/, @line); $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); $xsreturn = 1 if $EXPLICIT_RETURN; #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS(XS_${Full_func_name}) print Q<<"EOF" if $ALIAS ; print Q<<"EOF" if $INTERFACE ; # dXSFUNCTION($ret_type); $cond = ($min_args ? qq(items < $min_args) : 0); elsif ($min_args == $num_args) { $cond = qq(items != $min_args); $cond = qq(items < $min_args || items > $num_args); print Q<<"EOF" if $except; { print Q<<"EOF" if $cond } # Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv))); { print Q<<"EOF" if $cond } # Perl_croak(aTHX_ "Usage: $pname($report_args)"); #gcc -Wall: if an xsub has no arguments and PPCODE is used #it is likely none of ST, XSRETURN or XSprePUSH macros are used #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS #but such a move could break third-party extensions # PERL_UNUSED_VAR(ax); /* -Wall */ # Now do a block of some sort. $cond = ''; # last CASE: condidional # do initialization of input variables process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ; print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ; death ("PPCODE must be last thing") if @line; print "\tPUTBACK;\n\treturn;\n"; $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section; # $wantRETVAL set if 'RETVAL =' autogenerated # all OUTPUT done, so now push the return value on the stack # 0: type, 1: with_size, 2: how, 3: how_size # PUSHp corresponds to setpvn. Treate setpv directly print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; # RETVAL almost never needs SvSETMAGIC() # (PP)CODE set different values of SP; reset to PPCODE's with 0 output # Take into account stuff already put on stack # Now SP corresponds to ST($xsreturn), so one can combine PUSH and ST() print "\tEXTEND(SP,$c);\n" if $c; # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); blurt ("Error: No `CASE:' at top of function") $_ = "CASE: $_"; # Restore CASE: label death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); # Perl_croak(aTHX_ errbuf); # Build the prototype string for the xsub # User has specified empty prototype # User has specified a prototype $proto = ', "' . $ProtoThisXSUB . '"'; $proto = ', "' . join ("", @proto_arg) . '"'; push(@InitFileCode, Q<<"EOF"); push(@InitFileCode, Q<<"EOF"); push(@InitFileCode, Q<<"EOF"); if ($Overload) # make it findable with fetchmethod #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */ /* Making a sub named "${Package}::()" allows the package */ /* to be findable via fetchmethod(), and causes */ /* overload::Overloaded("${Package}") to return true. */ # print initialization routine #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ print Q<<"EOF" if $Full_func_name; print Q<<"EOF" if $WantVersionChk ; print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; print Q<<"EOF" if ($Overload); # /* register the overloading (type 'A') magic */ # PL_amagic_generation++; # /* The magic for overload gets a GV* via gv_fetchmeth as */ # /* mentioned above, and looks in the SV* slot of it for */ # /* the "fallback" status. */ # get_sv( "${Package}::()", TRUE ), print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; print "\n /* Initialisation Section */\n\n" ; print "\n /* End of Initialisation Section */\n\n" ; warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") local($type, $num, $var, $init, $name_printed) = @_; local($arg) = "ST(" . ($num - 1) . ")"; if( $init =~ s/^\+// && $num ) { &generate_init($type, $num, $var, $name_printed); } elsif ($name_printed) { $deferred .= eval qq/"\\n\\t$init\\n"/; # work out the line number my $line_no = $line_no[@line_no - @line -1] ; print STDERR "@_ in $filename, line $line_no\n" ; local($type, $num, $var) = @_; local($arg) = "ST(" . ($num - 1) . ")"; local($argoff) = $num - 1; $type = TidyType($type) ; blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type}); ($ntype = $type) =~ s/\s*\*/Ptr/g; ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; $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}; $type =~ tr/:/_/ unless $hiertype; unless defined $input_expr{$tk} ; $expr = $input_expr{$tk}; if ($expr =~ /DO_ARRAY_ELEM/) { blurt("Error: '$subtype' not in typemap"), return unless defined($type_kind{$subtype}); unless defined $input_expr{$type_kind{$subtype}} ; $subexpr = $input_expr{$type_kind{$subtype}}; $subexpr =~ s/\$type/\$subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\n\t/\n\t\t/g; $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments if (defined($defaults{$var})) { if ($defaults{$var} eq 'NO_INIT') { $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/; $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { $deferred .= eval qq/"\\n$expr;\\n"/; die "panic: do not know how to handle this branch for function pointers" local($type, $num, $var, $do_setmagic, $do_push) = @_; local($arg) = "ST(" . ($num - ($num != 0)) . ")"; local($argoff) = $num - 1; $type = TidyType($type) ; if ($type =~ /^array\(([^,]*),(.*)\)/) { print "\t$arg = sv_newmortal();\n"; print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type}); unless defined $output_expr{$type_kind{$type}} ; ($ntype = $type) =~ s/\s*\*/Ptr/g; ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; $expr = $output_expr{$type_kind{$type}}; if ($expr =~ /DO_ARRAY_ELEM/) { blurt("Error: '$subtype' not in typemap"), return unless defined($type_kind{$subtype}); unless defined $output_expr{$type_kind{$subtype}} ; $subexpr = $output_expr{$type_kind{$subtype}}; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\$var/${var}[ix_$var]/g; $subexpr =~ s/\n\t/\n\t\t/g; eval "print qq\a$expr\a"; print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; if ($expr =~ /^\t\$arg = new/) { # We expect that $arg has refcnt 1, so we need to eval "print qq\a$expr\a"; print "\tsv_2mortal(ST($num));\n"; print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; elsif ($expr =~ /^\s*\$arg\s*=/) { # We expect that $arg has refcnt >=1, so we need eval "print qq\a$expr\a"; print "\tsv_2mortal(ST(0));\n"; print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; # Just hope that the entry would safely write it # over an already mortalized value. By # coincidence, something like $arg = &sv_undef print "\tST(0) = sv_newmortal();\n"; eval "print qq\a$expr\a"; print "\tPUSHs(sv_newmortal());\n"; eval "print qq\a$expr\a"; elsif ($arg =~ /^ST\(\d+\)$/) { eval "print qq\a$expr\a"; # C++ has :: in types too so skip this # If this is VMS, the exit status has meaning to the shell, so we # use a predictable value (SS$_Normal or SS$_Abort) rather than an # exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;