home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _c5876614e7241b035c43c6cc53117d2d < prev    next >
Text File  |  2004-06-01  |  11KB  |  428 lines
  1. #!/usr/local/bin/perl -w
  2. use strict;
  3.  
  4.  
  5. my %Ignore;
  6. my %Ignored;
  7. my %WinIgnore;
  8. my %Exclude;
  9.  
  10. my $oops = 0;
  11.  
  12. use Getopt::Std;
  13. my %opt;
  14. getopts('mt',\%opt);
  15. my @Files;
  16.  
  17. sub openRO
  18. {
  19.  my ($fh,$file) = @_;
  20.  if (-f $file && !-w $file)
  21.   {
  22.    chmod(0666,$file) || warn "Cannot change permissions on $file:$!";
  23.   }
  24.  open($fh,">$file") || return 0;
  25.  push(@Files,$file);
  26.  return 1;
  27. }
  28.  
  29. END
  30.  {
  31.   while (@Files)
  32.    {
  33.     my $file = pop(@Files);
  34.     if (-f $file)
  35.      {
  36.       chmod(0444,$file) || warn "Cannot change permissions on $file:$!";
  37.      }
  38.    }
  39.  }
  40.  
  41. my $win_arch = shift;
  42. die "Unknown \$win_arch" unless $win_arch eq 'open32'
  43.                                 or $win_arch eq 'pm'
  44.                                 or $win_arch eq 'x'
  45.                                 or $win_arch eq 'MSWin32';
  46. my $xexcl = <<EOM;
  47. #if (defined(__WIN32__) || defined(__PM__)) && !defined(DO_X_EXCLUDE)
  48. #  define DO_X_EXCLUDE
  49. #endif
  50. EOM
  51.  
  52. sub Ignore
  53. {
  54.  my $cfile = shift;
  55.  if (open(C,"<$cfile"))
  56.   {
  57.    warn "Ignoring from $cfile\n";
  58.    while (<C>)
  59.     {
  60.      if (/^([A-Za-z][A-Za-z0-9_]*)/)
  61.       {
  62.        $Ignore{$1} = $cfile;
  63.       }
  64.     }
  65.    close(C);
  66.   }
  67.  else
  68.   {
  69.    warn "Cannot open $cfile:$!";
  70.   }
  71. }
  72.  
  73. sub WinIgnore
  74. {
  75.  my $cfile = shift;
  76.  if (open(C,"<$cfile"))
  77.   {
  78.    warn "WinIgnoring from $cfile\n";
  79.    while (<C>)
  80.     {
  81.      if (/^([A-Za-z][A-Za-z0-9_]*)/)
  82.       {
  83.        $WinIgnore{$1} = $cfile;
  84.       }
  85.     }
  86.    close(C);
  87.   }
  88.  else
  89.   {
  90.    warn "Cannot open $cfile:$!";
  91.   }
  92. }
  93.  
  94. sub Exclude
  95. {
  96.  my $cfile = shift;
  97.  if (open(C,"<$cfile"))
  98.   {
  99.    while (<C>)
  100.     {
  101.      if (/{\s*\"[^\"]+\"\s*,\s*(\w+)\s*}/)
  102.       {
  103.        $Exclude{$1} = $cfile;
  104.       }
  105.     }
  106.    close(C);
  107.   }
  108.  else
  109.   {
  110.    warn "Cannot open $cfile:$!";
  111.   }
  112. }
  113.  
  114. sub Vfunc
  115. {
  116.  my $hfile = shift;
  117.  my %VFunc = ();
  118.  my %VVar  = ();
  119.  my %VError= ();
  120.  my $errors = 0;
  121.  my @ifdef  = ('');
  122.  open(H,"<$hfile") || die "Cannot open $hfile:$!";
  123.  my $gard = "\U$hfile";
  124.  $gard =~ s/\..*$//;
  125.  $gard =~ s#/#_#g;
  126.  
  127.  while (<H>)
  128.   {
  129.    if (/^\s*#\s*if/)
  130.     {
  131.      s#//.*##;
  132.      s#/\*.*?\*/# #g;
  133.      s/\s+$//;
  134.      s/^\s*#\s*ifndef\s+_$gard\b.*//;
  135.      s/^\s*#\s*ifndef\s+_\w+_H_\b.*//;
  136.      warn "'$gard' in '$_'" if /$gard/;
  137.      push(@ifdef,$_);
  138.     }
  139.    elsif (/^\s*#\s*else/)
  140.     {
  141.      s/\s+$//;
  142.      #warn "$hfile:$.:$_\n";
  143.      $ifdef[-1] = $_;
  144.     }
  145.    elsif (/^\s*#\s*endif\b/)
  146.     {
  147.      pop(@ifdef);
  148.     }
  149.    elsif (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s+_ANSI_ARGS_\s*\((TCL_VARARGS)?\(/)
  150.     {
  151.      my ($type,$name,$op) = ($2,$3,$4);
  152.      if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
  153.       {
  154.        warn "$1 $name\n";
  155.        $oops++;
  156.        $Ignore{$name} = $hfile;
  157.       }
  158.      $op = "" unless (defined $op);
  159.      my $defn =  "VFUNC($type,$name,V_$name,_ANSI_ARGS_($op(";
  160.      $_ = $';
  161.      until (/\)\);\s*$/)
  162.       {
  163.        $defn .= $_;
  164.        $_ = <H>;
  165.        if (/^\S/)
  166.         {
  167.          chomp($_);
  168.          die $_;
  169.         }
  170.       }
  171.      s/\)\);\s*$/\)\)\)\n/;
  172.      $defn .= $_;
  173.      die "$hfile:$.:$ifdef[-1]\n" if  $ifdef[-1] =~ /\belse\b/;
  174.      if (exists($VFunc{$name}{$ifdef[-1]}) && $defn ne $VFunc{$name}{$ifdef[-1]})
  175.       {
  176.        warn "Function (@ifdef) $name is $defn and $VFunc{$name}{$ifdef[-1]}";
  177.        $errors++;
  178.       }
  179.      else
  180.       {
  181.        $VFunc{$name}{$ifdef[-1]} = $defn;
  182.       }    
  183.     }
  184.    elsif (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s*;/)
  185.     {
  186.      my ($type,$name) = ($2,$3);
  187.      if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
  188.       {
  189.        warn "$1 $name\n";
  190.        $oops++;
  191.        $Ignore{$name} = $hfile;
  192.       }
  193.      my $defn = "VVAR($type,$name,V_$name)\n";
  194.      die "$hfile:$.:$ifdef[-1]\n" if  $ifdef[-1] =~ /\belse\b/;
  195.      if (exists $VVar{$name}{$ifdef[-1]})
  196.       {
  197.        warn "Variable (@ifdef) $name is $defn and $VVar{$name}{$ifdef[-1]}";
  198.        $errors++;
  199.       }
  200.      else
  201.       {
  202.        $VVar{$name}{$ifdef[-1]} = $defn;
  203.       }    
  204.     }
  205.    elsif (/\b(EXTERN|extern)\s+[\w_]+\s+[\w_]+\[\];$/)
  206.     {
  207.  
  208.     }
  209.    elsif (/\b(EXTERN|extern)\s*"C"\s*\{\s*$/)
  210.     {
  211.  
  212.     }
  213.    elsif (/\b(EXTERN|extern)\b/)
  214.     {
  215.      warn "$hfile:$.: $_" unless (/^\s*\#\s*define/);
  216.     }
  217.   }
  218.  close(H);
  219.  die "Multiple definitions\n" if $errors;
  220.  
  221.  
  222.  if (keys %VFunc || keys %VVar)
  223.   {
  224.    my $name = "\u\L${gard}\UV";
  225.    my $fdef = $hfile;
  226.    $fdef =~ s/\..*$/.t/;
  227.    my $mdef = $hfile;
  228.    $mdef =~ s/\..*$/.m/;
  229.  
  230.    $mdef .= 'dmy' unless $opt{'m'};
  231.    $fdef .= 'dmy' unless $opt{'t'};
  232.  
  233.    my $htfile = $hfile;
  234.    $htfile =~ s/\..*$/_f.h/;
  235.    unless (-r $htfile)
  236.     {
  237.      openRO(\*C,$htfile) || die "Cannot open $htfile:$!";
  238.      print C "#ifndef ${gard}_VT\n";
  239.      print C "#define ${gard}_VT\n";
  240.      print C "typedef struct ${name}tab\n{\n";
  241.      print C " unsigned (*tabSize)(void);\n";
  242.      print C "#define VFUNC(type,name,mem,args) type (*mem) args;\n";
  243.      print C "#define VVAR(type,name,mem)       type (*mem);\n";
  244.      print C "#include \"$fdef\"\n";
  245.      print C "#undef VFUNC\n";
  246.      print C "#undef VVAR\n";
  247.      print C "} ${name}tab;\n";
  248.      print C "extern ${name}tab *${name}ptr;\n";
  249.      print C "extern ${name}tab *${name}Get(void);\n";
  250.      print C "#endif /* ${gard}_VT */\n";
  251.      close(C);
  252.     }
  253.  
  254.    my $cfile = $hfile;
  255.    $cfile =~ s/\..*$/_f.c/;
  256.    unless (-r $cfile)
  257.     {
  258.      openRO(\*C,$cfile) || die "Cannot open $cfile:$!";
  259.      print C "#include \"$hfile\"\n";
  260.      print C "#include \"$htfile\"\n";
  261.      print C "static unsigned ${name}Size(void) { return sizeof(${name}tab);}\n";
  262.      print C "static ${name}tab ${name}table =\n{\n";
  263.      print C " ${name}Size,\n";
  264.      print C "#define VFUNC(type,name,mem,args) name,\n";
  265.      print C "#define VVAR(type,name,mem)      &name,\n";
  266.      print C "#include \"$fdef\"\n";
  267.      print C "#undef VFUNC\n";
  268.      print C "#undef VVAR\n";
  269.      print C "};\n";
  270.      print C "${name}tab *${name}ptr;\n";
  271.      print C "${name}tab *${name}Get() { return ${name}ptr = &${name}table;}\n";
  272.      close(C);
  273.     }
  274.  
  275.    print STDERR "$gard\n";
  276.    openRO(\*VFUNC,$fdef)   || die "Cannot open $fdef:$!";
  277.    openRO(\*VMACRO,$mdef)  || die "Cannot open $mdef:$!";
  278.    print VFUNC  "#ifdef _$gard\n";
  279.    print VMACRO "#ifndef _${gard}_VM\n";
  280.    print VMACRO "#define _${gard}_VM\n";
  281.    print VMACRO "#include \"$htfile\"\n";
  282.    print VMACRO "#ifndef NO_VTABLES\n";
  283.    print VMACRO $xexcl if %WinIgnore;
  284.    print VFUNC  $xexcl if %WinIgnore;
  285.    foreach my $func (sort keys %VVar)
  286.     {
  287.      if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
  288.       {
  289.        foreach my $ifdef (sort keys %{$VVar{$func}})
  290.         {
  291.      print VFUNC "$ifdef\n" if ($ifdef);
  292.          print VFUNC $VVar{$func}{$ifdef};
  293.      print VFUNC "#endif /* $ifdef */\n" if ($ifdef);
  294.         }
  295.        print VMACRO "#define $func (*${name}ptr->V_$func)\n";
  296.       }
  297.      $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
  298.     }
  299.    foreach my $func (sort keys %VFunc)
  300.     {
  301.      if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
  302.       {
  303.        print VFUNC "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
  304.        print VFUNC "#ifndef $func\n";
  305.        foreach my $ifdef (sort keys %{$VFunc{$func}})
  306.         {
  307.      print VFUNC "$ifdef\n" if ($ifdef);
  308.          print VFUNC $VFunc{$func}{$ifdef};
  309.      print VFUNC "#endif /* $ifdef */\n" if ($ifdef);
  310.     }
  311.        print VFUNC "#endif /* #ifndef $func */\n";
  312.        print VFUNC "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
  313.        print VFUNC "\n";
  314.  
  315.        print VMACRO "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
  316.        print VMACRO "#ifndef $func\n";
  317.        print VMACRO "#  define $func (*${name}ptr->V_$func)\n";
  318.        print VMACRO "#endif\n";
  319.        print VMACRO "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
  320.        print VMACRO "\n";
  321.       }
  322.      $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
  323.     }
  324.    print VMACRO "#endif /* NO_VTABLES */\n";
  325.    print VMACRO "#endif /* _${gard}_VM */\n";
  326.    close(VMACRO);
  327.    print VFUNC  "#endif /* _$gard */\n";
  328.    close(VFUNC); # Close this last - Makefile dependency
  329.  
  330.    unlink($mdef) unless $opt{'m'};
  331.    unlink($fdef) unless $opt{'t'};
  332.   }
  333.  else
  334.   {
  335.    die "No entries in $hfile\n";
  336.   }
  337. }
  338.  
  339. foreach (<tk*Tab.c>)
  340.  {
  341.   Exclude($_);
  342.  }
  343.  
  344. die "Usage: $0 <some.h>\n" if (@ARGV != 1);
  345.  
  346. my $h = shift;
  347. my $x = $h;
  348. $x =~ s/\.h/.exc/;
  349. Ignore($x) if (-f $x);
  350. $x =~ s/\.exc/.excwin/;
  351. WinIgnore($x) if (-f $x);
  352. Vfunc($h);
  353.  
  354. foreach my $s (sort keys %Ignore)
  355.  {
  356.   warn "$s is not in $h\n";
  357.   $oops++;
  358.  }
  359.  
  360. if ($oops)
  361.  {
  362.   $x = $h;
  363.   $x =~ s/\.h/.exc/;
  364.   rename($x,"$x.old") || die "Cannot rename $x to $x.old:$!";
  365.   open(EXC,">$x") || die "Cannot open $x:$!";
  366.   foreach my $s (sort keys %Ignored)
  367.    {
  368.     print EXC $s,"\n";
  369.    }
  370.   close(EXC);
  371.  }
  372.  
  373. __END__
  374.  
  375. =head1 NAME
  376.  
  377. mkVFunc - Support for "nested" dynamic loading
  378.  
  379. =head1 SYNOPSIS
  380.  
  381.  mkVFunc xxx.h
  382.  
  383. =head1 DESCRIPTION
  384.  
  385. B<perl/Tk> is designed so that B<Tk> can be dynamically loaded 'on top of'
  386. perl. That is the easy bit. What it also does is allow Tk::Xxxx to be
  387. dynamically loaded 'on top of' the B<perl/Tk> composite. Thus when
  388. you 'require Tk::HList' the shared object F<.../HList.so> needs to be
  389. able to call functions defined in perl I<and> functions defined in loadable
  390. .../Tk.so . Now functions in 'base executable' are a well known problem,
  391. and are solved by DynaLoader. However most of dynamic loading schemes
  392. cannot handle one loadable calling another loadable.
  393.  
  394. Thus what Tk does is build a table of functions that should be callable.
  395. This table is auto-generated from the .h file by looking for
  396. 'extern' (and EXTERN which is #defined to 'extern').
  397. Thus any function marked as 'extern' is 'referenced' by the table.
  398. The address of the table is then stored in a perl variable when Tk is loaded.
  399. When HList is loaded it looks in the perl variable (via functions
  400. in perl - the 'base executable') to get the address of the table.
  401.  
  402. The same utility that builds the table also builds a set of #define's.
  403. HList.c (and any other .c files which comprise HList) #include these
  404. #define's. So that
  405.  
  406.   Tk_SomeFunc(x,y,z)
  407.  
  408. Is actually compiled as
  409.  
  410.   (*TkVptr->V_Tk_SomeFunc)(x,y,z)
  411.  
  412. Where Tk_ptr is pointer to the table.
  413.  
  414. See:
  415.  
  416.  Tk-b*/pTk/mkVFunc - perl script that produces tables
  417.           /tk.h        - basis from which table is generated
  418.           /tk.m        - #define's to include in sub-extension
  419.           /tk_f.h      - #included both sides.
  420.           /tk_f.c      - Actual table definition.
  421.           /tk.t        - 'shared' set of macros which produce table
  422.                          included in tk_f.c and tk_f.h
  423.           /tkVMacro.h  - Wrapper to include *.m files
  424.  
  425. In addition to /tk* there are /tkInt*, /Lang* and /tix*
  426.  
  427. =cut
  428.