Change 29968 by [EMAIL PROTECTED] on 2007/01/25 10:55:13
Integrate:
[ 28063]
Fix bug in DynaLoader, which has been passing a filename in dynamic
storage to newXS() seemingly forever. This involves creating
newXS_flags(), with the first flag being "arrange to copy the
filename and free it at the right time".
[ 28064]
Change 28063 forgot 1 key line - acutally use the correct filename
storage.
[ 28066]
*static* pointers to newXSUB(), dammit!
[ 29107]
Plug a memory leak in newCONSTSUB
Affected files ...
... //depot/maint-5.8/perl/XSUB.h#35 integrate
... //depot/maint-5.8/perl/cv.h#14 integrate
... //depot/maint-5.8/perl/embed.fnc#187 integrate
... //depot/maint-5.8/perl/embed.h#140 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_aix.xs#3 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_beos.xs#2 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_dld.xs#2 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_dllload.xs#2 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_dlopen.xs#4 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_dyld.xs#6 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_hpux.xs#3 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_mac.xs#2 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_mpeix.xs#3 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_next.xs#3 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_symbian.xs#1 branch
... //depot/maint-5.8/perl/ext/DynaLoader/dl_vmesa.xs#2 integrate
... //depot/maint-5.8/perl/ext/DynaLoader/dl_vms.xs#3 integrate
... //depot/maint-5.8/perl/op.c#177 integrate
... //depot/maint-5.8/perl/pod/perlapi.pod#90 integrate
... //depot/maint-5.8/perl/proto.h#176 integrate
... //depot/maint-5.8/perl/writemain.SH#4 integrate
... //depot/maint-5.8/perl/xsutils.c#24 integrate
Differences ...
==== //depot/maint-5.8/perl/XSUB.h#35 (text) ====
Index: perl/XSUB.h
--- perl/XSUB.h#34~29920~ 2007-01-22 11:20:43.000000000 -0800
+++ perl/XSUB.h 2007-01-25 02:55:13.000000000 -0800
@@ -266,7 +266,7 @@
#define XSRETURN_UNDEF STMT_START { XST_mUNDEF(0); XSRETURN(1); } STMT_END
#define XSRETURN_EMPTY STMT_START { XSRETURN(0); } STMT_END
-#define newXSproto(a,b,c,d) sv_setpv((SV*)newXS(a,b,c), d)
+#define newXSproto(a,b,c,d) newXS_flags(a,b,c,d,0)
#ifdef XS_VERSION
# define XS_VERSION_BOOTCHECK \
==== //depot/maint-5.8/perl/cv.h#14 (text) ====
Index: perl/cv.h
--- perl/cv.h#13~29898~ 2007-01-20 10:43:49.000000000 -0800
+++ perl/cv.h 2007-01-25 02:55:13.000000000 -0800
@@ -154,6 +154,9 @@
#define CvWEAKOUTSIDE_off(cv) (CvFLAGS(cv) &= ~CVf_WEAKOUTSIDE)
#define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
+/* Flags for newXS_flags */
+#define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */
+
/*
=head1 CV reference counts and CvOUTSIDE
==== //depot/maint-5.8/perl/embed.fnc#187 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#186~29963~ 2007-01-24 15:24:03.000000000 -0800
+++ perl/embed.fnc 2007-01-25 02:55:13.000000000 -0800
@@ -541,6 +541,9 @@
Apa |OP* |newSLICEOP |I32 flags|NULLOK OP* subscript|NULLOK OP*
listop
Apa |OP* |newSTATEOP |I32 flags|NULLOK char* label|NULLOK OP* o
Ap |CV* |newSUB |I32 floor|NULLOK OP* o|NULLOK OP* proto|NULLOK
OP* block
+ApM |CV * |newXS_flags |NULLOK const char *name|NN XSUBADDR_t subaddr\
+ |NN const char *const filename \
+ |NULLOK const char *const proto|U32 flags
Apd |CV* |newXS |NULLOK char* name|NN XSUBADDR_t f|NN char*
filename
Apda |AV* |newAV
Apa |OP* |newAVREF |NN OP* o
==== //depot/maint-5.8/perl/embed.h#140 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#139~29963~ 2007-01-24 15:24:03.000000000 -0800
+++ perl/embed.h 2007-01-25 02:55:13.000000000 -0800
@@ -560,6 +560,7 @@
#define newSLICEOP Perl_newSLICEOP
#define newSTATEOP Perl_newSTATEOP
#define newSUB Perl_newSUB
+#define newXS_flags Perl_newXS_flags
#define newXS Perl_newXS
#define newAV Perl_newAV
#define newAVREF Perl_newAVREF
@@ -2644,6 +2645,7 @@
#define newSLICEOP(a,b,c) Perl_newSLICEOP(aTHX_ a,b,c)
#define newSTATEOP(a,b,c) Perl_newSTATEOP(aTHX_ a,b,c)
#define newSUB(a,b,c,d) Perl_newSUB(aTHX_ a,b,c,d)
+#define newXS_flags(a,b,c,d,e) Perl_newXS_flags(aTHX_ a,b,c,d,e)
#define newXS(a,b,c) Perl_newXS(aTHX_ a,b,c)
#define newAV() Perl_newAV(aTHX)
#define newAVREF(a) Perl_newAVREF(aTHX_ a)
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_aix.xs#3 (text) ====
Index: perl/ext/DynaLoader/dl_aix.xs
--- perl/ext/DynaLoader/dl_aix.xs#2~25572~ 2005-09-22 09:46:28.000000000
-0700
+++ perl/ext/DynaLoader/dl_aix.xs 2007-01-25 02:55:13.000000000 -0800
@@ -778,9 +778,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_beos.xs#2 (text) ====
Index: perl/ext/DynaLoader/dl_beos.xs
--- perl/ext/DynaLoader/dl_beos.xs#1~17645~ 2002-07-19 12:29:57.000000000
-0700
+++ perl/ext/DynaLoader/dl_beos.xs 2007-01-25 02:55:13.000000000 -0800
@@ -102,9 +102,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%lx)\n",
perl_name, (unsigned long) symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_dld.xs#2 (text) ====
Index: perl/ext/DynaLoader/dl_dld.xs
--- perl/ext/DynaLoader/dl_dld.xs#1~17645~ 2002-07-19 12:29:57.000000000
-0700
+++ perl/ext/DynaLoader/dl_dld.xs 2007-01-25 02:55:13.000000000 -0800
@@ -173,10 +173,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
-
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
dl_error()
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_dllload.xs#2 (text) ====
Index: perl/ext/DynaLoader/dl_dllload.xs
--- perl/ext/DynaLoader/dl_dllload.xs#1~17645~ 2002-07-19 12:29:57.000000000
-0700
+++ perl/ext/DynaLoader/dl_dllload.xs 2007-01-25 02:55:13.000000000 -0800
@@ -174,9 +174,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%lx)\n",
perl_name, (unsigned long) symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_dlopen.xs#4 (text) ====
Index: perl/ext/DynaLoader/dl_dlopen.xs
--- perl/ext/DynaLoader/dl_dlopen.xs#3~25498~ 2005-09-19 12:14:14.000000000
-0700
+++ perl/ext/DynaLoader/dl_dlopen.xs 2007-01-25 02:55:13.000000000 -0800
@@ -250,9 +250,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%"UVxf")\n",
perl_name, PTR2UV(symref)));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- DPTR2FPTR(XSUBADDR_t, symref),
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ DPTR2FPTR(XSUBADDR_t, symref),
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_dyld.xs#6 (text) ====
Index: perl/ext/DynaLoader/dl_dyld.xs
--- perl/ext/DynaLoader/dl_dyld.xs#5~25390~ 2005-09-12 09:18:42.000000000
-0700
+++ perl/ext/DynaLoader/dl_dyld.xs 2007-01-25 02:55:13.000000000 -0800
@@ -205,9 +205,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_hpux.xs#3 (text) ====
Index: perl/ext/DynaLoader/dl_hpux.xs
--- perl/ext/DynaLoader/dl_hpux.xs#2~22230~ 2004-01-27 12:08:23.000000000
-0800
+++ perl/ext/DynaLoader/dl_hpux.xs 2007-01-25 02:55:13.000000000 -0800
@@ -164,10 +164,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
-
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
dl_error()
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_mac.xs#2 (text) ====
Index: perl/ext/DynaLoader/dl_mac.xs
--- perl/ext/DynaLoader/dl_mac.xs#1~17645~ 2002-07-19 12:29:57.000000000
-0700
+++ perl/ext/DynaLoader/dl_mac.xs 2007-01-25 02:55:13.000000000 -0800
@@ -130,7 +130,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref,
filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_mpeix.xs#3 (text) ====
Index: perl/ext/DynaLoader/dl_mpeix.xs
--- perl/ext/DynaLoader/dl_mpeix.xs#2~20934~ 2003-08-29 08:12:24.000000000
-0700
+++ perl/ext/DynaLoader/dl_mpeix.xs 2007-01-25 02:55:13.000000000 -0800
@@ -115,9 +115,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
dl_error()
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_next.xs#3 (text) ====
Index: perl/ext/DynaLoader/dl_next.xs
--- perl/ext/DynaLoader/dl_next.xs#2~25572~ 2005-09-22 09:46:28.000000000
-0700
+++ perl/ext/DynaLoader/dl_next.xs 2007-01-25 02:55:13.000000000 -0800
@@ -305,9 +305,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_symbian.xs#1 (text) ====
Index: perl/ext/DynaLoader/dl_symbian.xs
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/ext/DynaLoader/dl_symbian.xs 2007-01-25 02:55:13.000000000 -0800
@@ -0,0 +1,224 @@
+/* dl_symbian.xs
+ *
+ * Platform: Symbian 7.0s
+ * Author: Jarkko Hietaniemi <[EMAIL PROTECTED]>
+ * Copyright: 2004, Nokia
+ * License: Artistic/GPL
+ *
+ */
+
+/*
+ * In Symbian DLLs there is no name information, one can only access
+ * the functions by their ordinals. Perl, however, very much would like
+ * to load functions by their names. We fake this by having a special
+ * setup function at the ordinal 1 (this is arranged by building the DLLs
+ * in a special way). The setup function builds a Perl hash mapping the
+ * names to the ordinals, and the hash is then used by dlsym().
+ *
+ */
+
+#include <e32base.h>
+#include <eikdll.h>
+#include <utf.h>
+
+/* This is a useful pattern: first include the Symbian headers,
+ * only after that the Perl ones. Otherwise you will get a lot
+ * trouble because of Symbian's New(), Copy(), etc definitions. */
+
+#define DL_SYMBIAN_XS
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+START_EXTERN_C
+
+void *dlopen(const char *filename, int flag);
+void *dlsym(void *handle, const char *symbol);
+int dlclose(void *handle);
+const char *dlerror(void);
+
+extern void* memset(void *s, int c, size_t n);
+extern size_t strlen(const char *s);
+
+END_EXTERN_C
+
+#include "dlutils.c"
+
+#define RTLD_LAZY 0x0001
+#define RTLD_NOW 0x0002
+#define RTLD_GLOBAL 0x0004
+
+#ifndef NULL
+# define NULL 0
+#endif
+
+/* No need to pull in symbian_dll.cpp for this. */
+#define symbian_get_vars() ((void*)Dll::Tls())
+
+const TInt KPerlDllSetupFunction = 1;
+
+typedef struct {
+ RLibrary handle;
+ TInt error;
+ HV* symbols;
+} PerlSymbianLibHandle;
+
+typedef void (*PerlSymbianLibInit)(void *);
+
+void* dlopen(const char *filename, int flags) {
+ TBuf16<KMaxFileName> utf16fn;
+ const TUint8* utf8fn = (const TUint8*)filename;
+ PerlSymbianLibHandle* h = NULL;
+ TInt error;
+
+ error =
+ CnvUtfConverter::ConvertToUnicodeFromUtf8(utf16fn, TPtrC8(utf8fn));
+ if (error == KErrNone) {
+ h = new PerlSymbianLibHandle;
+ if (h) {
+ h->error = KErrNone;
+ h->symbols = Nullhv;
+ } else
+ error = KErrNoMemory;
+ }
+
+ if (h && error == KErrNone) {
+ error = (h->handle).Load(utf16fn);
+ if (error == KErrNone) {
+ TLibraryFunction init = (h->handle).Lookup(KPerlDllSetupFunction);
+ ((PerlSymbianLibInit)init)(h);
+ } else {
+ free(h);
+ h = NULL;
+ }
+ }
+
+ if (h)
+ h->error = error;
+
+ return h;
+}
+
+void* dlsym(void *handle, const char *symbol) {
+ if (handle) {
+ dTHX;
+ PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)handle;
+ HV* symbols = h->symbols;
+ if (symbols) {
+ SV** svp = hv_fetch(symbols, symbol, strlen(symbol), FALSE);
+ if (svp && *svp && SvIOK(*svp)) {
+ IV ord = SvIV(*svp);
+ if (ord > 0)
+ return (void*)((h->handle).Lookup(ord));
+ }
+ }
+ }
+ return NULL;
+}
+
+int dlclose(void *handle) {
+ PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)handle;
+ if (h) {
+ (h->handle).Close();
+ if (h->symbols) {
+ dTHX;
+ hv_undef(h->symbols);
+ h->symbols = NULL;
+ }
+ return 0;
+ } else
+ return 1;
+}
+
+const char* dlerror(void) {
+ return 0; /* Bad interface: assumes static data. */
+}
+
+static void
+dl_private_init(pTHX)
+{
+ (void)dl_generic_private_init(aTHX);
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+PROTOTYPES: ENABLE
+
+BOOT:
+ (void)dl_private_init(aTHX);
+
+
+void
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ PerlSymbianLibHandle* h;
+ CODE:
+{
+ ST(0) = sv_newmortal();
+ h = (PerlSymbianLibHandle*)dlopen(filename, flags);
+ if (h && h->error == KErrNone)
+ sv_setiv(ST(0), PTR2IV(h));
+ else
+ PerlIO_printf(Perl_debug_log, "(dl_load_file %s %d)",
+ filename, h ? h->error : -1);
+}
+
+
+int
+dl_unload_file(libhandle)
+ void * libhandle
+ CODE:
+ RETVAL = (dlclose(libhandle) == 0 ? 1 : 0);
+ OUTPUT:
+ RETVAL
+
+
+void
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ PREINIT:
+ void *sym;
+ CODE:
+ PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)libhandle;
+ sym = dlsym(libhandle, symbolname);
+ ST(0) = sv_newmortal();
+ if (sym)
+ sv_setiv(ST(0), PTR2IV(sym));
+ else
+ PerlIO_printf(Perl_debug_log, "(dl_find_symbol %s %d)",
+ symbolname, h ? h->error : -1);
+
+
+void
+dl_undef_symbols()
+ CODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
+
+
+char *
+dl_error()
+ CODE:
+ dMY_CXT;
+ RETVAL = dl_last_error;
+ OUTPUT:
+ RETVAL
+
+# end.
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_vmesa.xs#2 (text) ====
Index: perl/ext/DynaLoader/dl_vmesa.xs
--- perl/ext/DynaLoader/dl_vmesa.xs#1~17645~ 2002-07-19 12:29:57.000000000
-0700
+++ perl/ext/DynaLoader/dl_vmesa.xs 2007-01-25 02:55:13.000000000 -0800
@@ -160,9 +160,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%lx)\n",
perl_name, (unsigned long) symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/ext/DynaLoader/dl_vms.xs#3 (text) ====
Index: perl/ext/DynaLoader/dl_vms.xs
--- perl/ext/DynaLoader/dl_vms.xs#2~25572~ 2005-09-22 09:46:28.000000000
-0700
+++ perl/ext/DynaLoader/dl_vms.xs 2007-01-25 02:55:13.000000000 -0800
@@ -368,9 +368,10 @@
CODE:
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s,
symref=%x)\n",
perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename)));
+ ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+ (void(*)(pTHX_ CV *))symref,
+ filename, NULL,
+ XS_DYNAMIC_FILENAME)));
char *
==== //depot/maint-5.8/perl/op.c#177 (text) ====
Index: perl/op.c
--- perl/op.c#176~29964~ 2007-01-24 15:53:28.000000000 -0800
+++ perl/op.c 2007-01-25 02:55:13.000000000 -0800
@@ -4719,15 +4719,11 @@
/* file becomes the CvFILE. For an XS, it's supposed to be static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
- and we need it to get freed. So we cheat, and take advantage of the
- fact that the first 0 bytes of any string always look the same. */
- cv = newXS(name, const_sv_xsub, file);
+ and we need it to get freed. */
+ cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- /* prototype is "". But this gets free()d. :-) */
- sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL);
- /* This gives us a prototype of "", rather than the file name. */
- SvCUR_set(cv, 0);
+ Safefree(file);
#ifdef USE_ITHREADS
if (stash)
@@ -4738,10 +4734,56 @@
return cv;
}
+CV *
+Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
+ const char *const filename, const char *const proto,
+ U32 flags)
+{
+ CV *cv = newXS(name, subaddr, filename);
+
+ if (flags & XS_DYNAMIC_FILENAME) {
+ /* We need to "make arrangements" (ie cheat) to ensure that the
+ filename lasts as long as the PVCV we just created, but also doesn't
+ leak */
+ STRLEN filename_len = strlen(filename);
+ STRLEN proto_and_file_len = filename_len;
+ char *proto_and_file;
+ STRLEN proto_len;
+
+ if (proto) {
+ proto_len = strlen(proto);
+ proto_and_file_len += proto_len;
+
+ Newx(proto_and_file, proto_and_file_len + 1, char);
+ Copy(proto, proto_and_file, proto_len, char);
+ Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
+ } else {
+ proto_len = 0;
+ proto_and_file = savepvn(filename, filename_len);
+ }
+
+ /* This gets free()d. :-) */
+ sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
+ SV_HAS_TRAILING_NUL);
+ if (proto) {
+ /* This gives us the correct prototype, rather than one with the
+ file name appended. */
+ SvCUR_set(cv, proto_len);
+ } else {
+ SvPOK_off(cv);
+ }
+ CvFILE(cv) = proto_and_file + proto_len;
+ } else {
+ sv_setpv((SV *)cv, proto);
+ }
+ return cv;
+}
+
/*
=for apidoc U||newXS
-Used by C<xsubpp> to hook up XSUBs as Perl subs.
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
=cut
*/
==== //depot/maint-5.8/perl/pod/perlapi.pod#90 (text+w) ====
Index: perl/pod/perlapi.pod
--- perl/pod/perlapi.pod#89~29965~ 2007-01-24 16:07:28.000000000 -0800
+++ perl/pod/perlapi.pod 2007-01-25 02:55:13.000000000 -0800
@@ -2583,7 +2583,8 @@
=item newXS
X<newXS>
-Used by C<xsubpp> to hook up XSUBs as Perl subs.
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
=for hackers
Found in file op.c
==== //depot/maint-5.8/perl/proto.h#176 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#175~29963~ 2007-01-24 15:24:03.000000000 -0800
+++ perl/proto.h 2007-01-25 02:55:13.000000000 -0800
@@ -839,6 +839,10 @@
__attribute__warn_unused_result__;
PERL_CALLCONV CV* Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP*
block);
+PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t
subaddr, const char *const filename, const char *const proto, U32 flags)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+
PERL_CALLCONV CV* Perl_newXS(pTHX_ char* name, XSUBADDR_t f, char*
filename);
PERL_CALLCONV AV* Perl_newAV(pTHX)
__attribute__malloc__
==== //depot/maint-5.8/perl/writemain.SH#4 (text) ====
Index: perl/writemain.SH
--- perl/writemain.SH#3~25647~ 2005-09-28 14:32:24.000000000 -0700
+++ perl/writemain.SH 2007-01-25 02:55:13.000000000 -0800
@@ -77,7 +77,7 @@
EOP
if test X"$args" != "X" ; then
- echo " const char file[] = __FILE__;"
+ echo " static const char file[] = __FILE__;"
echo " dXSUB_SYS;"
ai=''
==== //depot/maint-5.8/perl/xsutils.c#24 (text) ====
Index: perl/xsutils.c
--- perl/xsutils.c#23~29859~ 2007-01-17 14:07:40.000000000 -0800
+++ perl/xsutils.c 2007-01-25 02:55:13.000000000 -0800
@@ -43,11 +43,11 @@
* version checks in these bootstrap calls are optional.
*/
+static const char file[] = __FILE__;
+
void
Perl_boot_core_xsutils(pTHX)
{
- const char file[] = __FILE__;
-
newXS("attributes::bootstrap", XS_attributes_bootstrap, (char *)file);
}
@@ -160,7 +160,6 @@
XS(XS_attributes_bootstrap)
{
dXSARGS;
- const char file[] = __FILE__;
if( items > 1 )
Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
End of Patch.
