File Coverage

blib/lib/HiPi/Utils/Exec.pm
Criterion Covered Total %
statement 30 105 28.5
branch 0 18 0.0
condition 0 9 0.0
subroutine 10 19 52.6
pod 0 7 0.0
total 40 158 25.3


line stmt bran cond sub pod time code
1             #########################################################################################
2             # Package HiPi::Utils::Exec
3             # Description : Executable Wrappers
4             # Copyright : Copyright (c) 2013-2017 Mark Dootson
5             # License : This is free software; you can redistribute it and/or modify it under
6             # the same terms as the Perl 5 programming language system itself.
7             #########################################################################################
8              
9             package HiPi::Utils::Exec;
10              
11             #########################################################################################
12              
13 1     1   2135 use strict;
  1         6  
  1         30  
14 1     1   5 use warnings;
  1         3  
  1         28  
15 1     1   5 use parent qw( HiPi::Class );
  1         2  
  1         5  
16 1     1   56 use XSLoader;
  1         2  
  1         7  
17 1     1   20 use Config;
  1         2  
  1         58  
18 1     1   15 use Carp;
  1         4  
  1         73  
19 1     1   625 use File::Slurp;
  1         16755  
  1         71  
20 1     1   8 use Cwd;
  1         2  
  1         71  
21 1     1   7 use Try::Tiny;
  1         2  
  1         55  
22 1     1   6 use HiPi;
  1         2  
  1         1321  
23              
24             __PACKAGE__->create_accessors( qw( workingdir sourceperl outputexec ) );
25              
26             our $VERSION ='0.81';
27              
28             XSLoader::load('HiPi::Utils::Exec', $VERSION) if HiPi::is_raspberry_pi();
29              
30             sub new {
31 0     0 0   my ($class, %params) = @_;
32 0 0 0       unless(defined($params{workingdir} && -d $params{workingdir})) {
33 0           croak('you must provide a working directory');
34             }
35 0 0 0       unless(defined($params{sourceperl} && -f $params{sourceperl})) {
36 0           croak('you must provide a source perl script');
37             }
38 0 0 0       unless(defined($params{outputexec} && $params{outputexec})) {
39 0           croak('you must provide an output executable');
40             }
41 0           my $self = $class->SUPER::new(%params);
42 0           return $self;
43             }
44              
45             sub build {
46 0     0 0   my $self = shift;
47            
48 0           my $wdir = $self->workingdir;
49 0           my $makefile = 'makefile.gcc';
50 0           my $mainc = 'main.c';
51 0           my $hipicname = $self->outputexec . '.c';
52 0           my $execname = $self->outputexec;
53            
54 0           my $restoredir = getcwd();
55            
56             try {
57             # create makefile
58 0 0   0     File::Slurp::write_file( qq($wdir/$makefile), $self->makefile_template )
59             or croak qq(failed to create $makefile : $!);
60            
61             # create main.c
62 0 0         File::Slurp::write_file( qq($wdir/$mainc), $self->main_template )
63             or croak qq(failed to create $mainc : $!);
64            
65             # create hipi.c
66 0           $self->create_perl_c( $self->sourceperl, qq($wdir/$hipicname) );
67            
68             # run make
69 0 0         chdir($wdir) or croak qq(failed to enter directory $wdir);
70             # clean existing
71             {
72 0 0         system(qq(make -f $makefile)) and croak qq(failed to make $execname);
  0            
73 0           system(qq(make -f $makefile clean));
74 0           unlink( $makefile );
75             }
76             } catch {
77 0     0     chdir($restoredir);
78 0           croak qq(failed to build $execname : $_);
79 0           };
80 0           chdir($restoredir);
81             }
82              
83             sub create_perl_c {
84 0     0 0   my($self, $source, $outfile) = @_;
85            
86 0           my $rawcontent = File::Slurp::read_file($source);
87            
88 0 0         open my $fh, '>', $outfile or die "open '$outfile': $!";
89 0           binmode $fh;
90            
91 0           my ($output, $rawlen) = $self->compress_buffer( $rawcontent );
92            
93 0           my $compressedlen = length($output);
94 0           my $rawchars = $rawlen + 1;
95            
96 0           my $progbootsizename = 'size_hipi_prog';
97 0           my $progcompsizename = 'size_hipi_prog_comp';
98 0           my $progcompname = 'hipi_prog_comp';
99            
100 0           print $fh qq(\n);
101 0           print $fh qq(unsigned long $progbootsizename = $rawchars;\n);
102 0           print $fh qq(unsigned long $progcompsizename = $compressedlen;\n);
103 0           my $buffer = reverse( $output );
104 0           print $fh qq(const unsigned char $progcompname\[) . (length($buffer) + 1) . qq(] = {);
105            
106 0           my $i;
107 0           for (1 .. length($buffer)) {
108 0           print $fh sprintf "'\\%03o',", ord(chop($buffer));
109 0 0         print $fh "\n" unless $i++ % 16; # line break every 16
110             }
111            
112 0           print $fh qq(0\n};\n);
113            
114 0           close($fh);
115             }
116              
117             sub compress_buffer {
118 0     0 0   my ($self, $buffer) = @_;
119 0           my( $compressed, $clen ) = _compress_buffer($buffer);
120 0           return( $compressed, $clen );
121             }
122              
123             sub decompress_buffer {
124 0     0 0   my ($self, $compressed, $length) = @_;
125 0           _decompress_buffer($compressed, $length);
126             }
127              
128             sub makefile_template {
129 0     0 0   my $self = shift;
130 0           my $template = <<'PEPIMAKEFILETEMPLATE'
131              
132             MV=mv -f
133             RM=rm -f
134              
135             LD=REPLACELDEXEC
136             CC=REPLACECCEXEC
137              
138             PERL=REPLACEPERL
139              
140             CFLAGS=REPLACECFLAGS
141             LDFLAGS=REPLACELDFLAGS
142             LDLIBS=REPLACELDLIBS
143              
144             NOOP=$(PERL) -e1
145              
146             OBJECTS=main.o REPLACEOBJNAME.o
147              
148             all:: exec
149              
150             REPLACEOBJNAME.o:
151             $(CC) -c $(CFLAGS) REPLACEOBJNAME.c -o REPLACEOBJNAME.o
152              
153             main.o:
154             $(CC) -c $(CFLAGS) main.c -o main.o
155            
156             clean:
157             -$(RM) $(OBJECTS) main.c REPLACEOBJNAME.c
158              
159             realclean: clean
160             -$(RM) REPLACEOBJNAME
161              
162             exec: $(OBJECTS)
163             -$(LD) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o REPLACEOBJNAME
164             strip REPLACEOBJNAME
165              
166             PEPIMAKEFILETEMPLATE
167             ;
168 0           my $perl = $^X;
169 0           $template =~ s/REPLACEPERL/$perl/g;
170            
171 0           my $gcc = $Config{cc};
172 0           $template =~ s/REPLACECCEXEC/$gcc/g;
173            
174 0           my $ld = $Config{ld};
175 0           $template =~ s/REPLACELDEXEC/$ld/g;
176            
177 0           my $oname = $self->outputexec;
178 0           $template =~ s/REPLACEOBJNAME/$oname/g;
179            
180 0           my $optimise = $Config{optimize};
181            
182 0           my $cflags = $optimise . ' ' . $Config{ccflags} . ' ' . $Config{cccdlflags} . ' -I' . $Config{archlibexp} . '/CORE';
183 0           $template =~ s/REPLACECFLAGS/$cflags/g;
184            
185             #my $libpaths = $Config{libpth};
186             #$libpaths =~ s/\s+/ -L/g;
187 0           my $ldflags = $optimise . ' ' . $Config{ldflags} ;
188 0           $template =~ s/REPLACELDFLAGS/$ldflags/g;
189            
190 0           my $ldlibs = '-ldl -lm -lpthread -lc -lcrypt -lz -lperl';
191 0           $template =~ s/REPLACELDLIBS/$ldlibs/g;
192            
193 0           return $template;
194             }
195              
196             sub main_template {
197 0     0 0   my $self = shift;
198 0           my $template = <<'PEPIMAINTEMPLATE'
199             #include
200             #include
201             #include
202             #include
203              
204             extern char **environ;
205             #define envhipi environ
206             #include
207             #include
208              
209             extern char hipi_prog_comp[];
210             extern unsigned long size_hipi_prog;
211             extern unsigned long size_hipi_prog_comp;
212             static char **dynamicargv;
213             static char *hipi_prog;
214              
215             /* The __findenv and hipi_unsetenv functions are subject to the following
216             * notice:
217             *
218             * Copyright (c) 1987, 1993
219             * The Regents of the University of California. All rights reserved.
220             *
221             * Redistribution and use in source and binary forms, with or without
222             * modification, are permitted provided that the following conditions
223             * are met:
224             * 1. Redistributions of source code must retain the above copyright
225             * notice, this list of conditions and the following disclaimer.
226             * 2. Redistributions in binary form must reproduce the above copyright
227             * notice, this list of conditions and the following disclaimer in the
228             * documentation and/or other materials provided with the distribution.
229             * 3. Neither the name of the University nor the names of its contributors
230             * may be used to endorse or promote products derived from this software
231             * without specific prior written permission.
232             *
233             * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
234             * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
235             * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
236             * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
237             * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
238             * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
239             * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
240             * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
241             * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
242             * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
243             * SUCH DAMAGE.
244             */
245              
246              
247             static char *__findenv(register const char *name, int *offset)
248             {
249              
250             register int len;
251             register const char *np;
252             register char **p, *c;
253            
254             if (name == NULL || envhipi == NULL)
255             exit (101);
256            
257             for (np = name; *np && *np != '='; ++np)
258             continue;
259            
260             len = np - name;
261            
262             for (p = envhipi; (c = *p) != NULL; ++p)
263             {
264             if (strncmp(c, name, len) == 0 && c[len] == '=') {
265             *offset = p - envhipi;
266             return (c + len + 1);
267             }
268             }
269             return (NULL);
270             }
271              
272             static void hipi_unsetenv(const char *name)
273             {
274             register char **p;
275             int offset;
276              
277             while (__findenv(name, &offset)) /* if set multiple times */
278             for (p = &envhipi[offset];; ++p)
279             if (!(*p = *(p + 1)))
280             break;
281             }
282              
283             int error_message( char *message, int marker )
284             {
285             int result;
286             #ifdef WIN32
287             result = GetLastError();
288             #else
289             result = 0;
290             #endif
291             printf("Error at executable startup %d: (%d)\n%s", marker, result, message );
292             return marker;
293             }
294              
295             void decompress_prog()
296             {
297             Newx(hipi_prog, size_hipi_prog, char);
298             uLongf uncompressedsize = (uLongf)size_hipi_prog;
299             uncompress((Bytef*)hipi_prog, &uncompressedsize, (const Bytef*)hipi_prog_comp, (uLongf)size_hipi_prog_comp);
300             }
301              
302             #define NUMENVKEYS 20
303              
304             void clear_environment()
305             {
306             int i;
307             const char *env_keys[NUMENVKEYS] = {
308             "PERL5OPT", "PERL5LIB", "PERLIO",
309             "PERLIO_DEBUG", "PERLLIB", "PERL5DB",
310             "PERL5DB_THREADED", "PERL5SHELL", "PERL_ALLOW_NON_IFS_LSP",
311             "PERL_DEBUG_MSTATS", "PERL_DESTRUCT_LEVEL", "PERL_DL_NONLAZY",
312             "PERL_ENCODING", "PERL_HASH_SEED", "PERL_HASH_SEED_DEBUG",
313             "PERL_SIGNALS", "PERL_UNICODE", "PERL_ROOT", "HARNESS_ACTIVE", "HARNESS_VERSION"
314             };
315              
316             for ( i = 0 ; i < NUMENVKEYS ; i++ ) {
317             hipi_unsetenv(env_keys[i]);
318             }
319             }
320              
321             EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
322              
323             EXTERN_C void xs_init(pTHX)
324             {
325             const char* file = __FILE__;
326             dXSUB_SYS;
327             /* DynaLoader is a special case */
328             newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
329             }
330              
331             int main ( int argc, char **argv )
332             {
333             int exitstatus;
334             int i;
335             int numopts;
336             int extraopts;
337             PerlInterpreter *my_perl ;
338             /* environment */
339             clear_environment();
340              
341             /* be specific about safe putenv */
342             PL_use_safe_putenv = TRUE;
343              
344             /* if user wants control of gprof profiling off by default */
345             /* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
346             PERL_GPROF_MONCONTROL(0);
347            
348             PERL_SYS_INIT3(&argc,&argv,&envhipi);
349              
350             #if defined(USE_ITHREADS) && defined(HAS_PTHREAD_ATFORK)
351             PTHREAD_ATFORK(Perl_atfork_lock, Perl_atfork_unlock, Perl_atfork_unlock);
352             #endif
353              
354             if (!(my_perl = perl_alloc()))
355             return (1);
356            
357             perl_construct(my_perl);
358            
359             PL_perl_destruct_level = 1;
360             PL_origalen = 1;
361            
362             PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
363             PL_exit_flags |= PERL_EXIT_EXPECTED;
364            
365             /* prepare prog */
366             decompress_prog();
367              
368             /* Mung & Allocate Arguments */
369             extraopts = 3;
370             numopts = argc + extraopts;
371            
372             Newx(dynamicargv, numopts, char *);
373              
374             dynamicargv[0] = argv[0];
375             dynamicargv[1] = "-f\0";
376             dynamicargv[2] = "-e\0";
377             dynamicargv[3] = hipi_prog;
378              
379             for (i = 1; i < argc; i++)
380             dynamicargv[i + extraopts] = argv[i];
381              
382             /* parse perl */
383             exitstatus = perl_parse(my_perl, xs_init, numopts, dynamicargv, envhipi);
384              
385             /* run perl */
386             if (!exitstatus ) {
387             perl_run( my_perl );
388             exitstatus = perl_destruct( my_perl );
389             } else {
390             perl_destruct( my_perl );
391             }
392            
393             /* cleanup */
394              
395             perl_free(my_perl);
396              
397             PERL_SYS_TERM();
398              
399             return exitstatus;
400             }
401              
402             PEPIMAINTEMPLATE
403             ;
404            
405 0           return $template;
406             }
407              
408             1;