home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / mkVFunc < prev    next >
Encoding:
Text File  |  2003-12-10  |  10.2 KB  |  425 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 "#define VFUNC(type,name,mem,args) type (*mem) args;\n";
  242.      print C "#define VVAR(type,name,mem)       type (*mem);\n";
  243.      print C "#include \"$fdef\"\n";
  244.      print C "#undef VFUNC\n";
  245.      print C "#undef VVAR\n";
  246.      print C "} ${name}tab;\n";
  247.      print C "extern ${name}tab *${name}ptr;\n";
  248.      print C "extern ${name}tab *${name}Get _ANSI_ARGS_((void));\n";
  249.      print C "#endif /* ${gard}_VT */\n";
  250.      close(C);
  251.     }
  252.  
  253.    my $cfile = $hfile;
  254.    $cfile =~ s/\..*$/_f.c/;
  255.    unless (-r $cfile)
  256.     {
  257.      openRO(\*C,$cfile) || die "Cannot open $cfile:$!";
  258.      print C "#include \"$hfile\"\n";
  259.      print C "#include \"$htfile\"\n";
  260.      print C "static ${name}tab ${name}table =\n{\n";
  261.      print C "#define VFUNC(type,name,mem,args) name,\n";
  262.      print C "#define VVAR(type,name,mem)      &name,\n";
  263.      print C "#include \"$fdef\"\n";
  264.      print C "#undef VFUNC\n";
  265.      print C "#undef VVAR\n";
  266.      print C "};\n";
  267.      print C "${name}tab *${name}ptr;\n";
  268.      print C "${name}tab *${name}Get() { return ${name}ptr = &${name}table;}\n";
  269.      close(C);
  270.     }
  271.  
  272.    print STDERR "$gard\n";
  273.    openRO(\*VFUNC,$fdef)   || die "Cannot open $fdef:$!";
  274.    openRO(\*VMACRO,$mdef)  || die "Cannot open $mdef:$!";
  275.    print VFUNC  "#ifdef _$gard\n";
  276.    print VMACRO "#ifndef _${gard}_VM\n";
  277.    print VMACRO "#define _${gard}_VM\n";
  278.    print VMACRO "#include \"$htfile\"\n";
  279.    print VMACRO "#ifndef NO_VTABLES\n";
  280.    print VMACRO $xexcl if %WinIgnore;
  281.    print VFUNC  $xexcl if %WinIgnore;
  282.    foreach my $func (sort keys %VVar)
  283.     {
  284.      if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
  285.       {
  286.        foreach my $ifdef (sort keys %{$VVar{$func}})
  287.         {
  288.      print VFUNC "$ifdef\n" if ($ifdef);
  289.          print VFUNC $VVar{$func}{$ifdef};
  290.      print VFUNC "#endif /* $ifdef */\n" if ($ifdef);
  291.         }
  292.        print VMACRO "#define $func (*${name}ptr->V_$func)\n";
  293.       }
  294.      $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
  295.     }
  296.    foreach my $func (sort keys %VFunc)
  297.     {
  298.      if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
  299.       {
  300.        print VFUNC "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
  301.        print VFUNC "#ifndef $func\n";
  302.        foreach my $ifdef (sort keys %{$VFunc{$func}})
  303.         {
  304.      print VFUNC "$ifdef\n" if ($ifdef);
  305.          print VFUNC $VFunc{$func}{$ifdef};
  306.      print VFUNC "#endif /* $ifdef */\n" if ($ifdef);
  307.     }
  308.        print VFUNC "#endif /* #ifndef $func */\n";
  309.        print VFUNC "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
  310.        print VFUNC "\n";
  311.  
  312.        print VMACRO "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
  313.        print VMACRO "#ifndef $func\n";
  314.        print VMACRO "#  define $func (*${name}ptr->V_$func)\n";
  315.        print VMACRO "#endif\n";
  316.        print VMACRO "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
  317.        print VMACRO "\n";
  318.       }
  319.      $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
  320.     }
  321.    print VMACRO "#endif /* NO_VTABLES */\n";
  322.    print VMACRO "#endif /* _${gard}_VM */\n";
  323.    close(VMACRO);
  324.    print VFUNC  "#endif /* _$gard */\n";
  325.    close(VFUNC); # Close this last - Makefile dependency
  326.  
  327.    unlink($mdef) unless $opt{'m'};
  328.    unlink($fdef) unless $opt{'t'};
  329.   }
  330.  else
  331.   {
  332.    die "No entries in $hfile\n";
  333.   }
  334. }
  335.  
  336. foreach (<tk*Tab.c>)
  337.  {
  338.   Exclude($_);
  339.  }
  340.  
  341. die "Usage: $0 <some.h>\n" if (@ARGV != 1);
  342.  
  343. my $h = shift;
  344. my $x = $h;
  345. $x =~ s/\.h/.exc/;
  346. Ignore($x) if (-f $x);
  347. $x =~ s/\.exc/.excwin/;
  348. WinIgnore($x) if (-f $x);
  349. Vfunc($h);
  350.  
  351. foreach my $s (sort keys %Ignore)
  352.  {
  353.   warn "$s is not in $h\n";
  354.   $oops++;
  355.  }
  356.  
  357. if ($oops)
  358.  {
  359.   $x = $h;
  360.   $x =~ s/\.h/.exc/;
  361.   rename($x,"$x.old") || die "Cannot rename $x to $x.old:$!";
  362.   open(EXC,">$x") || die "Cannot open $x:$!";
  363.   foreach my $s (sort keys %Ignored)
  364.    {
  365.     print EXC $s,"\n";
  366.    }
  367.   close(EXC);
  368.  }
  369.  
  370. __END__
  371.  
  372. =head1 NAME
  373.  
  374. mkVFunc - Support for "nested" dynamic loading
  375.  
  376. =head1 SYNOPSIS
  377.  
  378.  mkVFunc xxx.h
  379.  
  380. =head1 DESCRIPTION
  381.  
  382. B<perl/Tk> is designed so that B<Tk> can be dynamically loaded 'on top of'
  383. perl. That is the easy bit. What it also does is allow Tk::Xxxx to be
  384. dynamically loaded 'on top of' the B<perl/Tk> composite. Thus when
  385. you 'require Tk::HList' the shared object F<.../HList.so> needs to be
  386. able to call functions defined in perl I<and> functions defined in loadable
  387. .../Tk.so . Now functions in 'base executable' are a well known problem,
  388. and are solved by DynaLoader. However most of dynamic loading schemes
  389. cannot handle one loadable calling another loadable.
  390.  
  391. Thus what Tk does is build a table of functions that should be callable.
  392. This table is auto-generated from the .h file by looking for
  393. 'extern' (and EXTERN which is #defined to 'extern').
  394. Thus any function marked as 'extern' is 'referenced' by the table.
  395. The address of the table is then stored in a perl variable when Tk is loaded.
  396. When HList is loaded it looks in the perl variable (via functions
  397. in perl - the 'base executable') to get the address of the table.
  398.  
  399. The same utility that builds the table also builds a set of #define's.
  400. HList.c (and any other .c files which comprise HList) #include these
  401. #define's. So that
  402.  
  403.   Tk_SomeFunc(x,y,z)
  404.  
  405. Is actually compiled as
  406.  
  407.   (*TkVptr->V_Tk_SomeFunc)(x,y,z)
  408.  
  409. Where Tk_ptr is pointer to the table.
  410.  
  411. See:
  412.  
  413.  Tk-b*/pTk/mkVFunc - perl script that produces tables
  414.           /tk.h        - basis from which table is generated
  415.           /tk.m        - #define's to include in sub-extension
  416.           /tk_f.h      - #included both sides.
  417.           /tk_f.c      - Actual table definition.
  418.           /tk.t        - 'shared' set of macros which produce table
  419.                          included in tk_f.c and tk_f.h
  420.           /tkVMacro.h  - Wrapper to include *.m files
  421.  
  422. In addition to /tk* there are /tkInt*, /Lang* and /tix*
  423.  
  424. =cut
  425.