rpm 5.3.7
|
00001 #include "system.h" 00002 00003 #include <argv.h> 00004 00005 #undef _ /* XXX everyone gotta be different */ 00006 #define _RPMPERL_INTERNAL 00007 #include "rpmperl.h" 00008 00009 #if defined(WITH_PERLEMBED) 00010 #include <EXTERN.h> 00011 #include <perl.h> 00012 #endif 00013 00014 #include "debug.h" 00015 00016 /*@unchecked@*/ 00017 int _rpmperl_debug = 0; 00018 00019 /*@unchecked@*/ /*@relnull@*/ 00020 rpmperl _rpmperlI = NULL; 00021 00022 #define my_perl ((PerlInterpreter *)perl->I) 00023 00024 static void rpmperlFini(void * _perl) 00025 /*@globals fileSystem @*/ 00026 /*@modifies *_perl, fileSystem @*/ 00027 { 00028 rpmperl perl = _perl; 00029 00030 #if defined(WITH_PERLEMBED) 00031 PERL_SET_CONTEXT(my_perl); 00032 PL_perl_destruct_level = 1; 00033 perl_destruct(my_perl); 00034 perl_free(my_perl); 00035 if (perl == _rpmperlI) /* XXX necessary on HP-UX? */ 00036 PERL_SYS_TERM(); 00037 #endif 00038 perl->I = NULL; 00039 } 00040 00041 /*@unchecked@*/ /*@only@*/ /*@null@*/ 00042 rpmioPool _rpmperlPool; 00043 00044 static rpmperl rpmperlGetPool(/*@null@*/ rpmioPool pool) 00045 /*@globals _rpmperlPool, fileSystem @*/ 00046 /*@modifies pool, _rpmperlPool, fileSystem @*/ 00047 { 00048 rpmperl perl; 00049 00050 if (_rpmperlPool == NULL) { 00051 _rpmperlPool = rpmioNewPool("perl", sizeof(*perl), -1, _rpmperl_debug, 00052 NULL, NULL, rpmperlFini); 00053 pool = _rpmperlPool; 00054 } 00055 return (rpmperl) rpmioGetPool(pool, sizeof(*perl)); 00056 } 00057 00058 #if defined(WITH_PERLEMBED) 00059 EXTERN_C void xs_init (PerlInterpreter * _my_perl PERL_UNUSED_DECL); 00060 00061 EXTERN_C void boot_DynaLoader (PerlInterpreter* _my_perl, CV* cv); 00062 00063 EXTERN_C void 00064 xs_init(PerlInterpreter* _my_perl PERL_UNUSED_DECL) 00065 { 00066 char *file = __FILE__; 00067 dXSUB_SYS; 00068 00069 /* DynaLoader is a special case */ 00070 Perl_newXS(_my_perl, "DynaLoader::boot_DynaLoader", boot_DynaLoader, file); 00071 } 00072 00073 /*@unchecked@*/ 00074 static const char * rpmperlInitStringIO = "\ 00075 use strict;\n\ 00076 use IO::String;\n\ 00077 our $io = IO::String->new;\n\ 00078 select $io;\n\ 00079 "; 00080 #endif 00081 00082 static rpmperl rpmperlI(void) 00083 /*@globals _rpmperlI @*/ 00084 /*@modifies _rpmperlI @*/ 00085 { 00086 if (_rpmperlI == NULL) 00087 _rpmperlI = rpmperlNew(NULL, 0); 00088 return _rpmperlI; 00089 } 00090 00091 rpmperl rpmperlNew(char ** av, uint32_t flags) 00092 { 00093 rpmperl perl = 00094 #ifdef NOTYET 00095 (flags & 0x80000000) ? rpmperlI() : 00096 #endif 00097 rpmperlGetPool(_rpmperlPool); 00098 #if defined(WITH_PERLEMBED) 00099 static char * _av[] = { "rpmperl", NULL }; 00100 static int initialized = 0; 00101 ARGV_t argv = NULL; 00102 int argc = 0; 00103 int xx; 00104 00105 if (av == NULL) av = _av; 00106 00107 /* Build argv(argc) for the interpreter. */ 00108 xx = argvAdd(&argv, av[0]); 00109 xx = argvAdd(&argv, "-e"); 00110 xx = argvAdd(&argv, rpmperlInitStringIO); 00111 if (av[1]) 00112 xx = argvAppend(&argv, (ARGV_t)av+1); 00113 argc = argvCount(argv); 00114 00115 if (!initialized) { 00116 /* XXX claimed necessary on HP-UX */ 00117 PERL_SYS_INIT3(&argc, (char ***)&argv, &environ); 00118 initialized++; 00119 } 00120 perl->I = perl_alloc(); 00121 PERL_SET_CONTEXT(my_perl); 00122 PL_perl_destruct_level = 1; 00123 perl_construct(my_perl); 00124 00125 PL_origalen = 1; /* don't let $0 assignment update proctitle/embedding[0] */ 00126 xx = perl_parse(my_perl, xs_init, argc, (char **)argv, NULL); 00127 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 00128 perl_run(my_perl); 00129 00130 argv = argvFree(argv); 00131 #endif 00132 00133 return rpmperlLink(perl); 00134 } 00135 00136 rpmRC rpmperlRun(rpmperl perl, const char * str, const char ** resultp) 00137 { 00138 rpmRC rc = RPMRC_FAIL; 00139 00140 if (_rpmperl_debug) 00141 fprintf(stderr, "==> %s(%p,%s)\n", __FUNCTION__, perl, str); 00142 00143 if (perl == NULL) perl = rpmperlI(); 00144 00145 if (str != NULL) { 00146 #if defined(WITH_PERLEMBED) 00147 STRLEN n_a; 00148 SV * retSV; 00149 00150 retSV = Perl_eval_pv(my_perl, str, TRUE); 00151 if (SvTRUE(ERRSV)) { 00152 fprintf(stderr, "==> FIXME #1: %d %s\n", 00153 (int)SvTRUE(ERRSV), SvPV(ERRSV, n_a)); 00154 } else { 00155 if (resultp) { 00156 retSV = Perl_eval_pv(my_perl, "${$io->string_ref}", TRUE); 00157 if (SvTRUE(ERRSV)) { 00158 fprintf(stderr, "==> FIXME #2: %d %s\n", 00159 (int)SvTRUE(ERRSV), SvPV(ERRSV, n_a)); 00160 } else { 00161 *resultp = SvPV(retSV, n_a); 00162 rc = RPMRC_OK; 00163 } 00164 } else 00165 rc = RPMRC_OK; 00166 } 00167 #endif 00168 } 00169 return rc; 00170 }