This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Okay, here's your official unofficial closure leak patch
[perl5.git] / minimod.PL
CommitLineData
fed7345c
AD
1# minimod.PL writes the contents of miniperlmain.c into the module
2# ExtUtils::Miniperl for later perusal (when the perl source is
3# deleted)
4#
5# It also writes the subroutine writemain(), which takes as its
6# arguments module names that shall be statically linked into perl.
7#
8# Authors: Andreas Koenig <k@franz.ww.TU-Berlin.DE>, Tim Bunce
9# <Tim.Bunce@ig.co.uk>
10#
11# Version 1.0, Feb 2nd 1995 by Andreas Koenig
12
13print <<'END';
14# This File keeps the contents of miniperlmain.c.
15#
16# It was generated automatically by minimod.PL from the contents
17# of miniperlmain.c. Don't edit this file!
18#
19# ANY CHANGES MADE HERE WILL BE LOST!
20#
21
22
23package ExtUtils::Miniperl;
24require Exporter;
25@ISA = qw(Exporter);
26@EXPORT = qw(&writemain);
27
28$head= <<'EOF!HEAD';
29END
30
31open MINI, "miniperlmain.c";
32while (<MINI>) {
33 last if /Do not delete this line--writemain depends on it/;
34 print;
35}
36
37print <<'END';
38EOF!HEAD
39$tail=<<'EOF!TAIL';
40END
41
42while (<MINI>) {
43 print;
44}
45close MINI;
46
47print <<'END';
48EOF!TAIL
49
50sub writemain{
51 my(@exts) = @_;
52
53 my($pname);
54 my($dl) = canon('/','DynaLoader');
55 print $head;
56 print " char *file = __FILE__;\n";
57 foreach $_ (@exts){
58 my($pname) = canon('/', $_);
59 my($mname, $cname);
60 ($mname = $pname) =~ s!/!::!g;
61 ($cname = $pname) =~ s!/!__!g;
62 print "\t{ extern void boot_${cname} _((CV* cv));\n";
63 if ($pname eq $dl){
64 # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
65 # boot_DynaLoader is called directly in DynaLoader.pm
66 print "\t/* DynaLoader is a special case */\n";
67 print "\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n"
68 } else {
69 print "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n"
70 }
71 print "\t}\n";
72 }
73 print $tail;
74}
75
76sub canon{
77 my($as, @ext) = @_;
78 foreach(@ext){
79 # might be X::Y or lib/auto/X/Y/Y.a
80 next if s!::!/!g;
81 s:^(lib|ext)/(auto/)?::;
82 s:/\w+\.\w+$::;
83 }
84 grep(s:/:$as:, @ext) if ($as ne '/');
85 @ext;
86}
87
881;
89END