File: mkmethods

package info (click to toggle)
perl-tk 1%3A804.033-2
  • links: PTS
  • area: main
  • in suites: buster
  • size: 34,724 kB
  • ctags: 37,174
  • sloc: ansic: 349,541; perl: 52,192; sh: 17,904; makefile: 5,732; asm: 3,565; ada: 1,681; pascal: 1,089; cpp: 1,006; yacc: 883; cs: 879
file content (124 lines) | stat: -rwxr-xr-x 2,765 bytes parent folder | download | duplicates (10)
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
119
120
121
122
123
124
#!/usr/local/bin/perl -w

$dst = shift;

while (<>)
 {
  if (defined $Widget)
   {
    undef $Widget if (/^}/);
    if (/strn?cmp\s*\(\s*LangString\(args\[1\]\)\s*,\s*("[^"]*")\s*/)
     {
      if ($1 ne '"configure"' and $1 ne '"cget"')
       {
        push(@{$table{WIDGET}{$Widget}},$1);
       }
     }
   }
  elsif (defined $Image)
   {
    undef $Image if (/^}/);
    if (/strn?cmp\s*\(\s*LangString\(args\[1\]\)\s*,\s*("[^"]*")\s*/)
     {
      if ($1 ne '"configure"' and $1 ne '"cget"')
       {
        push(@{$table{IMAGE}{$Image}},$1);
       }
     }
   }
  elsif (defined $Command)
   {
    undef $Command if (/^}/);
    if (/strn?cmp\s*\(\s*LangString\(args\[1\]\)\s*,\s*("[^"]*")\s*/)
     {my $string = $1;
      push(@{$table{COMMAND}{$Command}},$string) unless ($string =~ /^"-/);
     }
   }
  elsif (defined $Tag)
   {
    undef $Tag if (/^}/);
    if (/strn?cmp\s*\(\s*LangString\(args\[2\]\)\s*,\s*("[^"]*")\s*/)
     {
      push(@{$tags{$Tag}},$1);
      print "$Tag : $1\n";
     }
   }
  else
   {
    if (/^(\w+)WidgetCmd\s*\(/)
     {
      $Widget = "\L$1";
      $Widget = "\u$Widget";
      printf STDERR "Widget : $Widget\n";
      $table{WIDGET}{$Widget} = [];
     }
    elsif (/^Img(\w+)Cmd\s*\(/)
     {
      $Image = "\L$1";
      $Image = "\u$Image";
      printf STDERR "Image : $Image\n";
      $table{IMAGE}{$Image} = [];
     }
    elsif (/^(Tk)?([A-Z][a-z]+[A-Z][a-z]+)Cmd\s*\(/)
     {
      $Tag = $2;
      printf STDERR "Tag : $Tag\n";
      $tags{$Tag} = [];
     }
    elsif (/^Tk_([A-Z][a-z]+)Cmd2?\s*\(/)
     {
      $Command = "\L$1";
      printf STDERR "Command : $Command\n";
      $table{COMMAND}{$Command} = [];
     }
   }
 }

if (%{$table{WIDGET}} || %{$table{COMMAND}} || %{$table{IMAGE}})
 {
  if (open(SRC,"<$dst"))
   {
    while (<SRC>)
     {
      my ($kind,$Widget,$list) =  /^(WIDGET|COMMAND|IMAGE)\(\("(\w+)",(("[^"]*",)*)NULL\)\)$/;
      if (defined $Widget)
       {
        if (!defined ${$table{$kind}}{$Widget})
         {
          chop($list);
          print STDERR "Keep $kind $Widget : $list\n";
          my @list = split(/,/,$list);
          @list = grep(!/^(configure|cget)$/,@list);
          ${$table{$kind}}{$Widget} = \@list;
         }
       }
      else
       {
        chomp($_);
        die "Mismatch : $_" unless (/^\s*$/);
       }
     }
    close(SRC);
   }

  open(SRC,">$dst") || die "Cannot open $dst:$!";
  foreach $kind (sort keys %table)
   {
    foreach $Widget (sort keys %{$table{$kind}})
     {
      if (@{$table{$kind}{$Widget}})
       {
        print SRC "$kind((\"$Widget\",";
        foreach (sort @{$table{$kind}{$Widget}})
         {
          print SRC "$_,";
         }
        print SRC "NULL))\n";
       }
     }
   }
  close(SRC);

 }