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$/);
}
|