diff options
| -rw-r--r-- | MANIFEST | 2 | ||||
| -rw-r--r-- | XSUB.h | 6 | ||||
| -rw-r--r-- | cv.h | 2 | ||||
| -rw-r--r-- | ipstdio.h | 4 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 10 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Win32.pm | 8 | ||||
| -rw-r--r-- | lib/ExtUtils/MakeMaker.pm | 2 | ||||
| -rw-r--r-- | lib/ExtUtils/Mksymlists.pm | 7 | ||||
| -rwxr-xr-x | lib/ExtUtils/xsubpp | 40 | ||||
| -rw-r--r-- | op.c | 2 | ||||
| -rw-r--r-- | perl.h | 13 | ||||
| -rw-r--r-- | pp_ctl.c | 2 | ||||
| -rw-r--r-- | pp_hot.c | 2 | ||||
| -rw-r--r-- | proto.h | 38 | ||||
| -rw-r--r-- | sv.h | 2 | ||||
| -rw-r--r-- | thread.h | 2 | ||||
| -rw-r--r-- | win32/GenCAPI.pl | 1015 | ||||
| -rw-r--r-- | win32/Makefile | 33 | ||||
| -rw-r--r-- | win32/dl_win32.xs | 2 | ||||
| -rw-r--r-- | win32/runperl.c | 11 | ||||
| -rw-r--r-- | win32/win32.c | 8 |
21 files changed, 1160 insertions, 51 deletions
@@ -967,6 +967,7 @@ win32/config_h.PL Perl code to convert Win32 config.sh to config.h win32/config_sh.PL Perl code to update Win32 config.sh from Makefile win32/dl_win32.xs Win32 port win32/genxsdef.pl Win32 port +win32/GenCAPI.pl Win32 port for C API with PERL_OBJECT win32/include/arpa/inet.h Win32 port win32/include/dirent.h Win32 port win32/include/netdb.h Win32 port @@ -980,6 +981,7 @@ win32/perllib.c Win32 port win32/pod.mak Win32 port win32/runperl.c Win32 port win32/splittree.pl Win32 port +win32/TEST win32/win32.c Win32 port win32/win32.h Win32 port win32/win32iop.h Win32 port @@ -2,7 +2,7 @@ #ifdef CAN_PROTOTYPE #ifdef PERL_OBJECT -#define XS(name) void name(CPerlObj* pPerl, CV* cv) +#define XS(name) void name(CV* cv, CPerlObj* pPerl) #else #define XS(name) void name(CV* cv) #endif @@ -75,4 +75,8 @@ #include "XSLock.h" #endif /* WIN32 */ #endif /* NO_XSLOCKS */ +#else +#ifdef PERL_CAPI +#include "PerlCAPI.h" +#endif #endif /* PERL_OBJECT */ @@ -21,7 +21,7 @@ struct xpvcv { HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub) _((CPERLproto_ CV*)); + void (*xcv_xsub) _((CV* _CPERLproto)); ANY xcv_xsubany; GV * xcv_gv; GV * xcv_filegv; @@ -52,6 +52,10 @@ public: virtual int Setpos(PerlIO*, const Fpos_t *, int &err) = 0; virtual void Init(int &err) = 0; virtual void InitOSExtras(void* p) = 0; +#ifdef WIN32 + virtual int OpenOSfhandle(long osfhandle, int flags) = 0; + virtual int GetOSfhandle(int filenum) = 0; +#endif }; #endif /* __Inc__IPerlStdIO___ */ diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 92a46426da..9ae5abe0bd 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -368,6 +368,12 @@ sub cflags { $self->{uc $_} ||= $cflags{$_} } + if ($self->{CAPI}) { + $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\s|$)//; + $self->{CCFLAGS} =~ s/-TP(\s|$)//; + $self->{OPTIMIZE} =~ s/-TP(\s|$)//; + $self->{CCFLAGS} .= '-DPERL_CAPI'; + } return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} @@ -3240,9 +3246,11 @@ sub tool_xsubpp { } } + $xsubpp = $self->{CAPI} ? "xsubpp -perlobject" : "xsubpp"; + return qq{ XSUBPPDIR = $xsdir -XSUBPP = \$(XSUBPPDIR)/xsubpp +XSUBPP = \$(XSUBPPDIR)/$xsubpp XSPROTOARG = $self->{XSPROTOARG} XSUBPPDEPS = @tmdeps XSUBPPARGS = @tmargs diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index d6dfe4a613..5b0184c39e 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -449,8 +449,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists sub perl_archive { + my ($self) = @_; if($OBJ) { - return '$(PERL_INC)\perlcore$(LIB_EXT)'; + if ($self->{CAPI} eq 'TRUE') { + return '$(PERL_INC)\PerlCAPI$(LIB_EXT)'; + } + else { + return '$(PERL_INC)\perlcore$(LIB_EXT)'; + } } return '$(PERL_INC)\perl$(LIB_EXT)'; } diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index c86486ac1a..6735b034c0 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -235,7 +235,7 @@ sub full_setup { @Attrib_help = qw/ - AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION LICENSE_HREF + AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION LICENSE_HREF CAPI C CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS EXE_FILES EXCLUDE_EXT INCLUDE_EXT NO_VC FIRST_MAKEFILE FULLPERL H INC INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 4ac175af5e..2f2366a1c8 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -178,6 +178,13 @@ sub _write_vms { } close OPT; + # Options file specifying RTLs to which this extension must be linked. + # Eventually, the list of libraries will be supplied by a working + # extliblist routine. + open OPT,'>rtls.opt'; + print OPT "PerlShr/Share\n"; + foreach $rtl (split(/\s+/,$Config::Config{'libs'})) { print OPT "$rtl\n"; } + close OPT; } 1; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 58b3a08705..fafa9cc2d5 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -6,7 +6,7 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs +B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] [B<-perlobject>]... file.xs =head1 DESCRIPTION @@ -59,7 +59,11 @@ number. Prevents the inclusion of `#line' directives in the output. -=back +=item B<-perlobject> + +Compile code as C in a PERL_OBJECT environment. + +back =head1 ENVIRONMENT @@ -122,6 +126,7 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; + $WantCAPI = 1, next SWITCH if $flag eq 'perlobject'; $except = " TRY", next SWITCH if $flag eq 'except'; push(@tm,shift), next SWITCH if $flag eq 'typemap'; $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; @@ -1175,6 +1180,19 @@ EOF } # print initialization routine +if ($WantCAPI) { +print Q<<"EOF"; +# +##ifdef __cplusplus +#extern "C" +##endif +#XS(boot__CAPI_entry) +#[[ +# dXSARGS; +# char* file = __FILE__; +# +EOF +} else { print Q<<"EOF"; ##ifdef __cplusplus #extern "C" @@ -1185,6 +1203,7 @@ print Q<<"EOF"; # char* file = __FILE__; # EOF +} print Q<<"EOF" if $WantVersionChk ; # XS_VERSION_BOOTCHECK ; @@ -1215,7 +1234,24 @@ print Q<<"EOF";; # ST(0) = &sv_yes; # XSRETURN(1); #]] +# +EOF + +if ($WantCAPI) { +print Q<<"EOF"; +# +##define XSCAPI(name) void name(void* pPerl, CV* cv) +##ifdef __cplusplus +#extern "C" +##endif +#XSCAPI(boot_$Module_cname) +#[[ +# SetCPerlObj(pPerl); +# boot__CAPI_entry(cv); +#]] +# EOF +} warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") unless $ProtoUsed ; @@ -3550,7 +3550,7 @@ newCONSTSUB(HV *stash, char *name, SV *sv) } CV * -newXS(char *name, void (*subaddr) (CPERLproto_ CV *), char *filename) +newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename) { dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); @@ -104,11 +104,12 @@ class CPerlObj; #define STATIC #define CPERLscope(x) CPerlObj::x #define CPERLproto CPerlObj * -#define CPERLproto_ CPERLproto, +#define _CPERLproto ,CPERLproto #define CPERLarg CPerlObj *pPerl #define CPERLarg_ CPERLarg, +#define _CPERLarg ,CPERLarg #define THIS this -#define THIS_ this, +#define _THIS ,this #define CALLRUNOPS (this->*runops) #else /* !PERL_OBJECT */ @@ -116,10 +117,12 @@ class CPerlObj; #define STATIC static #define CPERLscope(x) x #define CPERLproto -#define CPERLproto_ +#define _CPERLproto #define CPERLarg void #define CPERLarg_ +#define _CPERLarg #define THIS +#define _THIS #define THIS_ #define CALLRUNOPS runops @@ -1195,6 +1198,10 @@ union any { IV any_iv; long any_long; void (CPERLscope(*any_dptr)) _((void*)); +#if defined(WIN32) && !defined(PERL_OBJECT) + /* Visual C thinks that a pointer to a member variable is 16 bytes in size. */ + char handle_VC_problem[16]; +#endif }; #ifdef USE_THREADS @@ -1762,7 +1762,7 @@ PP(pp_goto) } else { stack_sp--; /* There is no cv arg. */ - (void)(*CvXSUB(cv))(THIS_ cv); + (void)(*CvXSUB(cv))(cv _THIS); } LEAVE; return pop_return(); @@ -2093,7 +2093,7 @@ PP(pp_entersub) curcopdb = NULL; } /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(THIS_ cv); + (void)(*CvXSUB(cv))(cv _THIS); /* Enforce some sanity in scalar context. */ if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) { @@ -60,7 +60,7 @@ VIRTUAL OP* block_end _((I32 floor, OP* seq)); VIRTUAL I32 block_gimme _((void)); VIRTUAL int block_start _((int full)); VIRTUAL void boot_core_UNIVERSAL _((void)); -VIRTUAL void call_list _((I32 oldscope, AV* list)); +VIRTUAL void call_list _((I32 oldscope, AV* av_list)); VIRTUAL I32 cando _((I32 bit, I32 effective, Stat_t* statbufp)); #ifndef CASTNEGFLOAT VIRTUAL U32 cast_ulong _((double f)); @@ -276,7 +276,7 @@ VIRTUAL char* mem_collxfrm _((const char* s, STRLEN len, STRLEN* xlen)); #endif VIRTUAL char* mess _((const char* pat, va_list* args)); VIRTUAL int mg_clear _((SV* sv)); -VIRTUAL int mg_copy _((SV* , SV* , char* , I32)); +VIRTUAL int mg_copy _((SV* sv, SV* nsv, char* key, I32 klen)); VIRTUAL MAGIC* mg_find _((SV* sv, int type)); VIRTUAL int mg_free _((SV* sv)); VIRTUAL int mg_get _((SV* sv)); @@ -321,7 +321,7 @@ VIRTUAL OP* newASSIGNOP _((I32 flags, OP* left, I32 optype, OP* right)); VIRTUAL OP* newCONDOP _((I32 flags, OP* expr, OP* trueop, OP* falseop)); VIRTUAL void newCONSTSUB _((HV* stash, char* name, SV* sv)); VIRTUAL void newFORM _((I32 floor, OP* o, OP* block)); -VIRTUAL OP* newFOROP _((I32 flags, char* label, line_t forline, OP* scalar, OP* expr, OP*block, OP*cont)); +VIRTUAL OP* newFOROP _((I32 flags, char* label, line_t forline, OP* sclr, OP* expr, OP*block, OP*cont)); VIRTUAL OP* newLOGOP _((I32 optype, I32 flags, OP* left, OP* right)); VIRTUAL OP* newLOOPEX _((I32 type, OP* label)); VIRTUAL OP* newLOOPOP _((I32 flags, I32 debuggable, OP* expr, OP* block)); @@ -332,7 +332,7 @@ VIRTUAL OP* newRANGE _((I32 flags, OP* left, OP* right)); VIRTUAL OP* newSLICEOP _((I32 flags, OP* subscript, OP* list)); VIRTUAL OP* newSTATEOP _((I32 flags, char* label, OP* o)); VIRTUAL CV* newSUB _((I32 floor, OP* o, OP* proto, OP* block)); -VIRTUAL CV* newXS _((char* name, void (*subaddr)(CPERLproto_ CV* cv), char* filename)); +VIRTUAL CV* newXS _((char* name, void (*subaddr)(CV* cv _CPERLproto), char* filename)); VIRTUAL AV* newAV _((void)); VIRTUAL OP* newAVREF _((OP* o)); VIRTUAL OP* newBINOP _((I32 type, I32 flags, OP* first, OP* last)); @@ -346,9 +346,9 @@ VIRTUAL IO* newIO _((void)); VIRTUAL OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last)); VIRTUAL OP* newPMOP _((I32 type, I32 flags)); VIRTUAL OP* newPVOP _((I32 type, I32 flags, char* pv)); -VIRTUAL SV* newRV _((SV* ref)); +VIRTUAL SV* newRV _((SV* pref)); #if !defined(__GNUC__) && (defined(CRIPPLED_CC) || defined(USE_THREADS) || defined(PERL_OBJECT)) -VIRTUAL SV* newRV_noinc _((SV *)); +VIRTUAL SV* newRV_noinc _((SV *sv)); #endif #ifdef LEAKTEST VIRTUAL SV* newSV _((I32 x, STRLEN len)); @@ -389,9 +389,9 @@ VIRTUAL void peep _((OP* o)); #ifndef PERL_OBJECT PerlInterpreter* perl_alloc _((void)); #endif -VIRTUAL I32 perl_call_argv _((char* subname, I32 flags, char** argv)); +VIRTUAL I32 perl_call_argv _((char* sub_name, I32 flags, char** argv)); VIRTUAL I32 perl_call_method _((char* methname, I32 flags)); -VIRTUAL I32 perl_call_pv _((char* subname, I32 flags)); +VIRTUAL I32 perl_call_pv _((char* sub_name, I32 flags)); VIRTUAL I32 perl_call_sv _((SV* sv, I32 flags)); #ifdef PERL_OBJECT VIRTUAL void perl_construct _((void)); @@ -448,19 +448,19 @@ void regdump _((regexp* r)); VIRTUAL I32 pregexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave)); VIRTUAL I32 regexec_flags _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, void* data, U32 flags)); VIRTUAL void pregfree _((struct regexp* r)); -VIRTUAL regnode*regnext _((regnode* p)); +VIRTUAL regnode* regnext _((regnode* p)); #ifdef DEBUGGING void regprop _((SV* sv, regnode* o)); #endif VIRTUAL void repeatcpy _((char* to, char* from, I32 len, I32 count)); VIRTUAL char* rninstr _((char* big, char* bigend, char* little, char* lend)); -VIRTUAL Sighandler_t rsignal _((int, Sighandler_t)); -VIRTUAL int rsignal_restore _((int, Sigsave_t*)); -VIRTUAL int rsignal_save _((int, Sighandler_t, Sigsave_t*)); -VIRTUAL Sighandler_t rsignal_state _((int)); +VIRTUAL Sighandler_t rsignal _((int i, Sighandler_t t)); +VIRTUAL int rsignal_restore _((int i, Sigsave_t* t)); +VIRTUAL int rsignal_save _((int i, Sighandler_t t1, Sigsave_t* t2)); +VIRTUAL Sighandler_t rsignal_state _((int i)); VIRTUAL void rxres_free _((void** rsp)); -VIRTUAL void rxres_restore _((void** rsp, REGEXP* rx)); -VIRTUAL void rxres_save _((void** rsp, REGEXP* rx)); +VIRTUAL void rxres_restore _((void** rsp, REGEXP* prx)); +VIRTUAL void rxres_save _((void** rsp, REGEXP* prx)); #ifndef HAS_RENAME VIRTUAL I32 same_dirent _((char* a, char* b)); #endif @@ -532,8 +532,8 @@ VIRTUAL UV sv_2uv _((SV* sv)); VIRTUAL IV sv_iv _((SV* sv)); VIRTUAL UV sv_uv _((SV* sv)); VIRTUAL double sv_nv _((SV* sv)); -VIRTUAL char * sv_pvn _((SV *, STRLEN *)); -VIRTUAL I32 sv_true _((SV *)); +VIRTUAL char * sv_pvn _((SV *sv, STRLEN *len)); +VIRTUAL I32 sv_true _((SV *sv)); VIRTUAL void sv_add_arena _((char* ptr, U32 size, U32 flags)); VIRTUAL int sv_backoff _((SV* sv)); VIRTUAL SV* sv_bless _((SV* sv, HV* stash)); @@ -1233,10 +1233,10 @@ void restore_rsfp _((void *f)); void restore_expect _((void *e)); void restore_lex_expect _((void *e)); void yydestruct _((void *ptr)); -VIRTUAL int fprintf _((PerlIO *, const char *, ...)); +VIRTUAL int fprintf _((PerlIO *pf, const char *pat, ...)); #ifdef WIN32 -VIRTUAL int& ErrorNo(); +VIRTUAL int& ErrorNo _((void)); #endif /* WIN32 */ #else /* !PERL_OBJECT */ END_EXTERN_C @@ -270,7 +270,7 @@ struct xpvfm { HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub)_((CV*)); + void (*xcv_xsub)_((CV* _CPERLproto)); ANY xcv_xsubany; GV * xcv_gv; GV * xcv_filegv; @@ -225,7 +225,7 @@ typedef struct condpair { #define THR /* Rats: if dTHR is just blank then the subsequent ";" throws an error */ #ifdef WIN32 -#define dTHR +#define dTHR extern int Perl___notused #else #define dTHR extern int errno #endif diff --git a/win32/GenCAPI.pl b/win32/GenCAPI.pl new file mode 100644 index 0000000000..d096da302e --- /dev/null +++ b/win32/GenCAPI.pl @@ -0,0 +1,1015 @@ + +# creates a C API file from proto.h +# takes one argument, the path to lib/CORE directory. +# creates 2 files: "PerlCAPI.cpp" and "PerlCAPI.h". + +my $hdrfile = "$ARGV[0]\\PerlCAPI.h"; +my $infile = '..\\proto.h'; +my $embedfile = '..\\embed.h'; +my $separateObj = 0; + +my %skip_list; +my %embed; + +sub readembed(\%$) { + my ($syms, $file) = @_; + my ($line, @words); + %$syms = (); + local (*FILE, $_); + open(FILE, "< $file") + or die "$0: Can't open $file: $!\n"; + while ($line = <FILE>) { + chop($line); + if ($line =~ /^#define\s+\w+/) { + $line =~ s/^#define\s+//; + @words = split ' ', $line; +# print "$words[0]\t$words[1]\n"; + $$syms{$words[0]} = $words[1]; + } + } + close(FILE); +} + +readembed %embed, $embedfile; + +sub skip_these { + my $list = shift; + foreach my $symbol (@$list) { + $skip_list{$symbol} = 1; + } +} + +skip_these [qw( +cando +cast_ulong +my_chsize +condpair_magic +deb +deb_growlevel +debprofdump +debop +debstack +debstackptrs +fprintf +find_threadsv +magic_mutexfree +my_pclose +my_popen +my_swap +my_htonl +my_ntohl +new_struct_thread +same_dirent +unlnk +unlock_condpair +safexmalloc +safexcalloc +safexrealloc +safexfree +Perl_GetVars +)]; + + + +if (!open(INFILE, "<$infile")) { + print "open of $infile failed: $!\n"; + return 1; +} + +if (!open(OUTFILE, ">PerlCAPI.cpp")) { + print "open of PerlCAPI.cpp failed: $!\n"; + return 1; +} + +print OUTFILE "#include \"EXTERN.h\"\n#include \"perl.h\"\n#include \"XSUB.h\"\n\n"; +print OUTFILE "#define DESTRUCTORFUNC (void (*)(void*))\n\n"; +print OUTFILE "#ifdef SetCPerlObj_defined\n" unless ($separateObj == 0); +print OUTFILE "extern \"C\" void SetCPerlObj(CPerlObj* pP)\n{\n\tpPerl = pP;\n}\n"; +print OUTFILE "#endif\n" unless ($separateObj == 0); + +while () { + last unless defined ($_ = <INFILE>); + if (/^VIRTUAL\s/) { + while (!/;$/) { + chomp; + $_ .= <INFILE>; + } + $_ =~ s/^VIRTUAL\s*//; + $_ =~ s/\s*__attribute__.*$/;/; + if ( /(.*)\s([A-z_]*[0-9A-z_]+\s)_\(\((.*)\)\);/ || + /(.*)\*([A-z_]*[0-9A-z_]+\s)_\(\((.*)\)\);/ ) { + $type = $1; + $name = $2; + $args = $3; + + $name =~ s/\s*$//; + $type =~ s/\s*$//; + next if (defined $skip_list{$name}); + + if($args eq "ARGSproto") { + $args = "void"; + } + + $return = ($type eq "void" or $type eq "Free_t") ? "\t" : "\treturn"; + + if(defined $embed{$name}) { + $funcName = $embed{$name}; + } else { + $funcName = $name; + } + + @args = split(',', $args); + if ($args[$#args] =~ /\s*\.\.\.\s*/) { + if(($name eq "croak") or ($name eq "deb") or ($name eq "die") + or ($name eq "form") or ($name eq "warn")) { + print OUTFILE "\n#ifdef $name" . "_defined" unless ($separateObj == 0); + print OUTFILE "\n#undef $name\nextern \"C\" $type $funcName ($args)\n{\n"; + $args[0] =~ /(\w+)\W*$/; + $arg = $1; + print OUTFILE "\tva_list args;\n\tva_start(args, $arg);\n"; + print OUTFILE "$return pPerl->Perl_$name(pPerl->Perl_mess($arg, &args));\n"; + print OUTFILE "\tva_end(args);\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + } + elsif($name eq "newSVpvf") { + print OUTFILE "\n#ifdef $name" . "_defined" unless ($separateObj == 0); + print OUTFILE "\n#undef $name\nextern \"C\" $type $funcName ($args)\n{\n"; + $args[0] =~ /(\w+)\W*$/; + $arg = $1; + print OUTFILE "\tSV *sv;\n\tva_list args;\n\tva_start(args, $arg);\n"; + print OUTFILE "\tsv = pPerl->Perl_newSV(0);\n"; + print OUTFILE "\tpPerl->Perl_sv_vcatpvfn(sv, $arg, strlen($arg), &args, NULL, 0, NULL);\n"; + print OUTFILE "\tva_end(args);\n\treturn sv;\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + } + elsif($name eq "sv_catpvf") { + print OUTFILE "\n#ifdef $name" . "_defined" unless ($separateObj == 0); + print OUTFILE "\n#undef $name\nextern \"C\" $type $funcName ($args)\n{\n"; + $args[0] =~ /(\w+)\W*$/; + $arg0 = $1; + $args[1] =~ /(\w+)\W*$/; + $arg1 = $1; + print OUTFILE "\tva_list args;\n\tva_start(args, $arg1);\n"; + print OUTFILE "\tpPerl->Perl_sv_vcatpvfn($arg0, $arg1, strlen($arg1), &args, NULL, 0, NULL);\n"; + print OUTFILE "\tva_end(args);\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + } + elsif($name eq "sv_setpvf") { + print OUTFILE "\n#ifdef $name" . "_defined" unless ($separateObj == 0); + print OUTFILE "\n#undef $name\nextern \"C\" $type $funcName ($args)\n{\n"; + $args[0] =~ /(\w+)\W*$/; + $arg0 = $1; + $args[1] =~ /(\w+)\W*$/; + $arg1 = $1; + print OUTFILE "\tva_list args;\n\tva_start(args, $arg1);\n"; + print OUTFILE "\tpPerl->Perl_sv_vsetpvfn($arg0, $arg1, strlen($arg1), &args, NULL, 0, NULL);\n"; + print OUTFILE "\tva_end(args);\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + } + elsif($name eq "fprintf") { + print OUTFILE "\n#ifdef $name" . "_defined" unless ($separateObj == 0); + print OUTFILE "\n#undef $name\nextern \"C\" $type $name ($args)\n{\n"; + $args[0] =~ /(\w+)\W*$/; + $arg0 = $1; + $args[1] =~ /(\w+)\W*$/; + $arg1 = $1; + print OUTFILE "\tint nRet;\n\tva_list args;\n\tva_start(args, $arg1);\n"; + print OUTFILE "\tnRet = PerlIO_vprintf($arg0, $arg1, args);\n"; + print OUTFILE "\tva_end(args);\n\treturn nRet;\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + } else { + print "Warning: can't handle varargs function '$name'\n"; + } + next; + } + + # newXS special case + if ($name eq "newXS") { + next; + } + + print OUTFILE "\n#ifdef $name" . "defined" unless ($separateObj == 0); + + # handle specical case for save_destructor + if ($name eq "save_destructor") { + next; + } + # handle specical case for sighandler + if ($name eq "sighandler") { + next; + } + # handle special case for sv_grow + if ($name eq "sv_grow" and $args eq "SV* sv, unsigned long newlen") { + next; + } + # handle special case for newSV + if ($name eq "newSV" and $args eq "I32 x, STRLEN len") { + next; + } + # handle special case for perl_parse + if ($name eq "perl_parse") { + print OUTFILE "\n#undef $name\nextern \"C\" $type $name ($args)\n{\n"; + print OUTFILE "\treturn pPerl->perl_parse(xsinit, argc, argv, env);\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + next; + } + + # foo(void); + if ($args eq "void") { + print OUTFILE "\n#undef $name\nextern \"C\" $type $funcName ()\n{\n$return pPerl->$funcName();\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + next; + } + + # foo(char *s, const int bar); + print OUTFILE "\n#undef $name\nextern \"C\" $type $funcName ($args)\n{\n$return pPerl->$funcName"; + $doneone = 0; + foreach $arg (@args) { + if ($arg =~ /(\w+)\W*$/) { + if ($doneone) { + print OUTFILE ", $1"; + } + else { + print OUTFILE "($1"; + $doneone++; + } + } + } + print OUTFILE ");\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + } + else { + print "failed to match $_"; + } + } +} + +close INFILE; + +%skip_list = (); + +skip_these [qw( +strchop +filemode +lastfd +oldname +curinterp +Argv +Cmd +sortcop +sortstash +firstgv +secondgv +sortstack +signalstack +mystrk +dumplvl +oldlastpm +gensym +preambled +preambleav +Ilaststatval +Ilaststype +mess_sv +ors +opsave +eval_mutex +orslen +ofmt +mh +modcount +generation +DBcv +archpat_auto +sortcxix +lastgotoprobe +regdummy +regparse +regxend +regcode +regnaughty +regsawback +regprecomp +regnpar +regsize +regflags +regseen +seen_zerolen +rx +extralen +colorset +colors +reginput +regbol +regeol +regstartp +regendp +reglastparen +regtill +regprev +reg_start_tmp +reg_start_tmpl +regdata +bostr +reg_flags +reg_eval_set +regnarrate +regprogram +regindent +regcc +in_clean_objs +in_clean_all +linestart +pending_ident +statusvalue_vms +sublex_info +thrsv +threadnum +piMem +piENV +piStdIO +piLIO +piDir +piSock +piProc +cshname +threadsv_names +thread +nthreads +thr_key +threads_mutex +malloc_mutex +svref_mutex +sv_mutex +nthreads_cond +eval_cond +cryptseen +cshlen +)]; + +sub readvars(\%$$) { + my ($syms, $file, $pre) = @_; + %$syms = (); + local (*FILE, $_); + open(FILE, "< $file") + or die "$0: Can't open $file: $!\n"; + while (<FILE>) { + s/[ \t]*#.*//; # Delete comments. + if (/PERLVARI?C?\($pre(\w+),\s*([^,)]+)/) { + $$syms{$1} = $2; + } + } + close(FILE); +} + +my %intrp; +my %thread; +my %globvar; + +readvars %intrp, '..\intrpvar.h','I'; +readvars %thread, '..\thrdvar.h','T'; +readvars %globvar, '..\perlvars.h','G'; + +open(HDRFILE, ">$hdrfile") or die "$0: Can't open $hdrfile: $!\n"; +print HDRFILE "\nvoid SetCPerlObj(void* pP);"; +print HDRFILE "\nCV* Perl_newXS(char* name, void (*subaddr)(CV* cv), char* filename);\n"; + +sub DoVariable($$) { + my $name = shift; + my $type = shift; + + return if (defined $skip_list{$name}); + return if ($type eq 'struct perl_thread *'); + + print OUTFILE "\n#ifdef $name" . "_defined" unless ($separateObj == 0); + print OUTFILE "\nextern \"C\" $type * _Perl_$name ()\n{\n"; + print OUTFILE "\treturn (($type *)&pPerl->Perl_$name);\n}\n"; + print OUTFILE "#endif\n" unless ($separateObj == 0); + + print HDRFILE "\n#undef Perl_$name\n$type * _Perl_$name ();"; + print HDRFILE "\n#define Perl_$name (*_Perl_$name())\n\n"; +} + +foreach $key (keys %intrp) { + DoVariable ($key, $intrp{$key}); +} + +foreach $key (keys %thread) { + DoVariable ($key, $thread{$key}); +} + +foreach $key (keys %globvar) { + DoVariable ($key, $globvar{$key}); +} + +print OUTFILE <<EOCODE; + + +extern "C" { +void xs_handler(CV* cv, CPerlObj* pPerl) +{ + void(*func)(CV*); + SV* sv; + MAGIC* m = pPerl->Perl_mg_find((SV*)cv, '~'); + if(m != NULL) + { + sv = m->mg_obj; + if(SvIOK(sv)) + { + func = (void(*)(CV*))SvIVX(sv); + } + else + { + func = (void(*)(CV*))pPerl->Perl_sv_2iv(sv); + } + SetCPerlObj(pPerl); + func(cv); + } +} + +CV* Perl_newXS(char* name, void (*subaddr)(CV* cv), char* filename) +{ + CV* cv = pPerl->Perl_newXS(name, xs_handler, filename); + pPerl->Perl_sv_magic((SV*)cv, pPerl->Perl_sv_2mortal(pPerl->Perl_newSViv((IV)subaddr)), '~', "CAPI", 4); + return cv; +} + +#undef piMem +#undef piENV +#undef piStdIO +#undef piLIO +#undef piDir +#undef piSock +#undef piProc + +int * _win32_errno(void) +{ + return &pPerl->ErrorNo(); +} + +FILE* _win32_stdin(void) +{ + return (FILE*)pPerl->piStdIO->Stdin(); +} + +FILE* _win32_stdout(void) +{ + return (FILE*)pPerl->piStdIO->Stdout(); +} + +FILE* _win32_stderr(void) +{ + return (FILE*)pPerl->piStdIO->Stderr(); +} + +int _win32_ferror(FILE *fp) +{ + return pPerl->piStdIO->Error((PerlIO*)fp, ErrorNo()); +} + +int _win32_feof(FILE *fp) +{ + return pPerl->piStdIO->Eof((PerlIO*)fp, ErrorNo()); +} + +char* _win32_strerror(int e) +{ + return strerror(e); +} + +void _win32_perror(const char *str) +{ + perror(str); +} + +int _win32_vfprintf(FILE *pf, const char *format, va_list arg) +{ + return pPerl->piStdIO->Vprintf((PerlIO*)pf, ErrorNo(), format, arg); +} + +int _win32_vprintf(const char *format, va_list arg) +{ + return pPerl->piStdIO->Vprintf(pPerl->piStdIO->Stdout(), ErrorNo(), format, arg); +} + +int _win32_fprintf(FILE *pf, const char *format, ...) +{ + int ret; + va_list args; + va_start(args, format); + ret = _win32_vfprintf(pf, format, args); + va_end(args); + return ret; +} + +int _win32_printf(const char *format, ...) +{ + int ret; + va_list args; + va_start(args, format); + ret = _win32_vprintf(format, args); + va_end(args); + return ret; +} + +size_t _win32_fread(void *buf, size_t size, size_t count, FILE *pf) +{ + return pPerl->piStdIO->Read((PerlIO*)pf, buf, (size*count), ErrorNo()); +} + +size_t _win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf) +{ + return pPerl->piStdIO->Write((PerlIO*)pf, buf, (size*count), ErrorNo()); +} + +FILE* _win32_fopen(const char *path, const char *mode) +{ + return (FILE*)pPerl->piStdIO->Open(path, mode, ErrorNo()); +} + +FILE* _win32_fdopen(int fh, const char *mode) +{ + return (FILE*)pPerl->piStdIO->Fdopen(fh, mode, ErrorNo()); +} + +FILE* _win32_freopen(const char *path, const char *mode, FILE *pf) +{ + return (FILE*)pPerl->piStdIO->Reopen(path, mode, (PerlIO*)pf, ErrorNo()); +} + +int _win32_fclose(FILE *pf) +{ + return pPerl->piStdIO->Close((PerlIO*)pf, ErrorNo()); +} + +int _win32_fputs(const char *s,FILE *pf) +{ + return pPerl->piStdIO->Puts((PerlIO*)pf, s, ErrorNo()); +} + +int _win32_fputc(int c,FILE *pf) +{ + return pPerl->piStdIO->Putc((PerlIO*)pf, c, ErrorNo()); +} + +int _win32_ungetc(int c,FILE *pf) +{ + return pPerl->piStdIO->Ungetc((PerlIO*)pf, c, ErrorNo()); +} + +int _win32_getc(FILE *pf) +{ + return pPerl->piStdIO->Getc((PerlIO*)pf, ErrorNo()); +} + +int _win32_fileno(FILE *pf) +{ + return pPerl->piStdIO->Fileno((PerlIO*)pf, ErrorNo()); +} + +void _win32_clearerr(FILE *pf) +{ + pPerl->piStdIO->Clearerr((PerlIO*)pf, ErrorNo()); +} + +int _win32_fflush(FILE *pf) +{ + return pPerl->piStdIO->Flush((PerlIO*)pf, ErrorNo()); +} + +long _win32_ftell(FILE *pf) +{ + return pPerl->piStdIO->Tell((PerlIO*)pf, ErrorNo()); +} + +int _win32_fseek(FILE *pf,long offset,int origin) +{ + return pPerl->piStdIO->Seek((PerlIO*)pf, offset, origin, ErrorNo()); +} + +int _win32_fgetpos(FILE *pf,fpos_t *p) +{ + return pPerl->piStdIO->Getpos((PerlIO*)pf, p, ErrorNo()); +} + +int _win32_fsetpos(FILE *pf,const fpos_t *p) +{ + return pPerl->piStdIO->Setpos((PerlIO*)pf, p, ErrorNo()); +} + +void _win32_rewind(FILE *pf) +{ + pPerl->piStdIO->Rewind((PerlIO*)pf, ErrorNo()); +} + +FILE* _win32_tmpfile(void) +{ + return (FILE*)pPerl->piStdIO->Tmpfile(ErrorNo()); +} + +void _win32_setbuf(FILE *pf, char *buf) +{ + pPerl->piStdIO->SetBuf((PerlIO*)pf, buf, ErrorNo()); +} + +int _win32_setvbuf(FILE *pf, char *buf, int type, size_t size) +{ + return pPerl->piStdIO->SetVBuf((PerlIO*)pf, buf, type, size, ErrorNo()); +} + +int _win32_fgetc(FILE *pf) +{ + return pPerl->piStdIO->Getc((PerlIO*)pf, ErrorNo()); +} + +int _win32_putc(int c, FILE *pf) +{ + return pPerl->piStdIO->Putc((PerlIO*)pf, c, ErrorNo()); +} + +int _win32_puts(const char *s) +{ + return pPerl->piStdIO->Puts(pPerl->piStdIO->Stdout(), s, ErrorNo()); +} + +int _win32_getchar(void) +{ + return pPerl->piStdIO->Getc(pPerl->piStdIO->Stdin(), ErrorNo()); +} + +int _win32_putchar(int c) +{ + return pPerl->piStdIO->Putc(pPerl->piStdIO->Stdout(), c, ErrorNo()); +} + +void* _win32_malloc(size_t size) +{ + return pPerl->piMem->Malloc(size); +} + +void* _win32_calloc(size_t numitems, size_t size) +{ + return pPerl->piMem->Malloc(numitems*size); +} + +void* _win32_realloc(void *block, size_t size) +{ + return pPerl->piMem->Realloc(block, size); +} + +void _win32_free(void *block) +{ + pPerl->piMem->Free(block); +} + +void _win32_abort(void) +{ + pPerl->piProc->Abort(); +} + +int _win32_pipe(int *phandles, unsigned int psize, int textmode) +{ + return pPerl->piProc->Pipe(phandles); +} + +FILE* _win32_popen(const char *command, const char *mode) +{ + return (FILE*)pPerl->piProc->Popen(command, mode); +} + +int _win32_pclose(FILE *pf) +{ + return pPerl->piProc->Pclose((PerlIO*)pf); +} + +unsigned _win32_sleep(unsigned int t) +{ + return pPerl->piProc->Sleep(t); +} + +int _win32_spawnvp(int mode, const char *cmdname, const char *const *argv) +{ + return pPerl->piProc->Spawnvp(mode, cmdname, argv); +} + +int _win32_mkdir(const char *dir, int mode) +{ + return pPerl->piDir->Makedir(dir, mode, ErrorNo()); +} + +int _win32_rmdir(const char *dir) +{ + return pPerl->piDir->Rmdir(dir, ErrorNo()); +} + +int _win32_chdir(const char *dir) +{ + return pPerl->piDir->Chdir(dir, ErrorNo()); +} + +#undef stat +int _win32_fstat(int fd,struct stat *sbufptr) +{ + return pPerl->piLIO->FileStat(fd, sbufptr, ErrorNo()); +} + +int _win32_stat(const char *name,struct stat *sbufptr) +{ + return pPerl->piLIO->NameStat(name, sbufptr, ErrorNo()); +} + +int _win32_setmode(int fd, int mode) +{ + return pPerl->piLIO->Setmode(fd, mode, ErrorNo()); +} + +long _win32_lseek(int fd, long offset, int origin) +{ + return pPerl->piLIO->Lseek(fd, offset, origin, ErrorNo()); +} + +long _win32_tell(int fd) +{ + return pPerl->piStdIO->Tell((PerlIO*)fd, ErrorNo()); +} + +int _win32_dup(int fd) +{ + return pPerl->piLIO->Dup(fd, ErrorNo()); +} + +int _win32_dup2(int h1, int h2) +{ + return pPerl->piLIO->Dup2(h1, h2, ErrorNo()); +} + +int _win32_open(const char *path, int oflag,...) +{ + return pPerl->piLIO->Open(path, oflag, ErrorNo()); +} + +int _win32_close(int fd) +{ + return pPerl->piLIO->Close(fd, ErrorNo()); +} + +int _win32_read(int fd, void *buf, unsigned int cnt) +{ + return pPerl->piLIO->Read(fd, buf, cnt, ErrorNo()); +} + +int _win32_write(int fd, const void *buf, unsigned int cnt) +{ + return pPerl->piLIO->Write(fd, buf, cnt, ErrorNo()); +} + +int _win32_times(struct tms *timebuf) +{ + return pPerl->piProc->Times(timebuf); +} + +int _win32_ioctl(int i, unsigned int u, char *data) +{ + return pPerl->piLIO->IOCtl(i, u, data, ErrorNo()); +} + +int _win32_utime(const char *f, struct utimbuf *t) +{ + return pPerl->piLIO->Utime((char*)f, t, ErrorNo()); +} + +char* _win32_getenv(const char *name) +{ + return pPerl->piENV->Getenv(name, ErrorNo()); +} + +int _win32_open_osfhandle(long handle, int flags) +{ + return pPerl->piStdIO->OpenOSfhandle(handle, flags); +} + +long _win32_get_osfhandle(int fd) +{ + return pPerl->piStdIO->GetOSfhandle(fd); +} +} /* extern "C" */ +EOCODE + + +print HDRFILE <<EOCODE; +#undef win32_errno +#undef win32_stdin +#undef win32_stdout +#undef win32_stderr +#undef win32_ferror +#undef win32_feof +#undef win32_fprintf +#undef win32_printf +#undef win32_vfprintf +#undef win32_vprintf +#undef win32_fread +#undef win32_fwrite +#undef win32_fopen +#undef win32_fdopen +#undef win32_freopen +#undef win32_fclose +#undef win32_fputs +#undef win32_fputc +#undef win32_ungetc +#undef win32_getc +#undef win32_fileno +#undef win32_clearerr +#undef win32_fflush +#undef win32_ftell +#undef win32_fseek +#undef win32_fgetpos +#undef win32_fsetpos +#undef win32_rewind +#undef win32_tmpfile +#undef win32_abort +#undef win32_fstat +#undef win32_stat +#undef win32_pipe +#undef win32_popen +#undef win32_pclose +#undef win32_setmode +#undef win32_lseek +#undef win32_tell +#undef win32_dup +#undef win32_dup2 +#undef win32_open +#undef win32_close +#undef win32_eof +#undef win32_read +#undef win32_write +#undef win32_mkdir +#undef win32_rmdir +#undef win32_chdir +#undef win32_setbuf +#undef win32_setvbuf +#undef win32_fgetc +#undef win32_putc +#undef win32_puts +#undef win32_getchar +#undef win32_putchar +#undef win32_malloc +#undef win32_calloc +#undef win32_realloc +#undef win32_free +#undef win32_sleep +#undef win32_times +#undef win32_stat +#undef win32_ioctl +#undef win32_utime +#undef win32_getenv + +#define win32_errno _win32_errno +#define win32_stdin _win32_stdin +#define win32_stdout _win32_stdout +#define win32_stderr _win32_stderr +#define win32_ferror _win32_ferror +#define win32_feof _win32_feof +#define win32_strerror _win32_strerror +#define win32_perror _win32_perror +#define win32_fprintf _win32_fprintf +#define win32_printf _win32_printf +#define win32_vfprintf _win32_vfprintf +#define win32_vprintf _win32_vprintf +#define win32_fread _win32_fread +#define win32_fwrite _win32_fwrite +#define win32_fopen _win32_fopen +#define win32_fdopen _win32_fdopen +#define win32_freopen _win32_freopen +#define win32_fclose _win32_fclose +#define win32_fputs _win32_fputs +#define win32_fputc _win32_fputc +#define win32_ungetc _win32_ungetc +#define win32_getc _win32_getc +#define win32_fileno _win32_fileno +#define win32_clearerr _win32_clearerr +#define win32_fflush _win32_fflush +#define win32_ftell _win32_ftell +#define win32_fseek _win32_fseek +#define win32_fgetpos _win32_fgetpos +#define win32_fsetpos _win32_fsetpos +#define win32_rewind _win32_rewind +#define win32_tmpfile _win32_tmpfile +#define win32_abort _win32_abort +#define win32_fstat _win32_fstat +#define win32_stat _win32_stat +#define win32_pipe _win32_pipe +#define win32_popen _win32_popen +#define win32_pclose _win32_pclose +#define win32_setmode _win32_setmode +#define win32_lseek _win32_lseek +#define win32_tell _win32_tell +#define win32_dup _win32_dup +#define win32_dup2 _win32_dup2 +#define win32_open _win32_open +#define win32_close _win32_close +#define win32_eof _win32_eof +#define win32_read _win32_read +#define win32_write _win32_write +#define win32_mkdir _win32_mkdir +#define win32_rmdir _win32_rmdir +#define win32_chdir _win32_chdir +#define win32_setbuf _win32_setbuf +#define win32_setvbuf _win32_setvbuf +#define win32_fgetc _win32_fgetc +#define win32_putc _win32_putc +#define win32_puts _win32_puts +#define win32_getchar _win32_getchar +#define win32_putchar _win32_putchar +#define win32_malloc _win32_malloc +#define win32_calloc _win32_calloc +#define win32_realloc _win32_realloc +#define win32_free _win32_free +#define win32_sleep _win32_sleep +#define win32_spawnvp _win32_spawnvp +#define win32_times _win32_times +#define win32_stat _win32_stat +#define win32_ioctl _win32_ioctl +#define win32_utime _win32_utime +#define win32_getenv _win32_getenv +#define win32_open_osfhandle _win32_open_osfhandle +#define win32_get_osfhandle _win32_get_osfhandle + +int * _win32_errno(void); +FILE* _win32_stdin(void); +FILE* _win32_stdout(void); +FILE* _win32_stderr(void); +int _win32_ferror(FILE *fp); +int _win32_feof(FILE *fp); +char* _win32_strerror(int e); +void _win32_perror(const char *str); +int _win32_fprintf(FILE *pf, const char *format, ...); +int _win32_printf(const char *format, ...); +int _win32_vfprintf(FILE *pf, const char *format, va_list arg); +int _win32_vprintf(const char *format, va_list arg); +size_t _win32_fread(void *buf, size_t size, size_t count, FILE *pf); +size_t _win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf); +FILE* _win32_fopen(const char *path, const char *mode); +FILE* _win32_fdopen(int fh, const char *mode); +FILE* _win32_freopen(const char *path, const char *mode, FILE *pf); +int _win32_fclose(FILE *pf); +int _win32_fputs(const char *s,FILE *pf); +int _win32_fputc(int c,FILE *pf); +int _win32_ungetc(int c,FILE *pf); +int _win32_getc(FILE *pf); +int _win32_fileno(FILE *pf); +void _win32_clearerr(FILE *pf); +int _win32_fflush(FILE *pf); +long _win32_ftell(FILE *pf); +int _win32_fseek(FILE *pf,long offset,int origin); +int _win32_fgetpos(FILE *pf,fpos_t *p); +int _win32_fsetpos(FILE *pf,const fpos_t *p); +void _win32_rewind(FILE *pf); +FILE* _win32_tmpfile(void); +void _win32_abort(void); +int _win32_fstat(int fd,struct stat *sbufptr); +int _win32_stat(const char *name,struct stat *sbufptr); +int _win32_pipe( int *phandles, unsigned int psize, int textmode ); +FILE* _win32_popen( const char *command, const char *mode ); +int _win32_pclose( FILE *pf); +int _win32_setmode( int fd, int mode); +long _win32_lseek( int fd, long offset, int origin); +long _win32_tell( int fd); +int _win32_dup( int fd); +int _win32_dup2(int h1, int h2); +int _win32_open(const char *path, int oflag,...); +int _win32_close(int fd); +int _win32_eof(int fd); +int _win32_read(int fd, void *buf, unsigned int cnt); +int _win32_write(int fd, const void *buf, unsigned int cnt); +int _win32_mkdir(const char *dir, int mode); +int _win32_rmdir(const char *dir); +int _win32_chdir(const char *dir); +void _win32_setbuf(FILE *pf, char *buf); +int _win32_setvbuf(FILE *pf, char *buf, int type, size_t size); +char* _win32_fgets(char *s, int n, FILE *pf); +char* _win32_gets(char *s); +int _win32_fgetc(FILE *pf); +int _win32_putc(int c, FILE *pf); +int _win32_puts(const char *s); +int _win32_getchar(void); +int _win32_putchar(int c); +void* _win32_malloc(size_t size); +void* _win32_calloc(size_t numitems, size_t size); +void* _win32_realloc(void *block, size_t size); +void _win32_free(void *block); +unsigned _win32_sleep(unsigned int); +int _win32_spawnvp(int mode, const char *cmdname, const char *const *argv); +int _win32_times(struct tms *timebuf); +int _win32_stat(const char *path, struct stat *buf); +int _win32_ioctl(int i, unsigned int u, char *data); +int _win32_utime(const char *f, struct utimbuf *t); +char* _win32_getenv(const char *name); +int _win32_open_osfhandle(long handle, int flags); +long _win32_get_osfhandle(int fd); + +#pragma warning(once : 4113) +EOCODE + + +close HDRFILE; +close OUTFILE; diff --git a/win32/Makefile b/win32/Makefile index f8095d8f76..29e92d15ec 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -141,7 +141,7 @@ LINK_DBG = -debug -pdb:none ! IF "$(CCTYPE)" == "MSVC20" OPTIMIZE = -Od $(RUNTIME) -DNDEBUG ! ELSE -OPTIMIZE = -Od $(RUNTIME) -DNDEBUG +OPTIMIZE = -O2 $(RUNTIME) -DNDEBUG ! ENDIF LINK_DBG = -release !ENDIF @@ -200,9 +200,11 @@ EXTUTILSDIR = $(LIBDIR)\extutils !IF "$(OBJECT)" == "-DPERL_OBJECT" PERLIMPLIB = ..\perlcore.lib PERLDLL = ..\perlcore.dll +CAPILIB = $(COREDIR)\PerlCAPI.lib !ELSE PERLIMPLIB = ..\perl.lib PERLDLL = ..\perl.dll +CAPILIB = !ENDIF MINIPERL = ..\miniperl.exe @@ -430,7 +432,7 @@ CFG_VARS = \ # Top targets # -all : $(GLOBEXE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) $(PERL95EXE) $(X2P) \ +all : $(GLOBEXE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) $(PERL95EXE) $(CAPILIB) $(X2P) \ $(EXTENSION_DLL) $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c @@ -575,6 +577,18 @@ $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM) $(XSUBPP) dl_win32.xs > $(*B).c cd ..\..\win32 +!IF "$(OBJECT)" == "-DPERL_OBJECT" +PerlCAPI.cpp : $(MINIPERL) + $(MINIPERL) GenCAPI.pl $(COREDIR) + +PerlCAPI$(o) : PerlCAPI.cpp + $(CC) $(CFLAGS_O) -MT -UPERLDLL -DWIN95FIX -c \ + $(OBJOUT_FLAG)PerlCAPI$(o) PerlCAPI.cpp + +$(CAPILIB) : PerlCAPI.cpp PerlCAPI$(o) + lib /OUT:$(CAPILIB) PerlCAPI$(o) +!ENDIF + $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs @@ -647,7 +661,7 @@ utils: $(PERLEXE) $(PERLEXE) -I..\lib $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ bin\pl2bat.pl bin\perlglob.pl -distclean: clean +realclean: clean -del /f $(MINIPERL) $(PERLEXE) $(PERL95EXE) $(PERLDLL) $(GLOBEXE) \ $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD) -del /f *.def *.map @@ -655,13 +669,22 @@ distclean: clean -del /f $(EXTENSION_C) -del /f $(PODDIR)\*.html -del /f $(PODDIR)\*.bat + -del /f ..\utils\h2ph ..\utils\splain ..\utils\perlbug ..\utils\pl2pm ..\utils\c2ph + -del /f ..\utils\h2xs ..\utils\perldoc ..\utils\pstruct ..\utils\*.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new - -del /f ..\lib\Config.pm + -del /f $(CONFIGPM) -del /f perl95.c -del /f bin\*.bat cd $(EXTDIR) -del /s *.lib *.def *.map *.bs Makefile *$(o) pm_to_blib cd ..\win32 + -del /f $(EXTDIR)\DynaLoader\dl_win32.xs + -del /f $(EXTDIR)\DynaLoader\DynaLoader.c + -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\Dynaloader.pm $(LIBDIR)\FCntl.pm + -del /f $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm + -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm + -del /f ..\x2p\find2perl ..\x2p\s2p + -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -rmdir /s /q $(AUTODIR) || rmdir /s $(AUTODIR) -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR) -rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR) @@ -711,10 +734,12 @@ clean : -@erase perlmain$(o) -@erase config.w32 -@erase /f config.h + -@erase PerlCAPI.cpp -@erase $(GLOBEXE) -@erase $(PERLEXE) -@erase $(PERLDLL) -@erase $(CORE_OBJ) + -@erase $(CAPILIB) -rmdir /s /q "$(MINIDIR)" -@erase $(WIN32_OBJ) -@erase $(DLL_OBJ) diff --git a/win32/dl_win32.xs b/win32/dl_win32.xs index 2f330b4e1e..b9d4c14bd3 100644 --- a/win32/dl_win32.xs +++ b/win32/dl_win32.xs @@ -133,7 +133,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") CODE: DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CPERLarg_ CV*))symref, filename))); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CV* _CPERLarg))symref, filename))); char * diff --git a/win32/runperl.c b/win32/runperl.c index 755b386358..cfa195d044 100644 --- a/win32/runperl.c +++ b/win32/runperl.c @@ -23,13 +23,6 @@ CPerlObj *pPerl; #include <ipproc.h> #include <ipstdio.h> -class IPerlStdIOWin : public IPerlStdIO -{ -public: - virtual int OpenOSfhandle(long osfhandle, int flags) = 0; - virtual int GetOSfhandle(int filenum) = 0; -}; - extern int g_closedir(DIR *dirp); extern DIR *g_opendir(char *filename); extern struct direct *g_readdir(DIR *dirp); @@ -668,7 +661,7 @@ public: }; -class CPerlStdIO : public IPerlStdIOWin +class CPerlStdIO : public IPerlStdIO { public: CPerlStdIO() {}; @@ -1001,7 +994,7 @@ char *staticlinkmodules[] = { NULL, }; -EXTERN_C void boot_DynaLoader _((CPERLarg_ CV* cv)); +EXTERN_C void boot_DynaLoader _((CV* cv _CPERLarg)); static void xs_init(CPERLarg) diff --git a/win32/win32.c b/win32/win32.c index 7208e6bd08..674b047446 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -349,6 +349,7 @@ win32_get_sitelib(char *pl) char szPathStr[MAX_PATH]; char *lpPath1; char *lpPath2; + int len, newSize; /* $HKCU{"sitelib-$]"} || $HKLM{"sitelib-$]"} . ---; */ sprintf(szRegStr, "%s-%s", szSiteLib, pl); @@ -363,8 +364,8 @@ win32_get_sitelib(char *pl) if (lpPath2 == NULL) return lpPath1; - int len = strlen(lpPath1); - int newSize = len + strlen(lpPath2) + 2; /* plus one for ';' */ + len = strlen(lpPath1); + newSize = len + strlen(lpPath2) + 2; /* plus one for ';' */ lpPath1 = Renew(lpPath1, newSize, char); if (lpPath1 != NULL) @@ -2908,13 +2909,14 @@ XS(w32_RegSetValue) unsigned int size; char *buffer; + DWORD type; if (items != 4) { croak("usage: Win32::RegSetValue($hkey, $subKey, $type, $data);\n"); } - DWORD type = SvIV(ST(2)); + type = SvIV(ST(2)); if (type != REG_SZ && type != REG_EXPAND_SZ) { croak("Win32::RegSetValue: Type was not REG_SZ or REG_EXPAND_SZ, cannot set %s\n", (char *)SvPV(ST(1), na)); |