home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _e3d507ba7725432f051c47cc361d3871 < prev    next >
Encoding:
Text File  |  2004-06-01  |  6.4 KB  |  258 lines
  1. #!/usr/local/bin/perl -w
  2. use open IO => ':bytes'; # Avoid UTF-8 issues with some perl5.8.0 (RedHat)
  3. use Carp;
  4. my $verbose = 0;
  5.  
  6. $SIG{'__WARN__'} = sub { print STDERR $_; Carp::confess(shift) };
  7.  
  8. $src = shift;
  9. $dst = shift;
  10.  
  11. die "Usage: $0 <src> <dst> \n" unless (defined $src and defined $dst);
  12.  
  13. chmod(0666, $dst);
  14. unlink($dst);
  15. open(DST,">$dst") || die "Cannot open $dst;$!";
  16. select(DST);
  17.  
  18. my $copyright;
  19.  
  20. @ARGV = ($src);
  21.  
  22. undef $undone;
  23.  
  24. sub getline
  25. {
  26.  local $_;
  27.  if (defined $undone)
  28.   {
  29.    $_ = $undone;
  30.    undef $undone;
  31.   }
  32.  else
  33.   {
  34.    $_ = <>;
  35.   }
  36.  return $_;
  37. }
  38.  
  39. sub int_results
  40. {my $fmt = shift;
  41.  my $type = shift;
  42.  my @fmt = split(/\s+/,$fmt);
  43.  my $cnt = @fmt;
  44.  # print STDERR "'$fmt' => $cnt\n";
  45.  return "Tcl_${type}Results(interp,$cnt,0";
  46. }
  47.  
  48. sub result
  49. {my ($interp,$value,$tail) = @_;
  50.  my $line = &getline;
  51.  my $kind = "TCL_STATIC";
  52.  if (defined $line)
  53.   {
  54.    if ($line =~ /^\s*$interp\s*->\s*freeProc\s*=\s*(.*)\s*;\s*$/)
  55.     {
  56.      $kind = $1;
  57.     }
  58.    else
  59.     {
  60.      $undone = $line if (defined $line);
  61.     }
  62.   }
  63.  return "Tcl_SetResult($interp,$value,$kind)$tail";
  64. }
  65.  
  66. sub complete
  67. {
  68.  my $tail = "";
  69.  until (/;/)
  70.   {
  71.    my $line = &getline;
  72.    last unless defined($line);
  73.    s/\s*$//;
  74.    $line =~ s/^\s*//;
  75.    $_ .= " " . $line;
  76.    $tail .= "\n";
  77.   }
  78.  $_ .= $tail;
  79. }
  80.  
  81. #use Carp;
  82. #$SIG{'INT'} = sub {  Carp::confess($_) };
  83.  
  84.  
  85. PROCESS:
  86. while ($_ = &getline)
  87.  {
  88.   s/^\s*#\s*include\s*[<"]tcl\.h[">]\s*$/#include "Lang.h"\n/;
  89.  
  90.   s/^\s*#\s*include\s*<((tk|tkInt|tkPort|tix|tixInt)\.h)>\s*$/#include "$1"\n/;
  91.  
  92.   next if (/^\s*extern.*\bpanic\s*\(/);
  93.  
  94.   s/\(char\s*\*\)\s*NULL\b/         NULL/g;
  95.  
  96.   if (/^#(define|ifn?def|endif)\b/)
  97.    {
  98.     print;
  99.     while (/\\$/)
  100.      {
  101.       $_ = &getline;
  102.       print;
  103.      }
  104.     next;
  105.    }
  106.  
  107.   if (m#^ */\*# && !m#\*/#)
  108.    {
  109.     print;
  110.     while (!m#\*/#)
  111.      {
  112.       $_ = &getline;
  113.       print;
  114.      }
  115.     next;
  116.    }
  117.  
  118.   s/tclStubs\.t(\w+)/TkeventVptr->V_T$1/;
  119.  
  120.   s/\bpanic\b/Tcl_Panic/g;
  121.  
  122.   s/\b(\w+Ptr)->internalRep\./TclObjInternal($1)->/g;
  123.  
  124.   s/(\w+bjPtr)->typePtr\s*=\s*(.*);/TclObjSetType($1,$2);/g;
  125.  
  126.   s/\b(\w*bjPtr)->typePtr\b/TclObjGetType($1)/g;
  127.  
  128.   if (/if\s*\(\(c == '.'\)\s*$/)
  129.    {
  130.     my $line = &getline;
  131.     if (defined($line))
  132.      {
  133.       s/\s*$//;
  134.       $line =~ s/^\s*//;
  135.       $_ .= " " . $line . "\n";
  136.      }
  137.    }
  138.  
  139.   if (/Tcl_DeleteCommandFromToken/)
  140.    {
  141.     if (/Tcl_DeleteCommandFromToken[^;{]*$/)
  142.      {
  143.       &complete;
  144.       redo PROCESS;
  145.      }
  146.     s/Tcl_DeleteCommandFromToken(.*imageCmd)/Lang_DeleteObject$1/;
  147.     s/Tcl_DeleteCommandFromToken(.*widgetCmd)/Lang_DeleteWidget$1/;
  148.    }
  149.  
  150.   if (/Tcl_(Create|Delete)Command/)
  151.    {
  152.     if (/Tcl_(Create|Delete)Command[^;{]*$/)
  153.      {
  154.       &complete;
  155.       redo PROCESS;
  156.      }
  157.     s/Tcl_CreateCommand\s*\(\s*((\w+->)*interp)\s*,\s*Tk_PathName\s*\(([^\)]+)\)/Lang_CreateWidget($1,$3/;
  158.     s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->(\w+\.style|image)Cmd)\)/Lang_DeleteObject($1,$4/;
  159.     s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->widgetCmd)\)/Lang_DeleteWidget($1,$4/;
  160.    }
  161.  
  162.   s/\(char \*\*\)\s*objv\b/objv/g;
  163.  
  164. # s/Tcl_Obj\s+\*(CONST\s+)?objv\b/Tcl_Obj *objv/;
  165.   if (/\bargv\w*\b/)
  166.    {
  167.     if (/\bargv\w*\s*\[([^[]*)\]\s*=[^=][^;{]*$/)
  168.      {
  169.       &complete;
  170.       redo PROCESS;
  171.      }
  172.     s/Tcl_Obj\s+\*(CONST\s+)?argv\b/Tcl_Obj *objv/;
  173.     if (/\bchar\b.*\bargv\w*\b/)
  174.      {
  175.       # convert char *argv[] to char **argv
  176.       s/char\s*\*\s*\bargv\s*\[\s*\]/char **argv/;
  177.       # convert char **argv to Tcl_Obj **objv
  178.       s/(CONST\s+)?char\s*\*\*\s*\bargv\b/Tcl_Obj *CONST *objv/;
  179.       # convert char *argv[n] to Tcl_Obj **objv = LangAllocVec(n)
  180.       s/char\s*\*\s*\bargv\s*\[\s*([^[]+)\]/Tcl_Obj **objv = LangAllocVec($1)/;
  181.      }
  182.     else
  183.      {
  184.       s/([^*])\*(argv\w*(\[[^[]*\])?)/${1}${2}[0]/g;
  185.      }
  186.     s/\(Tcl_Obj\s\*\)\s*argv\b/objv/g;
  187.     s/\bargv\s*\[([^[]*)\]\s*=([^=].*);\s*$/LangSetString(objv+$1,$2);\n/;
  188.     s/\bargv\s*\[([^[]*)\]\+\+/objv[$1] = Tcl_NewStringObj(Tcl_GetString(objv[$1])+1,-1)/;
  189.     s/\bargv\s*\[([^[]*)\]\+([0-9])/Tcl_NewStringObj(Tcl_GetString(objv[$1])+$2,-1)/;
  190.     if (/Tcl_Get(Boolean|Int|Double)/ || /Tk_Get(Cursor)/)
  191.      {
  192.       s/\bargv(\w*)\b/objv$1/g;
  193.      }
  194.     s/\bargv\s*(\[[^[]*\])/Tcl_GetString(objv$1)/g;
  195.     if (/\bargv\b/)
  196.      {
  197.       warn "Leak: $_" if ($verbose && !/\bargv\s*\)/);
  198.       s/\bargv\b/objv/;
  199.      }
  200.    }
  201.   if (/->\s*result\b/)
  202.    {
  203.     s/\s*->\s*result\b/->result/g;
  204.  
  205.     s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%d)+)"/&int_results($1,"Int")/e;
  206.  
  207.     s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%g)+)"/&int_results($1,"Double")/e;
  208.  
  209.     s/\bsprintf\s*\(\s*interp->result\b/Tcl_SprintfResult(interp/;
  210.     if (/\binterp->result\s*=[^;]*$/)
  211.      {
  212.       &complete;
  213.       redo PROCESS;
  214.      }
  215.     s/\b((\w+\s*->\s*)*interp)->result\s*=([^;]*);/&result($1,$3,";")/e;
  216.     s/\b((\w+\s*->\s*)*interp)->result\s*=(.*);\s*$/&result($1,$3,";\n")/e;
  217.     s/\b((\w+\s*->\s*)*interp)->result/Tcl_GetResult($1)/;
  218.    }
  219.  
  220.   if (/\bTcl_SetResult\s*\(/)
  221.    {
  222.     if (/Tcl_SetResult\s*\([^;{]*$/)
  223.      {
  224.       &complete;
  225.       redo PROCESS;
  226.      }
  227.     s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*"(\d+)",\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1, Tcl_NewIntObj($3))/;
  228.     s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*Tk_PathName\(([^)]+)\),\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,$3))/;
  229.     s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*((\w+->)*\w+)->pathName\s*,\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,(Tk_Window)($3)))/;
  230.     die $_ if /(Tk_PathName|->pathName)/;
  231.    }
  232. #            1             2                 3           4                  5                           6
  233.   s/\(c == '(.)'\)\s*&&\s*(\(?)\(strncmp\(([^,]+),\s*("-\1[^"]*"),\s*(\w+|strlen\(\3\))\s*\)\s*==\s*0\)(\)?)/(c == '$1') && $2 LangCmpOpt($4,$3,$5) == 0 $6/g;
  234.   s/\(c == '(.)'\)\s*&&\s*\(strcmp\(([^,]+),\s*("-\1[^"]*")\s*\)\s*==\s*0\)/(c == '$1') && LangCmpOpt($3,$2,0) == 0/g;
  235.  
  236.   if (defined($copyright) && !/^\s\*\s*Copyright/)
  237.    {
  238.     print $copyright;
  239.     undef $copyright;
  240.    }
  241.  
  242.   s/[^\S\n]+$//;
  243.   print;
  244.  
  245.   if (0 && /^((\s\*)\s*)Copyright/)
  246.    {
  247.     $copyright = "$2\n$1Modifications Copyright (c) 1994-2003 Nick Ing-Simmons\n";
  248.    }
  249.  }
  250.  
  251. select(STDOUT);
  252. close(DST);
  253.  
  254. chmod(0444,$dst);
  255.  
  256. exit 0;
  257.  
  258.