home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _4dde769415a0d06118fbc913130125e4 < prev    next >
Text File  |  2004-06-01  |  6KB  |  293 lines
  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 = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
  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]*)\s*\)//;
  45.  return exists($define{$1}) if s/^\s*defined\s*([_A-Za-z][_\w]*)//;
  46.  return eval "$1" if s/^\s*(0x[0-9a-f]+)//i;
  47.  return $1 if s/^\s*(\d+)//;
  48.  return $define{$1} || 0 if s/^\s*([_A-Za-z][_\w]*)//;
  49.  if (s/^\s*\(//)
  50.   {
  51.    my $val = expression(0);
  52.    warn "Missing ')'\n" unless s/^\s*\)//;
  53.    return $val;
  54.   }
  55.  warn "Invalid term:$_";
  56.  return undef;
  57. }
  58.  
  59. my %pri = ( '&&' => 4,
  60.             '||' => 3,
  61.             '>=' => 2, '<=' => 2, '<' => 2, '>' => 2,
  62.             '==' => 1, '!=' => 1  );
  63.  
  64. sub expression
  65. {
  66.  my $pri = shift;
  67.  # printf STDERR "%d# expr . $_\n";
  68.  my $invert = 0;
  69.  my $lhs = term() || 0;
  70.  remove_comment();
  71.  while (/^\s*(&&|\|\||>=?|<=?|==|!=)/)
  72.   {
  73.    my $op = $1;
  74.    last unless ($pri{$op} >= $pri);
  75.    s/^\s*\Q$op\E//;
  76.    # printf STDERR "%d# $lhs $op . $_\n";
  77.    my $rhs = expression($pri{$op}) || 0;
  78.    my $e = "$lhs $op $rhs";
  79.    $lhs = eval "$e" || 0;
  80.    die "'$e' $@"  if $@;
  81.    remove_comment();
  82.   }
  83.  return $lhs;
  84. }
  85.  
  86. sub do_if
  87. {
  88.  my ($key,$expr) = @_;
  89.  chomp($expr);
  90.  if ($key eq 'ifdef' || $key eq 'ifndef')
  91.   {
  92.    if ($expr =~ /^\s*(\w+)/)
  93.     {
  94.      my $val = exists $define{$1};
  95.      $val = !$val if ($key eq 'ifndef');
  96. #    printf STDERR "%d from $key $expr\n",$val;
  97.      return $val;
  98.     }
  99.   }
  100.  else
  101.   {
  102.    local $_ = $expr;
  103.    my $val = expression(0) != 0;
  104.    warn "trailing: $_" if /\S/;
  105.    #printf STDERR "%d from $key $expr\n",$val;
  106.    return $val;
  107.   }
  108. }
  109.  
  110. sub scan_file
  111. {
  112.  no strict 'refs';
  113.  my ($file,$dep) = @_;
  114.  open($file,"<$file") || die "Cannot open $file:$!";
  115.  local $_;
  116.  my ($srcdir) = $file =~ m#^(.*)[\\/][^\\/]*$#;
  117.  $srcdir = '.' unless defined $srcdir;
  118.  my $live = 1;
  119.  $dep->{$file} = 1;
  120.  my @stack;
  121.  while (<$file>)
  122.   {
  123.    $_ .= <$file> while (s/\\\n/ /);
  124.    if (/^\s*#\s*(\w+)\s*(.*?)\s*$/)
  125.     {
  126.      my $ol = $live;
  127.      my $key = $1;
  128.      my $rest = $2;
  129.      if ($key =~ /^if(.*)$/)
  130.       {
  131.        push(@stack,$live);
  132.        $live &&= do_if($key,$rest);
  133.       }
  134.      elsif ($key eq 'elif')
  135.       {
  136.        $live = ($live) ? 0 : $stack[-1];
  137.        $live &&= do_if('if',$rest);
  138.       }
  139.      elsif ($key eq 'else')
  140.       {
  141.        $live = ($live) ? 0 : $stack[-1];
  142.       }
  143.      elsif ($key eq 'endif')
  144.       {
  145.        if (@stack)
  146.         {
  147.          $live = pop(@stack);
  148.         }
  149.        else
  150.         {
  151.          die "$file:$.: Mismatched #endif\n";
  152.         }
  153.       }
  154.      elsif ($live)
  155.       {
  156.        if ($key eq 'include')
  157.         {
  158.          do_include($1,$dep,$srcdir,@include) if $rest =~ /^"(.*)"/;
  159.         }
  160.        elsif ($key eq 'define')
  161.         {
  162.          if ($rest =~ /^\s*([_A-Za-z][\w_]*)\s*(.*)$/)
  163.           {
  164.            my $sym = $1;
  165.            my $val = $2 || 1;
  166.            $val =~ s#\s*/\*.*?\*/\s*# #g;
  167.            $define{$sym} = $val;
  168.           }
  169.          else
  170.           {
  171.            warn "ignore '$key $rest'\n";
  172.           }
  173.         }
  174.        elsif ($key eq 'undef')
  175.         {
  176.          if ($rest =~ /^\s*([_A-Za-z][\w_]*)/)
  177.           {
  178.            delete $define{$1};
  179.           }
  180.         }
  181.        elsif ($key =~ /^(line|pragma)$/)
  182.         {
  183.  
  184.         }
  185.        else
  186.         {
  187.          warn "ignore '$key $rest'\n";
  188.         }
  189.       }
  190.      # printf STDERR "$file:$.: %d $key $rest\n",$live if ($ol != $live);
  191.     }
  192.    else
  193.     {
  194.      # print if $live;
  195.     }
  196.   }
  197.  close($file);
  198.  if (@stack)
  199.   {
  200.    warn "$file:$.: unclosed #if\n";
  201.   }
  202. }
  203.  
  204. sub command_line
  205. {
  206.  @include = ();
  207.  local %define = ('__STDC__' => 1 );
  208.  my $data = '';
  209.  my @files;
  210.  while (@_ && $_[-1] !~ /^-/)
  211.   {
  212.    unshift(@files,pop(@_));
  213.   }
  214.  my $flags = $Config{ccflags};
  215.  $flags =~ s/^\s+|\s+$//g;
  216.  my @opt = (@_, split(/\s+/,$flags));
  217.  while (@opt)
  218.   {
  219.    local $_ = shift(@opt);
  220.    if (/^-I(.*)$/)
  221.     {
  222.      push @include,$1;
  223.     }
  224.    elsif (/^-D([^=]+)(?:=(.*))?$/)
  225.     {
  226.      $define{$1} = $2 || 1;
  227.     }
  228.    elsif (/^-U(.*)$/)
  229.     {
  230.      delete $define{$1};
  231.     }
  232.    elsif (/^(-.*)$/)
  233.     {
  234.      # Some option
  235.      if ($opt[0] !~ /^-/)
  236.       {
  237.        # next arg does not start with '-' assume it
  238.        # belongs to this option and discard it silently
  239.        shift(@opt);
  240.       }
  241.     }
  242.    else
  243.     {
  244.      # We got confused
  245.      warn "Ignoring $1\n";
  246.     }
  247.   }
  248.  # force /usr/include to be last element of @include
  249.  push @include, $Config{'usrinc'}
  250.    if (defined $Config{'usrinc'} and $Config{'usrinc'} ne '');
  251.  # warn "Include:@include\n";
  252.  while (@files)
  253.   {
  254.    local $_ = shift(@files);
  255.    unless (/^(.*)\.[^\.]+$/)
  256.     {
  257.      warn "Skip $_";
  258.      next;
  259.     }
  260.    local %define = %define;
  261.    my $base = $1;
  262.    my $file = $_;
  263.    my %dep;
  264.    warn "Finding dependencies for $file\n";
  265.    scan_file($_,\%dep);
  266.    my $str = "\n$base\$(OBJ_EXT) : $base.c";
  267.    delete $dep{$file};
  268.    my @dep = (sort(keys %dep));
  269.    while (@dep)
  270.     {
  271.      my $dep = shift(@dep);
  272.      $dep =~ s#^\./##;
  273.      if (length($str)+length($dep) > 70)
  274.       {
  275.        $data .= "$str \\\n";
  276.        $str = ' ';
  277.       }
  278.      else
  279.       {
  280.        $str .= ' ';
  281.       }
  282.      $str .= $dep;
  283.     }
  284.    $data .= "$str\n";
  285.   }
  286.  return $data;
  287. }
  288.  
  289. 1;
  290. __END__
  291.  
  292.  
  293.