1#!./perl -w
2package ExtUtils::Miniperl;
3use strict;
4require Exporter;
5use ExtUtils::Embed 1.31, qw(xsi_header xsi_protos xsi_body);
6
7use vars qw($VERSION @ISA @EXPORT);
8
9@ISA = qw(Exporter);
10@EXPORT = qw(writemain);
11$VERSION = '1.05';
12
13# blead will run this with miniperl, hence we can't use autodie or File::Temp
14my $temp;
15
16END {
17    return if !defined $temp || !-e $temp;
18    unlink $temp or warn "Can't unlink '$temp': $!";
19}
20
21sub writemain{
22    my ($fh, $real);
23
24    if (ref $_[0] eq 'SCALAR') {
25        $real = ${+shift};
26        $temp = $real;
27        $temp =~ s/(?:.c)?\z/.new/;
28        open $fh, '>', $temp
29            or die "Can't open '$temp' for writing: $!";
30    } elsif (ref $_[0]) {
31        $fh = shift;
32    } else {
33        $fh = \*STDOUT;
34    }
35
36    my(@exts) = @_;
37
38    printf $fh <<'EOF!HEAD', xsi_header();
39/*    miniperlmain.c
40 *
41 *    Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
42 *    2004, 2005, 2006, 2007, by Larry Wall and others
43 *
44 *    You may distribute under the terms of either the GNU General Public
45 *    License or the Artistic License, as specified in the README file.
46 *
47 */
48
49/*
50 *      The Road goes ever on and on
51 *          Down from the door where it began.
52 *
53 *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
54 *     [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
55 */
56
57/* This file contains the main() function for the perl interpreter.
58 * Note that miniperlmain.c contains main() for the 'miniperl' binary,
59 * while perlmain.c contains main() for the 'perl' binary.
60 *
61 * Miniperl is like perl except that it does not support dynamic loading,
62 * and in fact is used to build the dynamic modules needed for the 'real'
63 * perl executable.
64 */
65
66#ifdef OEMVS
67#ifdef MYMALLOC
68/* sbrk is limited to first heap segment so make it big */
69#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
70#else
71#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
72#endif
73#endif
74
75#define PERL_IN_MINIPERLMAIN_C
76%s
77static void xs_init (pTHX);
78static PerlInterpreter *my_perl;
79
80#if defined(PERL_GLOBAL_STRUCT_PRIVATE)
81/* The static struct perl_vars* may seem counterproductive since the
82 * whole idea PERL_GLOBAL_STRUCT_PRIVATE was to avoid statics, but note
83 * that this static is not in the shared perl library, the globals PL_Vars
84 * and PL_VarsPtr will stay away. */
85static struct perl_vars* my_plvarsp;
86struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; }
87#endif
88
89#ifdef NO_ENV_ARRAY_IN_MAIN
90extern char **environ;
91int
92main(int argc, char **argv)
93#else
94int
95main(int argc, char **argv, char **env)
96#endif
97{
98    int exitstatus, i;
99#ifdef PERL_GLOBAL_STRUCT
100    struct perl_vars *my_vars = init_global_struct();
101#  ifdef PERL_GLOBAL_STRUCT_PRIVATE
102    int veto;
103
104    my_plvarsp = my_vars;
105#  endif
106#endif /* PERL_GLOBAL_STRUCT */
107#ifndef NO_ENV_ARRAY_IN_MAIN
108    PERL_UNUSED_ARG(env);
109#endif
110#ifndef PERL_USE_SAFE_PUTENV
111    PL_use_safe_putenv = FALSE;
112#endif /* PERL_USE_SAFE_PUTENV */
113
114    /* if user wants control of gprof profiling off by default */
115    /* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
116    PERL_GPROF_MONCONTROL(0);
117
118#ifdef NO_ENV_ARRAY_IN_MAIN
119    PERL_SYS_INIT3(&argc,&argv,&environ);
120#else
121    PERL_SYS_INIT3(&argc,&argv,&env);
122#endif
123
124#if defined(USE_ITHREADS)
125    /* XXX Ideally, this should really be happening in perl_alloc() or
126     * perl_construct() to keep libperl.a transparently fork()-safe.
127     * It is currently done here only because Apache/mod_perl have
128     * problems due to lack of a call to cancel pthread_atfork()
129     * handlers when shared objects that contain the handlers may
130     * be dlclose()d.  This forces applications that embed perl to
131     * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
132     * been called at least once before in the current process.
133     * --GSAR 2001-07-20 */
134    PTHREAD_ATFORK(Perl_atfork_lock,
135                   Perl_atfork_unlock,
136                   Perl_atfork_unlock);
137#endif
138
139    PERL_SYS_FPU_INIT;
140
141    if (!PL_do_undump) {
142	my_perl = perl_alloc();
143	if (!my_perl)
144	    exit(1);
145	perl_construct(my_perl);
146	PL_perl_destruct_level = 0;
147    }
148    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
149    exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
150    if (!exitstatus)
151        perl_run(my_perl);
152
153#ifndef PERL_MICRO
154    /* Unregister our signal handler before destroying my_perl */
155    for (i = 1; PL_sig_name[i]; i++) {
156	if (rsignal_state(PL_sig_num[i]) == (Sighandler_t) PL_csighandlerp) {
157	    rsignal(PL_sig_num[i], (Sighandler_t) SIG_DFL);
158	}
159    }
160#endif
161
162    exitstatus = perl_destruct(my_perl);
163
164    perl_free(my_perl);
165
166#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN)
167    /*
168     * The old environment may have been freed by perl_free()
169     * when PERL_TRACK_MEMPOOL is defined, but without having
170     * been restored by perl_destruct() before (this is only
171     * done if destruct_level > 0).
172     *
173     * It is important to have a valid environment for atexit()
174     * routines that are eventually called.
175     */
176    environ = env;
177#endif
178
179    PERL_SYS_TERM();
180
181#ifdef PERL_GLOBAL_STRUCT
182#  ifdef PERL_GLOBAL_STRUCT_PRIVATE
183    veto = my_plvarsp->Gveto_cleanup;
184#  endif
185    free_global_struct(my_vars);
186#  ifdef PERL_GLOBAL_STRUCT_PRIVATE
187    if (!veto)
188        my_plvarsp = NULL;
189    /* Remember, functions registered with atexit() can run after this point,
190       and may access "global" variables, and hence end up calling
191       Perl_GetVarsPrivate()  */
192#endif
193#endif /* PERL_GLOBAL_STRUCT */
194
195    exit(exitstatus);
196}
197
198/* Register any extra external extensions */
199
200EOF!HEAD
201
202    print $fh xsi_protos(@exts), <<'EOT', xsi_body(@exts), "}\n";
203
204static void
205xs_init(pTHX)
206{
207EOT
208
209    if ($real) {
210        close $fh or die "Can't close '$temp': $!";
211        rename $temp, $real or die "Can't rename '$temp' to '$real': $!";
212    }
213}
214
2151;
216__END__
217
218=head1 NAME
219
220ExtUtils::Miniperl - write the C code for perlmain.c
221
222=head1 SYNOPSIS
223
224    use ExtUtils::Miniperl;
225    writemain(@directories);
226    # or
227    writemain($fh, @directories);
228    # or
229    writemain(\$filename, @directories);
230
231=head1 DESCRIPTION
232
233C<writemain()> takes an argument list of directories containing archive
234libraries that relate to perl modules and should be linked into a new
235perl binary. It writes a corresponding F<perlmain.c> file that
236is a plain C file containing all the bootstrap code to make the
237modules associated with the libraries available from within perl.
238If the first argument to C<writemain()> is a reference to a scalar it is
239used as the filename to open for output. Any other reference is used as
240the filehandle to write to. Otherwise output defaults to C<STDOUT>.
241
242The typical usage is from within a Makefile generated by
243L<ExtUtils::MakeMaker>. So under normal circumstances you won't have to
244deal with this module directly.
245
246=head1 SEE ALSO
247
248L<ExtUtils::MakeMaker>
249
250=cut
251
252# ex: set ts=8 sts=4 sw=4 et:
253