File: Tix2perl

package info (click to toggle)
perl-tk 1:800.025-2
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 18,444 kB
  • ctags: 19,081
  • sloc: ansic: 206,740; perl: 40,187; makefile: 4,371; sh: 2,373; yacc: 762
file content (118 lines) | stat: -rwxr-xr-x 2,149 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
#!/usr/local/bin/perl -w

use Tk::Pretty;

sub complete
{
 local ($_) = @_;
 my $open  = tr/{/{/;
 my $close = tr/}/}/;
 return 0 if ($open > $close);
 die "More } than { in \n$_" if ($close > $open);
 my $open  = tr/[/[/;
 my $close = tr/]/]/;
 return 0 if ($open > $close);
 die "More ] than [ in \n$_" if ($close > $open);
 return 1;
}

sub statement
{
# &Tk::Pretty::PrintArgs;
 local ($_) = @_;
 my ($sp,$rest) = (/^(\s*)(.*)$/s);
 if (defined($rest) && length($rest))
  {
   my @words = split(/\s+/,$rest);
   my $cmd = shift(@words); 
   my $i = 0;
   while ($i < @words)
    {
     while (($i+1) < @words && !complete($words[$i]))
      {
       my $next = splice(@words,$i+1,1);
       $words[$i] .= " $next";
      }
     $i++;
    }
   print PERL "$cmd(",join(',',@words),");\n";
  }
 else
  {
   print PERL "$_\n";
  }
}

sub block
{
 my @lines = split(/\n/,$_[0]);
 local ($_);
 while (@lines)
  {
   $_ = shift(@lines);
   while (@lines && !complete($_))
    {
     my $more = shift(@lines);
     $_ .= "\n$more";
    }
   statement($_);
  }
}

sub convert
{
 my ($tcl) = @_;
 open(TCL,"expand $tcl|") || die "Cannot open expand $tcl:$!";
 open(PERL,">$tcl.pm") || die "Cannot open $tcl.pm:$!";
LOOP:
 while (<TCL>)
  {
   if (/^\s*(#.*)?$/)
    {
     print PERL $_;
    }
   else
    {
     if (/\\$/ || !complete($_))
      {
       my $more = <TCL>;
       if (/\\$/)
        {
         chomp;
         s/\\$//;
        }
       $_ .= $more;
       redo LOOP;
      }
     # handling of args with defaults needs work for general case
     if (/^proc\s+(\S+)\s*\{([^\}]*)}\s*\{(.*)\}\s*$/s)
      {
       my ($name,$args,$body) = ($1,$2,$3);
       print STDERR "$name\n";
       print PERL "sub $name\n{\n";
       my @args = split(/\s/,$args);
       if (@args)
        {
         print PERL " my (",join(',',map('$'.$_,@args)),") = \@_;\n"; 
        }
       block($body);
       print PERL "}\n";
       next LOOP;
      }
     else
      {
       chomp;
       statement($_);
      }
    }
  }
 close(TCL);
 close(PERL);
}

@ARGV = <*.tcl> unless (@ARGV);

foreach $file (@ARGV)
 {
  convert($file) if ($file =~ /\.tcl$/);
 }