[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / pTk / mkVFunc

#!/usr/local/bin/perl -w
use strict;               

my %Ignore;
my %Ignored;
my %WinIgnore;          
my %Exclude;

my $oops = 0;

use Getopt::Std;
my %opt;
getopts('mt',\%opt);
my @Files;

sub openRO
{
 my ($fh,$file) = @_;
 if (-f $file && !-w $file)
  {
   chmod(0666,$file) || warn "Cannot change permissions on $file:$!";
  }
 open($fh,">$file") || return 0;
 push(@Files,$file);
 return 1;
}

END 
 {
  while (@Files)
   {
    my $file = pop(@Files);
    if (-f $file)
     {
      chmod(0444,$file) || warn "Cannot change permissions on $file:$!";
     }
   }
 }

my $win_arch = shift;
die "Unknown \$win_arch" unless $win_arch eq 'open32'
                                or $win_arch eq 'pm'
                                or $win_arch eq 'x'
                                or $win_arch eq 'MSWin32';
my $xexcl = <<EOM;
#if (defined(__WIN32__) || defined(__PM__)) && !defined(DO_X_EXCLUDE)
#  define DO_X_EXCLUDE
#endif
EOM

sub Ignore
{
 my $cfile = shift;
 if (open(C,"<$cfile"))
  {
   while (<C>)
    {       
     if (/^([A-Za-z][A-Za-z0-9_]*)/)
      {     
       $Ignore{$1} = $cfile;
      }     
    }       
   close(C);
  }
 else
  {
   warn "Cannot open $cfile:$!";
  }
}

sub WinIgnore
{
 my $cfile = shift;
 if (open(C,"<$cfile"))
  {
   while (<C>)
    {       
     if (/^([A-Za-z][A-Za-z0-9_]*)/)
      {     
       $WinIgnore{$1} = $cfile;
      }     
    }       
   close(C);
  }
 else
  {
   warn "Cannot open $cfile:$!";
  }
}

sub Exclude
{
 my $cfile = shift;
 if (open(C,"<$cfile"))
  {
   while (<C>)
    {       
     if (/{\s*\"[^\"]+\"\s*,\s*(\w+)\s*}/)
      {     
       $Exclude{$1} = $cfile;
      }     
    }       
   close(C);
  }
 else
  {
   warn "Cannot open $cfile:$!";
  }
}

sub Vfunc
{
 my $hfile = shift;
 my %VFunc = ();
 my %VVar  = ();
 my %VError= ();
 open(H,"<$hfile") || die "Cannot open $hfile:$!";

 while (<H>)
  {
   if (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s+_ANSI_ARGS_\s*\((TCL_VARARGS)?\(/)
    {                      
     my ($type,$name,$op) = ($2,$3,$4);
     if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
      {                   
       warn "$1 $name\n";
       $oops++;
       $Ignore{$name} = $hfile;
      }
     $op = "" unless (defined $op);
     my $defn =  "VFUNC($type,$name,V_$name,_ANSI_ARGS_($op(";
     $_ = $';
     until (/\)\);\s*$/)
      {
       $defn .= $_;
       $_ = <H>;
       if (/^\S/)
        {
         chomp($_);
         die $_;
        }
      }
     s/\)\);\s*$/\)\)\)\n/;
     $defn .= $_;
     $VFunc{$name} = $defn;
    }
   elsif (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s*;/)
    {
     my ($type,$name) = ($2,$3);
     if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
      {                   
       warn "$1 $name\n";
       $oops++;
       $Ignore{$name} = $hfile;
      }
     $VVar{$name} = "VVAR($type,$name,V_$name)\n";
    }
   elsif (/\b(EXTERN|extern)\s+[\w_]+\s+[\w_]+\[\];$/)
    {

    }
   elsif (/\b(EXTERN|extern)\s*"C"\s*\{\s*$/)
    {

    }
   elsif (/\b(EXTERN|extern)\b/)
    {
     warn "$hfile:$.: $_" unless (/^\s*\#\s*define/);
    }
  }
 close(H); 


 if (keys %VFunc || keys %VVar)
  {
   my $gard = "\U$hfile";             
   $gard =~ s/\..*$//;                 
   $gard =~ s#/#_#g;
   my $name = "\u\L${gard}\UV";
   my $fdef = $hfile;
   $fdef =~ s/\..*$/.t/;
   my $mdef = $hfile;
   $mdef =~ s/\..*$/.m/;
   
   $mdef .= 'dmy' unless $opt{'m'};
   $fdef .= 'dmy' unless $opt{'t'};
        
   my $htfile = $hfile;
   $htfile =~ s/\..*$/_f.h/;
   unless (-r $htfile)
    {
     openRO(\*C,$htfile) || die "Cannot open $htfile:$!";
     print C "#ifndef ${gard}_VT\n";
     print C "#define ${gard}_VT\n";
     print C "typedef struct ${name}tab\n{\n";
     print C "#define VFUNC(type,name,mem,args) type (*mem) args;\n";
     print C "#define VVAR(type,name,mem)       type (*mem);\n";
     print C "#include \"$fdef\"\n";
     print C "#undef VFUNC\n";
     print C "#undef VVAR\n";
     print C "} ${name}tab;\n";
     print C "extern ${name}tab *${name}ptr;\n";
     print C "extern ${name}tab *${name}Get _ANSI_ARGS_((void));\n";
     print C "#endif /* ${gard}_VT */\n";
     close(C);
    }
     
   my $cfile = $hfile;
   $cfile =~ s/\..*$/_f.c/;
   unless (-r $cfile)
    {
     openRO(\*C,$cfile) || die "Cannot open $cfile:$!";
     print C "#include \"$hfile\"\n";
     print C "#include \"$htfile\"\n";
     print C "static ${name}tab ${name}table =\n{\n";
     print C "#define VFUNC(type,name,mem,args) name,\n";
     print C "#define VVAR(type,name,mem)      &name,\n";
     print C "#include \"$fdef\"\n";
     print C "#undef VFUNC\n";
     print C "#undef VVAR\n";
     print C "};\n";
     print C "${name}tab *${name}ptr;\n";
     print C "${name}tab *${name}Get() { return ${name}ptr = &${name}table;}\n";
     close(C);
    }

   print STDERR "$gard\n";                              
   openRO(\*VFUNC,$fdef)   || die "Cannot open $fdef:$!";
   openRO(\*VMACRO,$mdef)  || die "Cannot open $mdef:$!";
   print VFUNC  "#ifdef _$gard\n";                       
   print VMACRO "#ifndef _${gard}_VM\n";
   print VMACRO "#define _${gard}_VM\n";
   print VMACRO "#include \"$htfile\"\n"; 
   print VMACRO "#ifndef NO_VTABLES\n";
   print VMACRO $xexcl if %WinIgnore;
   print VFUNC  $xexcl if %WinIgnore;
   foreach my $func (sort keys %VVar)                     
    {                                                   
     if (!exists($Exclude{$func}) && !exists($Ignore{$func}))                       
      {                                                 
       print VFUNC $VVar{$func};                     
       print VMACRO "#define $func (*${name}ptr->V_$func)\n";
      }                
     $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
    }                                                   
   foreach my $func (sort keys %VFunc)                     
    {                                                   
     if (!exists($Exclude{$func}) && !exists($Ignore{$func}))                       
      {                                                 
       print VFUNC "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});  
       print VFUNC "#ifndef $func\n";  
       print VFUNC $VFunc{$func};                     
       print VFUNC "#endif\n";
       print VFUNC "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});  
       print VFUNC "\n";

       print VMACRO "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});  
       print VMACRO "#ifndef $func\n";  
       print VMACRO "#  define $func (*${name}ptr->V_$func)\n";
       print VMACRO "#endif\n";
       print VMACRO "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});  
       print VMACRO "\n";
      }                                                 
     $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
    }                                                   
   print VMACRO "#endif /* NO_VTABLES */\n";
   print VMACRO "#endif /* _${gard}_VM */\n";
   close(VMACRO);                                       
   print VFUNC  "#endif /* _$gard */\n";                 
   close(VFUNC); # Close this last - Makefile dependancy

   unlink($mdef) unless $opt{'m'};
   unlink($fdef) unless $opt{'t'};
  }
}

foreach (<tk*Tab.c>)
 {
  Exclude($_);
 }   

die "Usage: $0 <some.h>\n" if (@ARGV != 1);

my $h = shift;
my $x = $h;
$x =~ s/\.h/.exc/;
Ignore($x) if (-f $x);
$x =~ s/\.exc/.excwin/;
WinIgnore($x) if (-f $x);
Vfunc($h);

foreach my $s (sort keys %Ignore)
 {
  warn "$s is not in $h\n";
  $oops++;
 }  
          
if ($oops)
 {
  $x = $h;   
  $x =~ s/\.h/.exc/;                    
  rename($x,"$x.old") || die "Cannot rename $x to $x.old:$!";
  open(EXC,">$x") || die "Cannot open $x:$!";
  foreach my $s (sort keys %Ignored)
   {         
    print EXC $s,"\n";
   }                  
  close(EXC);
 }

__END__

=head1 NAME

mkVFunc - Support for "nested" dynamic loading

=head1 SYNOPSIS

 mkVFunc xxx.h  

=head1 DESCRIPTION

B<perl/Tk> is designed so that B<Tk> can be dynamically loaded 'on top of'
perl. That is the easy bit. What it also does is allow Tk::Xxxx to be
dynamically loaded 'on top of' the B<perl/Tk> composite. Thus when 
you 'require Tk::HList' the shared object F<.../HList.so> needs to be 
able to call functions defined in perl I<and> functions defined in loadable
.../Tk.so . Now functions in 'base executable' are a well known problem,
and are solved by DynaLoader. However most of dynamic loading schemes 
cannot handle one loadable calling another loadable.

Thus what Tk does is build a table of functions that should be callable.
This table is auto-generated from the .h file by looking for 
'extern' (and EXTERN which is #defined to 'extern'). 
Thus any function marked as 'extern' is 'referenced' by the table.
The address of the table is then stored in a perl variable when Tk is loaded.
When HList is loaded it looks in the perl variable (via functions
in perl - the 'base executable') to get the address of the table.

The same utility that builds the table also builds a set of #define's.
HList.c (and any other .c files which comprise HList) #include these
#define's. So that 

  Tk_SomeFunc(x,y,z)

Is actually compiled as 

  (*TkVptr->V_Tk_SomeFunc)(x,y,z)

Where Tk_ptr is pointer to the table.

See:

 Tk-b*/pTk/mkVFunc - perl script that produces tables
          /tk.h        - basis from which table is generated
          /tk.m        - #define's to include in sub-extension
          /tk_f.h      - #included both sides.
          /tk_f.c      - Actual table definition.
          /tk.t        - 'shared' set of macros which produce table
                         included in tk_f.c and tk_f.h
          /tkVMacro.h  - Wrapper to include *.m files

In addition to /tk* there are /tkInt*, /Lang* and /tix*

=cut
Commit	Line	Data
86530b38 AT	1	#!/usr/local/bin/perl -w
	2	use strict;
	3
	4	my %Ignore;
	5	my %Ignored;
	6	my %WinIgnore;
	7	my %Exclude;
	8
	9	my $oops = 0;
	10
	11	use Getopt::Std;
	12	my %opt;
	13	getopts('mt',\%opt);
	14	my @Files;
	15
	16	sub openRO
	17	{
	18	my ($fh,$file) = @_;
	19	if (-f $file && !-w $file)
	20	{
	21	chmod(0666,$file) \|\| warn "Cannot change permissions on $file:$!";
	22	}
	23	open($fh,">$file") \|\| return 0;
	24	push(@Files,$file);
	25	return 1;
	26	}
	27
	28	END
	29	{
	30	while (@Files)
	31	{
	32	my $file = pop(@Files);
	33	if (-f $file)
	34	{
	35	chmod(0444,$file) \|\| warn "Cannot change permissions on $file:$!";
	36	}
	37	}
	38	}
	39
	40	my $win_arch = shift;
	41	die "Unknown \$win_arch" unless $win_arch eq 'open32'
	42	or $win_arch eq 'pm'
	43	or $win_arch eq 'x'
	44	or $win_arch eq 'MSWin32';
	45	my $xexcl = <<EOM;
	46	#if (defined(__WIN32__) \|\| defined(__PM__)) && !defined(DO_X_EXCLUDE)
	47	# define DO_X_EXCLUDE
	48	#endif
	49	EOM
	50
	51	sub Ignore
	52	{
	53	my $cfile = shift;
	54	if (open(C,"<$cfile"))
	55	{
	56	while (<C>)
	57	{
	58	if (/^([A-Za-z][A-Za-z0-9_]*)/)
	59	{
	60	$Ignore{$1} = $cfile;
	61	}
	62	}
	63	close(C);
	64	}
65	else
66	{
67	warn "Cannot open $cfile:$!";
68	}
69	}
70
71	sub WinIgnore
72	{
73	my $cfile = shift;
74	if (open(C,"<$cfile"))
75	{
76	while (<C>)
77	{
78	if (/^([A-Za-z][A-Za-z0-9_]*)/)
79	{
80	$WinIgnore{$1} = $cfile;
81	}
82	}
83	close(C);
84	}
85	else
86	{
87	warn "Cannot open $cfile:$!";
88	}
89	}
90
91	sub Exclude
92	{
93	my $cfile = shift;
94	if (open(C,"<$cfile"))
95	{
96	while (<C>)
97	{
98	if (/{\s\"[^\"]+\"\s,\s(\w+)\s}/)
99	{
100	$Exclude{$1} = $cfile;
101	}
102	}
103	close(C);
104	}
105	else
106	{
107	warn "Cannot open $cfile:$!";
108	}
109	}
110
111	sub Vfunc
112	{
113	my $hfile = shift;
114	my %VFunc = ();
115	my %VVar = ();
116	my %VError= ();
117	open(H,"<$hfile") \|\| die "Cannot open $hfile:$!";
118
119	while (<H>)
120	{
121	if (/^\s(MOVEXT\|COREXT\|EXTERN\|extern)\s(.?)\s(\w+)\s+_ANSI_ARGS_\s*\((TCL_VARARGS)?\(/)
122	{
123	my ($type,$name,$op) = ($2,$3,$4);
124	if ($1 eq 'MOVEXT' \|\| $1 eq 'COREXT')
125	{
126	warn "$1 $name\n";
127	$oops++;
128	$Ignore{$name} = $hfile;
129	}
130	$op = "" unless (defined $op);
131	my $defn = "VFUNC($type,$name,V_$name,_ANSI_ARGS_($op(";
132	$_ = $';
133	until (/\)\);\s*$/)
134	{
135	$defn .= $_;
136	$_ = <H>;
137	if (/^\S/)
138	{
139	chomp($_);
140	die $_;
141	}
142	}
143	s/\)\);\s*$/\)\)\)\n/;
144	$defn .= $_;
145	$VFunc{$name} = $defn;
146	}
147	elsif (/^\s(MOVEXT\|COREXT\|EXTERN\|extern)\s(.?)\s(\w+)\s*;/)
148	{
149	my ($type,$name) = ($2,$3);
150	if ($1 eq 'MOVEXT' \|\| $1 eq 'COREXT')
151	{
152	warn "$1 $name\n";
153	$oops++;
154	$Ignore{$name} = $hfile;
155	}
156	$VVar{$name} = "VVAR($type,$name,V_$name)\n";
157	}
158	elsif (/\b(EXTERN\|extern)\s+[\w_]+\s+[\w_]+\[\];$/)
159	{
160
161	}
162	elsif (/\b(EXTERN\|extern)\s"C"\s\{\s*$/)
163	{
164
165	}
166	elsif (/\b(EXTERN\|extern)\b/)
167	{
168	warn "$hfile:$.: $_" unless (/^\s\#\sdefine/);
169	}
170	}
171	close(H);
172
173
174	if (keys %VFunc \|\| keys %VVar)
175	{
176	my $gard = "\U$hfile";
177	$gard =~ s/\..*$//;
178	$gard =~ s#/#_#g;
179	my $name = "\u\L${gard}\UV";
180	my $fdef = $hfile;
181	$fdef =~ s/\..*$/.t/;
182	my $mdef = $hfile;
183	$mdef =~ s/\..*$/.m/;
184
185	$mdef .= 'dmy' unless $opt{'m'};
186	$fdef .= 'dmy' unless $opt{'t'};
187
188	my $htfile = $hfile;
189	$htfile =~ s/\..*$/_f.h/;
190	unless (-r $htfile)
191	{
192	openRO(\*C,$htfile) \|\| die "Cannot open $htfile:$!";
193	print C "#ifndef ${gard}_VT\n";
194	print C "#define ${gard}_VT\n";
195	print C "typedef struct ${name}tab\n{\n";
196	print C "#define VFUNC(type,name,mem,args) type (*mem) args;\n";
197	print C "#define VVAR(type,name,mem) type (*mem);\n";
198	print C "#include \"$fdef\"\n";
199	print C "#undef VFUNC\n";
200	print C "#undef VVAR\n";
201	print C "} ${name}tab;\n";
202	print C "extern ${name}tab *${name}ptr;\n";
203	print C "extern ${name}tab *${name}Get _ANSI_ARGS_((void));\n";
204	print C "#endif /* ${gard}_VT */\n";
205	close(C);
206	}
207
208	my $cfile = $hfile;
209	$cfile =~ s/\..*$/_f.c/;
210	unless (-r $cfile)
211	{
212	openRO(\*C,$cfile) \|\| die "Cannot open $cfile:$!";
213	print C "#include \"$hfile\"\n";
214	print C "#include \"$htfile\"\n";
215	print C "static ${name}tab ${name}table =\n{\n";
216	print C "#define VFUNC(type,name,mem,args) name,\n";
217	print C "#define VVAR(type,name,mem) &name,\n";
218	print C "#include \"$fdef\"\n";
219	print C "#undef VFUNC\n";
220	print C "#undef VVAR\n";
221	print C "};\n";
222	print C "${name}tab *${name}ptr;\n";
223	print C "${name}tab *${name}Get() { return ${name}ptr = &${name}table;}\n";
224	close(C);
225	}
226
227	print STDERR "$gard\n";
228	openRO(\*VFUNC,$fdef) \|\| die "Cannot open $fdef:$!";
229	openRO(\*VMACRO,$mdef) \|\| die "Cannot open $mdef:$!";
230	print VFUNC "#ifdef _$gard\n";
231	print VMACRO "#ifndef _${gard}_VM\n";
232	print VMACRO "#define _${gard}_VM\n";
233	print VMACRO "#include \"$htfile\"\n";
234	print VMACRO "#ifndef NO_VTABLES\n";
235	print VMACRO $xexcl if %WinIgnore;
236	print VFUNC $xexcl if %WinIgnore;
237	foreach my $func (sort keys %VVar)
238	{
239	if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
240	{
241	print VFUNC $VVar{$func};
242	print VMACRO "#define $func (*${name}ptr->V_$func)\n";
243	}
244	$Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
245	}
246	foreach my $func (sort keys %VFunc)
247	{
248	if (!exists($Exclude{$func}) && !exists($Ignore{$func}))
249	{
250	print VFUNC "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
251	print VFUNC "#ifndef $func\n";
252	print VFUNC $VFunc{$func};
253	print VFUNC "#endif\n";
254	print VFUNC "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
255	print VFUNC "\n";
256
257	print VMACRO "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});
258	print VMACRO "#ifndef $func\n";
259	print VMACRO "# define $func (*${name}ptr->V_$func)\n";
260	print VMACRO "#endif\n";
261	print VMACRO "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});
262	print VMACRO "\n";
263	}
264	$Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
265	}
266	print VMACRO "#endif /* NO_VTABLES */\n";
267	print VMACRO "#endif /* _${gard}_VM */\n";
268	close(VMACRO);
269	print VFUNC "#endif /* _$gard */\n";
270	close(VFUNC); # Close this last - Makefile dependancy
271
272	unlink($mdef) unless $opt{'m'};
273	unlink($fdef) unless $opt{'t'};
274	}
275	}
276
277	foreach (<tk*Tab.c>)
278	{
279	Exclude($_);
280	}
281
282	die "Usage: $0 <some.h>\n" if (@ARGV != 1);
283
284	my $h = shift;
285	my $x = $h;
286	$x =~ s/\.h/.exc/;
287	Ignore($x) if (-f $x);
288	$x =~ s/\.exc/.excwin/;
289	WinIgnore($x) if (-f $x);
290	Vfunc($h);
291
292	foreach my $s (sort keys %Ignore)
293	{
294	warn "$s is not in $h\n";
295	$oops++;
296	}
297
298	if ($oops)
299	{
300	$x = $h;
301	$x =~ s/\.h/.exc/;
302	rename($x,"$x.old") \|\| die "Cannot rename $x to $x.old:$!";
303	open(EXC,">$x") \|\| die "Cannot open $x:$!";
304	foreach my $s (sort keys %Ignored)
305	{
306	print EXC $s,"\n";
307	}
308	close(EXC);
309	}
310
311	__END__
312
313	=head1 NAME
314
315	mkVFunc - Support for "nested" dynamic loading
316
317	=head1 SYNOPSIS
318
319	mkVFunc xxx.h
320
321	=head1 DESCRIPTION
322
323	B<perl/Tk> is designed so that B<Tk> can be dynamically loaded 'on top of'
324	perl. That is the easy bit. What it also does is allow Tk::Xxxx to be
325	dynamically loaded 'on top of' the B<perl/Tk> composite. Thus when
326	you 'require Tk::HList' the shared object F<.../HList.so> needs to be
327	able to call functions defined in perl I<and> functions defined in loadable
328	.../Tk.so . Now functions in 'base executable' are a well known problem,
329	and are solved by DynaLoader. However most of dynamic loading schemes
330	cannot handle one loadable calling another loadable.
331
332	Thus what Tk does is build a table of functions that should be callable.
333	This table is auto-generated from the .h file by looking for
334	'extern' (and EXTERN which is #defined to 'extern').
335	Thus any function marked as 'extern' is 'referenced' by the table.
336	The address of the table is then stored in a perl variable when Tk is loaded.
337	When HList is loaded it looks in the perl variable (via functions
338	in perl - the 'base executable') to get the address of the table.
339
340	The same utility that builds the table also builds a set of #define's.
341	HList.c (and any other .c files which comprise HList) #include these
342	#define's. So that
343
344	Tk_SomeFunc(x,y,z)
345
346	Is actually compiled as
347
348	(*TkVptr->V_Tk_SomeFunc)(x,y,z)
349
350	Where Tk_ptr is pointer to the table.
351
352	See:
353
354	Tk-b*/pTk/mkVFunc - perl script that produces tables
355	/tk.h - basis from which table is generated
356	/tk.m - #define's to include in sub-extension
357	/tk_f.h - #included both sides.
358	/tk_f.c - Actual table definition.
359	/tk.t - 'shared' set of macros which produce table
360	included in tk_f.c and tk_f.h
361	/tkVMacro.h - Wrapper to include *.m files
362
363	In addition to /tk* there are /tkInt, /Lang and /tix*
364
365	=cut