rpm 5.3.7

rpmio/rpmperl.c

Go to the documentation of this file.
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 }