diff options
Diffstat (limited to 'ext')
-rw-r--r-- | ext/DB_File/DB_File.pm | 2 | ||||
-rw-r--r-- | ext/Fcntl/Fcntl.pm | 2 | ||||
-rw-r--r-- | ext/GDBM_File/GDBM_File.pm | 2 | ||||
-rw-r--r-- | ext/POSIX/POSIX.pm | 2 | ||||
-rw-r--r-- | ext/Socket/Socket.pm | 2 | ||||
-rw-r--r-- | ext/typemap | 284 | ||||
-rwxr-xr-x | ext/xsubpp | 616 |
7 files changed, 5 insertions, 905 deletions
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index d66ab2cabe..af56cc0548 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -179,7 +179,7 @@ require TieHash; require Exporter; require AutoLoader; require DynaLoader; -@ISA = (TieHash, Exporter, AutoLoader, DynaLoader); +@ISA = (TieHash, Exporter, DynaLoader); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO BTREEMAGIC diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index c4fd2ff550..d55d4e30bd 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -3,7 +3,7 @@ package Fcntl; require Exporter; require AutoLoader; require DynaLoader; -@ISA = (Exporter, AutoLoader, DynaLoader); +@ISA = (Exporter, DynaLoader); # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @EXPORT = diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index 23422f7a2e..99b6390e80 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -5,7 +5,7 @@ require TieHash; require Exporter; require AutoLoader; require DynaLoader; -@ISA = (TieHash, Exporter, AutoLoader, DynaLoader); +@ISA = (TieHash, Exporter, DynaLoader); @EXPORT = qw( GDBM_CACHESIZE GDBM_FAST diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 3fa292df6a..4ccc5ce520 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -5,7 +5,7 @@ require Exporter; require AutoLoader; require DynaLoader; require Config; -@ISA = (Exporter, AutoLoader, DynaLoader); +@ISA = (Exporter, DynaLoader); $H{assert_h} = [qw(assert NDEBUG)]; diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index a05c0a0a0c..a129ec694e 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -4,7 +4,7 @@ use Carp; require Exporter; require AutoLoader; require DynaLoader; -@ISA = (Exporter, AutoLoader, DynaLoader); +@ISA = (Exporter, DynaLoader); @EXPORT = qw( AF_802 AF_APPLETALK diff --git a/ext/typemap b/ext/typemap deleted file mode 100644 index 98493e7c04..0000000000 --- a/ext/typemap +++ /dev/null @@ -1,284 +0,0 @@ -# $Header$ -# basic C types -int T_IV -unsigned T_IV -unsigned int T_IV -long T_IV -unsigned long T_IV -short T_IV -unsigned short T_IV -char T_CHAR -unsigned char T_U_CHAR -char * T_PV -unsigned char * T_PV -caddr_t T_PV -wchar_t * T_PV -wchar_t T_IV -bool_t T_IV -size_t T_IV -ssize_t T_IV -time_t T_NV -unsigned long * T_OPAQUEPTR -char ** T_PACKED -void * T_PTR -Time_t * T_PV -SV * T_SV -SVREF T_SVREF -AV * T_AVREF -HV * T_HVREF -CV * T_CVREF - -IV T_IV -I32 T_IV -I16 T_IV -I8 T_IV -U32 T_U_LONG -U16 T_U_SHORT -U8 T_IV -Result T_U_CHAR -Boolean T_IV -double T_DOUBLE -SysRet T_SYSRET -SysRetLong T_SYSRET -FILE * T_IN -FileHandle T_PTROBJ -InputStream T_IN -InOutStream T_INOUT -OutputStream T_OUT - -############################################################################# -INPUT -T_SV - $var = $arg -T_SVREF - if (sv_isa($arg, \"${ntype}\")) - $var = (SV*)SvRV($arg); - else - croak(\"$var is not of type ${ntype}\") -T_AVREF - if (sv_isa($arg, \"${ntype}\")) - $var = (AV*)SvRV($arg); - else - croak(\"$var is not of type ${ntype}\") -T_HVREF - if (sv_isa($arg, \"${ntype}\")) - $var = (HV*)SvRV($arg); - else - croak(\"$var is not of type ${ntype}\") -T_CVREF - if (sv_isa($arg, \"${ntype}\")) - $var = (CV*)SvRV($arg); - else - croak(\"$var is not of type ${ntype}\") -T_SYSRET - $var NOT IMPLEMENTED -T_IV - $var = ($type)SvIV($arg) -T_INT - $var = (int)SvIV($arg) -T_ENUM - $var = ($type)SvIV($arg) -T_U_INT - $var = (unsigned int)SvIV($arg) -T_SHORT - $var = (short)SvIV($arg) -T_U_SHORT - $var = (unsigned short)SvIV($arg) -T_LONG - $var = (long)SvIV($arg) -T_U_LONG - $var = (unsigned long)SvIV($arg) -T_CHAR - $var = (char)*SvPV($arg,na) -T_U_CHAR - $var = (unsigned char)SvIV($arg) -T_FLOAT - $var = (float)SvNV($arg) -T_NV - $var = ($type)SvNV($arg) -T_DOUBLE - $var = (double)SvNV($arg) -T_PV - $var = ($type)SvPV($arg,na) -T_PTR - $var = ($type)SvIV($arg) -T_PTRREF - if (SvROK($arg)) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; - } - else - croak(\"$var is not a reference\") -T_REF_IV_REF - if (sv_isa($arg, \"${type}\")) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = *($type *) tmp; - } - else - croak(\"$var is not of type ${ntype}\") -T_REF_IV_PTR - if (sv_isa($arg, \"${type}\")) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; - } - else - croak(\"$var is not of type ${ntype}\") -T_PTROBJ - if (sv_isa($arg, \"${ntype}\")) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; - } - else - croak(\"$var is not of type ${ntype}\") -T_PTRDESC - if (sv_isa($arg, \"${ntype}\")) { - IV tmp = SvIV((SV*)SvRV($arg)); - ${type}_desc = (\U${type}_DESC\E*) tmp; - $var = ${type}_desc->ptr; - } - else - croak(\"$var is not of type ${ntype}\") -T_REFREF - if (SvROK($arg)) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = *($type) tmp; - } - else - croak(\"$var is not a reference\") -T_REFOBJ - if (sv_isa($arg, \"${ntype}\")) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = *($type) tmp; - } - else - croak(\"$var is not of type ${ntype}\") -T_OPAQUE - $var NOT IMPLEMENTED -T_OPAQUEPTR - $var = ($type)SvPV($arg,na) -T_PACKED - $var = XS_unpack_$ntype($arg) -T_PACKEDARRAY - $var = XS_unpack_$ntype($arg) -T_CALLBACK - $var = make_perl_cb_$type($arg) -T_ARRAY - $var = $ntype(items -= $argoff); - U32 ix_$var = $argoff; - while (items--) { - DO_ARRAY_ELEM; - } -T_IN - $var = IoIFP(sv_2io($arg)) -T_INOUT - $var = IoIFP(sv_2io($arg)) -T_OUT - $var = IoOFP(sv_2io($arg)) -############################################################################# -OUTPUT -T_SV - $arg = $var; -T_SVREF - $arg = newRV((SV*)$var); -T_AVREF - $arg = newRV((SV*)$var); -T_HVREF - $arg = newRV((SV*)$var); -T_CVREF - $arg = newRV((SV*)$var); -T_IV - sv_setiv($arg, (IV)$var); -T_INT - sv_setiv($arg, (IV)$var); -T_SYSRET - if ($var != -1) { - if ($var == 0) - sv_setpvn($arg, "0 but true", 10); - else - sv_setiv($arg, (IV)$var); - } -T_ENUM - sv_setiv($arg, (IV)$var); -T_U_INT - sv_setiv($arg, (IV)$var); -T_SHORT - sv_setiv($arg, (IV)$var); -T_U_SHORT - sv_setiv($arg, (IV)$var); -T_LONG - sv_setiv($arg, (IV)$var); -T_U_LONG - sv_setiv($arg, (IV)$var); -T_CHAR - sv_setpvn($arg, (char *)&$var, 1); -T_U_CHAR - sv_setiv($arg, (IV)$var); -T_FLOAT - sv_setnv($arg, (double)$var); -T_NV - sv_setnv($arg, (double)$var); -T_DOUBLE - sv_setnv($arg, (double)$var); -T_PV - sv_setpv((SV*)$arg, $var); -T_PTR - sv_setiv($arg, (IV)$var); -T_PTRREF - sv_setref_pv($arg, Nullch, (void*)$var); -T_REF_IV_REF - sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); -T_REF_IV_PTR - sv_setref_pv($arg, \"${ntype}\", (void*)$var); -T_PTROBJ - sv_setref_pv($arg, \"${ntype}\", (void*)$var); -T_PTRDESC - sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); -T_REFREF - sv_setrefref($arg, \"${ntype}\", XS_service_$ntype, - ($var ? (void*)new $ntype($var) : 0)); -T_REFOBJ - NOT IMPLEMENTED -T_OPAQUE - sv_setpvn($arg, (char *)&$var, sizeof($var)); -T_OPAQUEPTR - sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); -T_PACKED - XS_pack_$ntype($arg, $var); -T_PACKEDARRAY - XS_pack_$ntype($arg, $var, count_$ntype); -T_DATAUNIT - sv_setpvn($arg, $var.chp(), $var.size()); -T_CALLBACK - sv_setpvn($arg, $var.context.value().chp(), - $var.context.value().size()); -T_ARRAY - ST_EXTEND($var.size); - for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) { - ST(ix_$var) = sv_newmortal(); - DO_ARRAY_ELEM - } - sp += $var.size - 1; -T_IN - { - GV *gv = newGVgen("$Package"); - if ( do_open(gv, "<&", 2, $var) ) - sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); - else - $arg = &sv_undef; - } -T_INOUT - { - GV *gv = newGVgen("$Package"); - if ( do_open(gv, "+<&", 3, $var) ) - sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); - else - $arg = &sv_undef; - } -T_OUT - { - GV *gv = newGVgen("$Package"); - if ( do_open(gv, "+>&", 3, $var) ) - sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); - else - $arg = &sv_undef; - } diff --git a/ext/xsubpp b/ext/xsubpp deleted file mode 100755 index 1e13118ad5..0000000000 --- a/ext/xsubpp +++ /dev/null @@ -1,616 +0,0 @@ -#!./miniperl -'di '; -'ds 00 \"'; -'ig 00 '; -# $Header$ - -$usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n"; - -SWITCH: while ($ARGV[0] =~ s/^-//) { - $flag = shift @ARGV; - $spat = shift, next SWITCH if $flag eq 's'; - $cplusplus = 1, next SWITCH if $flag eq 'C++'; - $except = 1, next SWITCH if $flag eq 'except'; - push(@tm,shift), next SWITCH if $flag eq 'typemap'; - die $usage; -} -@ARGV == 1 or die $usage; -chop($pwd = `pwd`); -($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)# - or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)# - or ($dir, $filename) = ('.', $ARGV[0]); -chdir($dir); - -$typemap = shift @ARGV; -foreach $typemap (@tm) { - die "Can't find $typemap in $pwd\n" unless -r $typemap; -} -unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap); -foreach $typemap (@tm) { - open(TYPEMAP, $typemap) || next; - $mode = Typemap; - $current = \$junk; - while (<TYPEMAP>) { - next if /^#/; - if (/^INPUT\s*$/) { $mode = Input, next } - if (/^OUTPUT\s*$/) { $mode = Output, next } - if (/^TYPEMAP\s*$/) { $mode = Typemap, next } - if ($mode eq Typemap) { - chop; - ($typename, $kind) = split(/\t+/, $_, 2); - $type_kind{$typename} = $kind if $kind ne ''; - } - elsif ($mode eq Input) { - if (/^\s/) { - $$current .= $_; - } - else { - s/\s*$//; - $input_expr{$_} = ''; - $current = \$input_expr{$_}; - } - } - else { - if (/^\s/) { - $$current .= $_; - } - else { - s/\s*$//; - $output_expr{$_} = ''; - $current = \$output_expr{$_}; - } - } - } - close(TYPEMAP); -} - -foreach $key (keys %input_expr) { - $input_expr{$key} =~ s/\n+$//; -} - -sub Q { - local $text = shift; - $text =~ tr/#//d; - $text =~ s/\[\[/{/g; - $text =~ s/\]\]/}/g; - $text; -} - -open(F, $filename) || die "cannot open $filename\n"; - -while (<F>) { - last if ($Module, $foo, $Package, $foo1, $Prefix) = - /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/; - print $_; -} -exit 0 if $_ eq ""; -$lastline = $_; - -sub fetch_para { - # parse paragraph - @line = (); - if ($lastline ne "") { - if ($lastline =~ - /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) { - $Module = $1; - $foo = $2; - $Package = $3; - $foo1 = $4; - $Prefix = $5; - ($Module_cname = $Module) =~ s/\W/_/g; - ($Packid = $Package) =~ s/:/_/g; - $Packprefix = $Package; - $Packprefix .= "::" if defined $Packprefix && $Packprefix ne ""; - while (<F>) { - chop; - next if /^#/ && - !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; - last if /^\S/; - } - push(@line, $_) if $_ ne ""; - } - else { - push(@line, $lastline); - } - $lastline = ""; - while (<F>) { - next if /^#/ && - !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; - chop; - if (/^\S/ && @line && $line[-1] eq "") { - $lastline = $_; - last; - } - else { - push(@line, $_); - } - } - pop(@line) while @line && $line[-1] =~ /^\s*$/; - } - $PPCODE = grep(/PPCODE:/, @line); - scalar @line; -} - -while (&fetch_para) { - # initialize info arrays - undef(%args_match); - undef(%var_types); - undef(%var_addr); - undef(%defaults); - undef($class); - undef($static); - undef($elipsis); - - # extract return type, function name and arguments - $ret_type = shift(@line); - if ($ret_type =~ /^BOOT:/) { - push (@BootCode, @line, "", "") ; - next ; - } - if ($ret_type =~ /^static\s+(.*)$/) { - $static = 1; - $ret_type = $1; - } - $func_header = shift(@line); - ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/; - if ($func_name =~ /(.*)::(.*)/) { - $class = $1; - $func_name = $2; - } - ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; - push(@Func_name, "${Packid}_$func_name"); - push(@Func_pname, $pname); - @args = split(/\s*,\s*/, $orig_args); - if (defined($class)) { - if (defined($static)) { - unshift(@args, "CLASS"); - $orig_args = "CLASS, $orig_args"; - $orig_args =~ s/^CLASS, $/CLASS/; - } - else { - unshift(@args, "THIS"); - $orig_args = "THIS, $orig_args"; - $orig_args =~ s/^THIS, $/THIS/; - } - } - $orig_args =~ s/"/\\"/g; - $min_args = $num_args = @args; - foreach $i (0..$num_args-1) { - if ($args[$i] =~ s/\.\.\.//) { - $elipsis = 1; - $min_args--; - if ($args[i] eq '' && $i == $num_args - 1) { - pop(@args); - last; - } - } - if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) { - $min_args--; - $args[$i] = $1; - $defaults{$args[$i]} = $2; - $defaults{$args[$i]} =~ s/"/\\"/g; - } - } - if (defined($class)) { - $func_args = join(", ", @args[1..$#args]); - } else { - $func_args = join(", ", @args); - } - @args_match{@args} = 1..@args; - - # print function header - print Q<<"EOF"; -#XS(XS_${Packid}_$func_name) -#[[ -# dXSARGS; -EOF - if ($elipsis) { - $cond = qq(items < $min_args); - } - elsif ($min_args == $num_args) { - $cond = qq(items != $min_args); - } - else { - $cond = qq(items < $min_args || items > $num_args); - } - - print Q<<"EOF" if $except; -# char errbuf[1024]; -# *errbuf = '\0'; -EOF - - print Q<<"EOF"; -# if ($cond) { -# croak("Usage: $pname($orig_args)"); -# } -EOF - - print Q<<"EOF" if $PPCODE; -# SP -= items; -EOF - - # Now do a block of some sort. - - $condnum = 0; - if (!@line) { - @line = "CLEANUP:"; - } - while (@line) { - if ($_[0] =~ s/^\s*CASE\s*:\s*//) { - $cond = shift(@line); - if ($condnum == 0) { - print " if ($cond)\n"; - } - elsif ($cond ne '') { - print " else if ($cond)\n"; - } - else { - print " else\n"; - } - $condnum++; - } - - if ($except) { - print Q<<"EOF"; -# TRY [[ -EOF - } - else { - print Q<<"EOF"; -# [[ -EOF - } - - # do initialization of input variables - $thisdone = 0; - $retvaldone = 0; - $deferred = ""; - while (@line) { - $_ = shift(@line); - last if /^\s*NOT_IMPLEMENTED_YET/; - last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/; - # Catch common error. Much more error checking required here. - blurt("Error: no tab in $pname argument declaration '$_'\n") - unless (m/\S+\s*\t\s*\S+/); - ($var_type, $var_name, $var_init) = - /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/; - if ($var_name =~ /^&/) { - $var_name =~ s/^&//; - $var_addr{$var_name} = 1; - } - $thisdone |= $var_name eq "THIS"; - $retvaldone |= $var_name eq "RETVAL"; - $var_types{$var_name} = $var_type; - print "\t" . &map_type($var_type); - $var_num = $args_match{$var_name}; - if ($var_addr{$var_name}) { - $func_args =~ s/\b($var_name)\b/&\1/; - } - if ($var_init !~ /^=\s*NO_INIT\s*$/) { - if ($var_init !~ /^\s*$/) { - &output_init($var_type, $var_num, - "$var_name $var_init"); - } elsif ($var_num) { - # generate initialization code - &generate_init($var_type, $var_num, $var_name); - } else { - print ";\n"; - } - } else { - print "\t$var_name;\n"; - } - } - if (!$thisdone && defined($class)) { - if (defined($static)) { - print "\tchar *"; - $var_types{"CLASS"} = "char *"; - &generate_init("char *", 1, "CLASS"); - } - else { - print "\t$class *"; - $var_types{"THIS"} = "$class *"; - &generate_init("$class *", 1, "THIS"); - } - } - - # do code - if (/^\s*NOT_IMPLEMENTED_YET/) { - print "\ncroak(\"$pname: not implemented yet\");\n"; - } else { - if ($ret_type ne "void") { - print "\t" . &map_type($ret_type) . "\tRETVAL;\n" - if !$retvaldone; - $args_match{"RETVAL"} = 0; - $var_types{"RETVAL"} = $ret_type; - } - if (/^\s*PPCODE:/) { - print $deferred; - while (@line) { - $_ = shift(@line); - die "PPCODE must be last thing" - if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; - print "$_\n"; - } - print "\tPUTBACK;\n\treturn;\n"; - } elsif (/^\s*CODE:/) { - print $deferred; - while (@line) { - $_ = shift(@line); - last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; - print "$_\n"; - } - } elsif ($func_name eq "DESTROY") { - print $deferred; - print "\n\t"; - print "delete THIS;\n" - } else { - print $deferred; - print "\n\t"; - if ($ret_type ne "void") { - print "RETVAL = "; - } - if (defined($static)) { - if ($func_name =~ /^new/) { - $func_name = "$class"; - } - else { - print "$class::"; - } - } elsif (defined($class)) { - print "THIS->"; - } - if (defined($spat) && $func_name =~ /^($spat)(.*)$/) { - $func_name = $2; - } - print "$func_name($func_args);\n"; - &generate_output($ret_type, 0, "RETVAL") - unless $ret_type eq "void"; - } - } - - # do output variables - if (/^\s*OUTPUT\s*:/) { - while (@line) { - $_ = shift(@line); - last if /^\s*CLEANUP\s*:/; - s/^\s+//; - ($outarg, $outcode) = split(/\t+/); - if ($outcode) { - print "\t$outcode\n"; - } else { - die "$outarg not an argument" - unless defined($args_match{$outarg}); - $var_num = $args_match{$outarg}; - &generate_output($var_types{$outarg}, $var_num, - $outarg); - } - } - } - # do cleanup - if (/^\s*CLEANUP\s*:/) { - while (@line) { - $_ = shift(@line); - last if /^\s*CASE\s*:/; - print "$_\n"; - } - } - # print function trailer - if ($except) { - print Q<<EOF; -# ]] -# BEGHANDLERS -# CATCHALL -# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); -# ENDHANDLERS -EOF - } - else { - print Q<<EOF; -# ]] -EOF - } - if (/^\s*CASE\s*:/) { - unshift(@line, $_); - } - } - - print Q<<EOF if $except; -# if (errbuf[0]) -# croak(errbuf); -EOF - - print Q<<EOF unless $PPCODE; -# XSRETURN(1); -EOF - - print Q<<EOF; -#]] -# -EOF -} - -# print initialization routine -print qq/extern "C"\n/ if $cplusplus; -print Q<<"EOF"; -#XS(boot_$Module_cname) -#[[ -# dXSARGS; -# char* file = __FILE__; -# -EOF - -for (@Func_name) { - $pname = shift(@Func_pname); - print " newXS(\"$pname\", XS_$_, file);\n"; -} - -if (@BootCode) -{ - print "\n /* Initialisation Section */\n\n" ; - print grep (s/$/\n/, @BootCode) ; - print " /* End of Initialisation Section */\n\n" ; -} - -print " ST(0) = &sv_yes;\n"; -print " XSRETURN(1);\n"; -print "}\n"; - -sub output_init { - local($type, $num, $init) = @_; - local($arg) = "ST(" . ($num - 1) . ")"; - - eval qq/print " $init\\\n"/; -} - -sub blurt { warn @_; $errors++ } - -sub generate_init { - local($type, $num, $var) = @_; - local($arg) = "ST(" . ($num - 1) . ")"; - local($argoff) = $num - 1; - local($ntype); - local($tk); - - blurt("$type not in typemap"), return unless defined($type_kind{$type}); - ($ntype = $type) =~ s/\s*\*/Ptr/g; - $subtype = $ntype; - $subtype =~ s/Ptr$//; - $subtype =~ s/Array$//; - $tk = $type_kind{$type}; - $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; - $type =~ s/:/_/g; - $expr = $input_expr{$tk}; - if ($expr =~ /DO_ARRAY_ELEM/) { - $subexpr = $input_expr{$type_kind{$subtype}}; - $subexpr =~ s/ntype/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]/; - $expr =~ s/DO_ARRAY_ELEM/$subexpr/; - } - if (defined($defaults{$var})) { - $expr =~ s/(\t+)/$1 /g; - $expr =~ s/ /\t/g; - eval qq/print "\\t$var;\\n"/; - $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; - } elsif ($expr !~ /^\t\$var =/) { - eval qq/print "\\t$var;\\n"/; - $deferred .= eval qq/"\\n$expr;\\n"/; - } else { - eval qq/print "$expr;\\n"/; - } -} - -sub generate_output { - local($type, $num, $var) = @_; - local($arg) = "ST(" . ($num - ($num != 0)) . ")"; - local($argoff) = $num - 1; - local($ntype); - - if ($type =~ /^array\(([^,]*),(.*)\)/) { - print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; - } else { - blurt("$type not in typemap"), return - unless defined($type_kind{$type}); - ($ntype = $type) =~ s/\s*\*/Ptr/g; - $ntype =~ s/\(\)//g; - $subtype = $ntype; - $subtype =~ s/Ptr$//; - $subtype =~ s/Array$//; - $expr = $output_expr{$type_kind{$type}}; - if ($expr =~ /DO_ARRAY_ELEM/) { - $subexpr = $output_expr{$type_kind{$subtype}}; - $subexpr =~ s/ntype/subtype/g; - $subexpr =~ s/\$arg/ST(ix_$var)/g; - $subexpr =~ s/\$var/${var}[ix_$var]/g; - $subexpr =~ s/\n\t/\n\t\t/g; - $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; - eval "print qq\a$expr\a"; - } - elsif ($var eq 'RETVAL') { - if ($expr =~ /^\t\$arg = /) { - eval "print qq\a$expr\a"; - print "\tsv_2mortal(ST(0));\n"; - } - else { - print "\tST(0) = sv_newmortal();\n"; - eval "print qq\a$expr\a"; - } - } - elsif ($arg =~ /^ST\(\d+\)$/) { - eval "print qq\a$expr\a"; - } - elsif ($arg =~ /^ST\(\d+\)$/) { - eval "print qq\a$expr\a"; - } - elsif ($arg =~ /^ST\(\d+\)$/) { - eval "print qq\a$expr\a"; - } - } -} - -sub map_type { - local($type) = @_; - - $type =~ s/:/_/g; - if ($type =~ /^array\(([^,]*),(.*)\)/) { - return "$1 *"; - } else { - return $type; - } -} - -exit $errors; - -############################################################################## - - # These next few lines are legal in both Perl and nroff. - -.00 ; # finish .ig - -'di \" finish diversion--previous line must be blank -.nr nl 0-1 \" fake up transition to first page again -.nr % 0 \" start at page 1 -'; __END__ ############# From here on it's a standard manual page ############ -.TH XSUBPP 1 "August 9, 1994" -.AT 3 -.SH NAME -xsubpp \- compiler to convert Perl XS code into C code -.SH SYNOPSIS -.B xsubpp [-C++] [-except] [-typemap typemap] file.xs -.SH DESCRIPTION -.I xsubpp -will compile XS code into C code by embedding the constructs necessary to -let C functions manipulate Perl values and creates the glue necessary to let -Perl access those functions. The compiler uses typemaps to determine how -to map C function parameters and variables to Perl values. -.PP -The compiler will search for typemap files called -.I typemap. -It will use the following search path to find default typemaps, with the -rightmost typemap taking precedence. -.br -.nf - ../../../typemap:../../typemap:../typemap:typemap -.fi -.SH OPTIONS -.TP -.B \-C++ -.br -Adds ``extern "C"'' to the C code. -.TP -.B \-except -Adds exception handling stubs to the C code. -.TP -.B \-typemap typemap -Indicates that a user-supplied typemap should take precedence over the -default typemaps. This option may be used multiple times, with the last -typemap having the highest precedence. -.SH ENVIRONMENT -No environment variables are used. -.SH AUTHOR -Larry Wall -.SH "SEE ALSO" -perl(1) -.ex |