| 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__ |