Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::MakeDepend; |
2 | use strict; | |
3 | use vars qw(%define); | |
4 | use Config; | |
5 | ||
6 | my @include; | |
7 | ||
8 | use Carp; | |
9 | ||
10 | # $SIG{__DIE__} = \&Carp::confess; | |
11 | ||
12 | ||
13 | use vars qw($VERSION); | |
14 | $VERSION = '3.017'; # $Id: //depot/Tk8/Tk/MakeDepend.pm#17 $ | |
15 | ||
16 | sub scan_file; | |
17 | ||
18 | sub do_include | |
19 | { | |
20 | my ($inc,$dep,@include) = @_; | |
21 | foreach my $dir (@include) | |
22 | { | |
23 | my $path = "$dir/$inc"; | |
24 | if (-f $path) | |
25 | { | |
26 | scan_file($path,$dep) unless exists $dep->{$path}; | |
27 | return; | |
28 | } | |
29 | } | |
30 | warn "Cannot find '$inc' assume made\n"; | |
31 | $dep->{$inc} = 1; | |
32 | } | |
33 | ||
34 | sub remove_comment | |
35 | { | |
36 | s#^\s*/\*.*?\*/\s*##g; | |
37 | } | |
38 | ||
39 | ||
40 | sub term | |
41 | { | |
42 | remove_comment(); | |
43 | return !term() if s/^\s*!//; | |
44 | return exists($define{$1}) if s/^\s*defined\s*\(([_A-Za-z][_\w]*)\)//; | |
45 | return $1 if s/^\s*(\d+)//; | |
46 | return $define{$1} || 0 if s/^\s*([_A-Za-z][_\w]*)//; | |
47 | if (s/^\s*\(//) | |
48 | { | |
49 | my $val = expression(0); | |
50 | warn "Missing ')'\n" unless s/^\s*\)//; | |
51 | return $val; | |
52 | } | |
53 | warn "Invalid term:$_"; | |
54 | return undef; | |
55 | } | |
56 | ||
57 | my %pri = ( '&&' => 4, | |
58 | '||' => 3, | |
59 | '>=' => 2, '<=' => 2, '<' => 2, '>' => 2, | |
60 | '==' => 1, '!=' => 1 ); | |
61 | ||
62 | sub expression | |
63 | { | |
64 | my $pri = shift; | |
65 | #printf STDERR "%d# expr . $_\n"; | |
66 | my $invert = 0; | |
67 | my $lhs = term() || 0; | |
68 | remove_comment(); | |
69 | while (/^\s*(&&|\|\||>=?|<=?|==|!=)/) | |
70 | { | |
71 | my $op = $1; | |
72 | last unless ($pri{$op} >= $pri); | |
73 | s/^\s*\Q$op\E//; | |
74 | # printf STDERR "%d# $lhs $op . $_\n"; | |
75 | my $rhs = expression($pri{$op}) || 0; | |
76 | my $e = "$lhs $op $rhs"; | |
77 | $lhs = eval "$e" || 0; | |
78 | die "'$e' $@" if $@; | |
79 | remove_comment(); | |
80 | } | |
81 | return $lhs; | |
82 | } | |
83 | ||
84 | sub do_if | |
85 | { | |
86 | my ($key,$expr) = @_; | |
87 | chomp($expr); | |
88 | if ($key eq 'ifdef' || $key eq 'ifndef') | |
89 | { | |
90 | if ($expr =~ /^\s*(\w+)/) | |
91 | { | |
92 | my $val = exists $define{$1}; | |
93 | $val = !$val if ($key eq 'ifndef'); | |
94 | # printf STDERR "%d from $key $expr\n",$val; | |
95 | return $val; | |
96 | } | |
97 | } | |
98 | else | |
99 | { | |
100 | local $_ = $expr; | |
101 | my $val = expression(0) != 0; | |
102 | warn "trailing: $_" if /\S/; | |
103 | # printf STDERR "%d from $key $expr\n",$val; | |
104 | return $val; | |
105 | } | |
106 | } | |
107 | ||
108 | sub scan_file | |
109 | { | |
110 | no strict 'refs'; | |
111 | my ($file,$dep) = @_; | |
112 | open($file,"<$file") || die "Cannot open $file:$!"; | |
113 | local $_; | |
114 | my ($srcdir) = $file =~ m#^(.*)[\\/][^\\/]*$#; | |
115 | $srcdir = '.' unless defined $srcdir; | |
116 | my $live = 1; | |
117 | $dep->{$file} = 1; | |
118 | my @stack; | |
119 | while (<$file>) | |
120 | { | |
121 | $_ .= <$file> while (s/\\\n/ /); | |
122 | if (/^\s*#\s*(\w+)\s*(.*?)\s*$/) | |
123 | { | |
124 | my $ol = $live; | |
125 | my $key = $1; | |
126 | my $rest = $2; | |
127 | if ($key =~ /^if(.*)$/) | |
128 | { | |
129 | push(@stack,$live); | |
130 | $live = do_if($key,$rest); | |
131 | } | |
132 | elsif ($key eq 'else') | |
133 | { | |
134 | $live = ($live) ? 0 : $stack[-1]; | |
135 | } | |
136 | elsif ($key eq 'endif') | |
137 | { | |
138 | if (@stack) | |
139 | { | |
140 | $live = pop(@stack); | |
141 | } | |
142 | else | |
143 | { | |
144 | die "$file:$.: Mismatched #endif\n"; | |
145 | } | |
146 | } | |
147 | elsif ($live) | |
148 | { | |
149 | if ($key eq 'include') | |
150 | { | |
151 | do_include($1,$dep,$srcdir,@include) if $rest =~ /^"(.*)"/; | |
152 | } | |
153 | elsif ($key eq 'define') | |
154 | { | |
155 | if ($rest =~ /^\s*([_A-Za-z][\w_]*)\s*(.*)$/) | |
156 | { | |
157 | my $sym = $1; | |
158 | my $val = $2 || 1; | |
159 | $val =~ s#\s*/\*.*?\*/\s*# #g; | |
160 | $define{$sym} = $val; | |
161 | } | |
162 | else | |
163 | { | |
164 | warn "ignore '$key $rest'\n"; | |
165 | } | |
166 | } | |
167 | elsif ($key eq 'undef') | |
168 | { | |
169 | if ($rest =~ /^\s*([_A-Za-z][\w_]*)/) | |
170 | { | |
171 | delete $define{$1}; | |
172 | } | |
173 | } | |
174 | elsif ($key =~ /^(line|pragma)$/) | |
175 | { | |
176 | ||
177 | } | |
178 | else | |
179 | { | |
180 | warn "ignore '$key $rest'\n"; | |
181 | } | |
182 | } | |
183 | # printf STDERR "$file:$.: %d $key $rest\n",$live if ($ol != $live); | |
184 | } | |
185 | else | |
186 | { | |
187 | # print if $live; | |
188 | } | |
189 | } | |
190 | close($file); | |
191 | if (@stack) | |
192 | { | |
193 | warn "$file:$.: unclosed #if\n"; | |
194 | } | |
195 | } | |
196 | ||
197 | sub reset_includes | |
198 | { | |
199 | undef @include; | |
200 | push @include, $Config{'usrinc'} | |
201 | if (defined $Config{'usrinc'} and $Config{'usrinc'} ne ''); | |
202 | } | |
203 | ||
204 | sub command_line | |
205 | { | |
206 | reset_includes(); | |
207 | my %def = ('__STDC__' => 1 ); | |
208 | my $data = ''; | |
209 | while (@_) | |
210 | { | |
211 | $_ = shift(@_); | |
212 | if (/^-I(.*)$/) | |
213 | { | |
214 | # force /usr/include to be last element of @include | |
215 | if (@include) | |
216 | { | |
217 | splice @include, $#include, 0, $1; | |
218 | } | |
219 | else | |
220 | { | |
221 | @include = ($1); | |
222 | } | |
223 | } | |
224 | elsif (/^-D([^=]+)(?:=(.*))?$/) | |
225 | { | |
226 | $def{$1} = $2 || 1; | |
227 | } | |
228 | elsif (/^-U(.*)$/) | |
229 | { | |
230 | delete $def{$1}; | |
231 | } | |
232 | elsif (/^(-.*)$/) | |
233 | { | |
234 | warn "Ignoring $1\n"; | |
235 | } | |
236 | elsif (/^(.*)\.[^\.]+$/) | |
237 | { | |
238 | local %define = %def; | |
239 | my $base = $1; | |
240 | my $file = $_; | |
241 | my %dep; | |
242 | warn "Finding dependancies for $file\n"; | |
243 | scan_file($_,\%dep); | |
244 | my $str = "\n$base\$(OBJ_EXT) : $base.c"; | |
245 | delete $dep{$file}; | |
246 | my @dep = (sort(keys %dep)); | |
247 | while (@dep) | |
248 | { | |
249 | my $dep = shift(@dep); | |
250 | $dep =~ s#^\./##; | |
251 | if (length($str)+length($dep) > 70) | |
252 | { | |
253 | $data .= "$str \\\n"; | |
254 | $str = ' '; | |
255 | } | |
256 | else | |
257 | { | |
258 | $str .= ' '; | |
259 | } | |
260 | $str .= $dep; | |
261 | } | |
262 | $data .= "$str\n"; | |
263 | } | |
264 | } | |
265 | return $data; | |
266 | } | |
267 | ||
268 | 1; | |
269 | __END__ |