minimod.PL

   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
  13 print <<'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
  23 package ExtUtils::Miniperl;
  24 require Exporter;
  25 @ISA = qw(Exporter);
  26 @EXPORT = qw(&writemain);
  27
  28 $head= <<'EOF!HEAD';
  29 END
  30
  31 open MINI, "miniperlmain.c";
  32 while (<MINI>) {
  33     last if /Do not delete this line--writemain depends on it/;
  34     print;
  35 }
  36
  37 print <<'END';
  38 EOF!HEAD
  39 $tail=<<'EOF!TAIL';
  40 END
  41
  42 while (<MINI>) {
  43     print;
  44 }
  45 close MINI;
  46
  47 print <<'END';
  48 EOF!TAIL
  49
  50 sub 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
  76 sub 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
  88 1;
  89 END