rpm  5.4.10
rpmperl.c
Go to the documentation of this file.
1 #include "system.h"
2 
3 #include <argv.h>
4 
5 #undef _ /* XXX everyone gotta be different */
6 #define _RPMPERL_INTERNAL
7 #include "rpmperl.h"
8 #include <rpmmacro.h>
9 
10 #if defined(MODULE_EMBED)
11 #include <EXTERN.h>
12 #include <perl.h>
13 #undef WITH_PERLEMBED
14 #endif
15 
16 #if defined(WITH_PERLEMBED)
17 #include <dlfcn.h>
18 #include <rpmlog.h>
19 #endif
20 
21 #undef UNLIKELY /* XXX everyone gotta be different */
22 #include "debug.h"
23 
24 /*@unchecked@*/
26 
27 /*@unchecked@*/ /*@relnull@*/
29 
30 #if defined(WITH_PERLEMBED)
31 static int dlopened = 0;
32 static rpmperl (*rpmperlNew_p) (char ** av, uint32_t flags);
33 static rpmRC (*rpmperlRun_p) (rpmperl perl, const char * str, const char ** resultp);
34 #endif
35 
36 #define my_perl ((PerlInterpreter *)perl->I)
37 
38 static void rpmperlFini(void * _perl)
39  /*@globals fileSystem @*/
40  /*@modifies *_perl, fileSystem @*/
41 {
42  rpmperl perl = (rpmperl) _perl;
43 
44 #if defined(MODULE_EMBED)
45  PERL_SET_CONTEXT(my_perl);
46  PL_perl_destruct_level = 1;
47  perl_destruct(my_perl);
48  perl_free(my_perl);
49  if (perl == _rpmperlI) /* XXX necessary on HP-UX? */
50  PERL_SYS_TERM();
51 #endif
52  perl->I = NULL;
53 }
54 
55 /*@unchecked@*/ /*@only@*/ /*@null@*/
57 
58 static rpmperl rpmperlGetPool(/*@null@*/ rpmioPool pool)
59  /*@globals _rpmperlPool, fileSystem @*/
60  /*@modifies pool, _rpmperlPool, fileSystem @*/
61 {
62  rpmperl perl;
63 
64  if (_rpmperlPool == NULL) {
65  _rpmperlPool = rpmioNewPool("perl", sizeof(*perl), -1, _rpmperl_debug,
66  NULL, NULL, rpmperlFini);
67  pool = _rpmperlPool;
68  }
69  return (rpmperl) rpmioGetPool(pool, sizeof(*perl));
70 }
71 
72 #if defined(MODULE_EMBED)
73 EXTERN_C void xs_init (PerlInterpreter * _my_perl PERL_UNUSED_DECL);
74 
75 EXTERN_C void boot_DynaLoader (PerlInterpreter* _my_perl, CV* cv);
76 
77 EXTERN_C void
78 xs_init(PerlInterpreter* _my_perl PERL_UNUSED_DECL)
79 {
80  char * file = (char *) __FILE__;
81  dXSUB_SYS;
82 
83  /* DynaLoader is a special case */
84  Perl_newXS(_my_perl, "DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
85 }
86 
87 /*@unchecked@*/
88 static const char * _rpmperlI_init = "\
89 use strict;\n\
90 use IO::String;\n\
91 our $io = IO::String->new;\n\
92 select $io;\n\
93 ";
94 #endif
95 
96 static rpmperl rpmperlI(void)
97  /*@globals _rpmperlI @*/
98  /*@modifies _rpmperlI @*/
99 {
100  if (_rpmperlI == NULL)
101  _rpmperlI = rpmperlNew(NULL, 0);
102  return _rpmperlI;
103 }
104 
105 #if defined(WITH_PERLEMBED)
106 static void loadModule(void) {
107  const char librpmperl[] = "rpmperl.so";
108  void *h;
109 
110  h = dlopen (librpmperl, RTLD_NOW|RTLD_GLOBAL);
111  if (!h)
112  {
113  rpmlog(RPMLOG_WARNING, D_("Unable to open \"%s\" (%s), "
114  "embedded perl will not be available\n"),
115  librpmperl, dlerror());
116  }
117  else if(!((rpmperlNew_p = dlsym(h, "rpmperlNew"))
118  && (rpmperlRun_p = dlsym(h, "rpmperlRun")))) {
119  rpmlog(RPMLOG_WARNING, D_("Opened library \"%s\" is incompatible (%s), "
120  "embedded perl will not be available\n"),
121  librpmperl, dlerror());
122  if (dlclose (h))
123  rpmlog(RPMLOG_WARNING, "Error closing library \"%s\": %s", librpmperl,
124  dlerror());
125  } else
126  dlopened = 1;
127 }
128 #endif
129 
130 rpmperl rpmperlNew(char ** av, uint32_t flags)
131 {
132 #if defined(WITH_PERLEMBED)
133  if (!dlopened) loadModule();
134  if (dlopened) return rpmperlNew_p(av, flags);
135 #endif
136  rpmperl perl = (flags & 0x80000000)
137  ? rpmperlI() : rpmperlGetPool(_rpmperlPool);
138 #if defined(MODULE_EMBED)
139  static const char * _av[] = { "rpmperl", NULL };
140  static int initialized = 0;
141  ARGV_t argv = NULL;
142  int argc = 0;
143  int xx;
144 
145  if (av == NULL) av = (char **) _av;
146 
147  /* Build argv(argc) for the interpreter. */
148  xx = argvAdd(&argv, av[0]);
149  { static const char _perlI_init[] = "%{?_perlI_init}";
150  const char * s = rpmExpand(_rpmperlI_init, _perlI_init, NULL);
151  if (s && *s) {
152  xx = argvAdd(&argv, "-e");
153  xx = argvAdd(&argv, s);
154  }
155  s = _free(s);
156  }
157  if (av[1])
158  xx = argvAppend(&argv, (ARGV_t)av+1);
159  argc = argvCount(argv);
160 
161  if (!initialized) {
162  /* XXX claimed necessary on HP-UX */
163  PERL_SYS_INIT3(&argc, (char ***)&argv, &environ);
164  initialized++;
165  }
166  perl->I = perl_alloc();
167  PERL_SET_CONTEXT(my_perl);
168  PL_perl_destruct_level = 1;
169  perl_construct(my_perl);
170 
171  PL_origalen = 1; /* don't let $0 assignment update proctitle/embedding[0] */
172  xx = perl_parse(my_perl, xs_init, argc, (char **)argv, NULL);
173  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
174  perl_run(my_perl);
175 
176  argv = argvFree(argv);
177 #endif
178 
179  return rpmperlLink(perl);
180 }
181 
182 rpmRC rpmperlRun(rpmperl perl, const char * str, const char ** resultp)
183 {
184 #if defined(WITH_PERLEMBED)
185  if (dlopened) return rpmperlRun_p(perl, str, resultp);
186 #endif
187  rpmRC rc = RPMRC_FAIL;
188 
189 if (_rpmperl_debug)
190 fprintf(stderr, "==> %s(%p,%s)\n", __FUNCTION__, perl, str);
191 
192  if (perl == NULL) perl = rpmperlI();
193 
194  if (str != NULL) {
195 #if defined(MODULE_EMBED)
196  STRLEN n_a;
197  SV * retSV;
198 
199  retSV = Perl_eval_pv(my_perl, str, TRUE);
200  if (SvTRUE(ERRSV)) {
201  fprintf(stderr, "==> FIXME #1: %d %s\n",
202  (int)SvTRUE(ERRSV), SvPV(ERRSV, n_a));
203  } else {
204  if (resultp) {
205  retSV = Perl_eval_pv(my_perl, "${$io->string_ref}", TRUE);
206  if (SvTRUE(ERRSV)) {
207  fprintf(stderr, "==> FIXME #2: %d %s\n",
208  (int)SvTRUE(ERRSV), SvPV(ERRSV, n_a));
209  } else {
210  *resultp = SvPV(retSV, n_a);
211  rc = RPMRC_OK;
212  }
213  } else
214  rc = RPMRC_OK;
215  }
216 #endif
217  }
218  return rc;
219 }