home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / lib / zip / Make.pm < prev    next >
Text File  |  1999-04-05  |  27KB  |  1,294 lines
  1. package Make::Rule::Vars;
  2. use Carp;
  3. use strict;
  4.  
  5. # Package to handle 'magic' variables pertaining to rules e.g. $@ $* $^ $?
  6. # by using tie to this package 'subsvars' can work with array of 
  7. # hash references to possible sources of variable definitions.
  8.  
  9. sub TIEHASH
  10. {
  11.  my ($class,$rule) = @_;
  12.  return bless \$rule,$class;
  13. }
  14.  
  15. sub FETCH
  16. {
  17.  my $self = shift;
  18.  local $_ = shift;
  19.  my $rule = $$self;
  20.  return undef unless (/^[\@^<?*]$/);
  21.  # print STDERR "FETCH $_ for ",$rule->Name,"\n";
  22.  return $rule->Name if ($_ eq '@');
  23.  return $rule->Base if ($_ eq '*');
  24.  return join(' ',$rule->exp_depend)  if ($_ eq '^');
  25.  return join(' ',$rule->out_of_date) if ($_ eq '?');
  26.  # Next one is dubious - I think $< is really more subtle ...
  27.  return ($rule->exp_depend)[0] if ($_ eq '<');
  28.  return undef;
  29. }
  30.  
  31. package Make::Rule;
  32. use Carp;
  33. use strict;
  34.  
  35. # Bottom level 'rule' package 
  36. # An instance exists for each ':' or '::' rule in the makefile.
  37. # The commands and dependancies are kept here.
  38.  
  39. sub target
  40. {
  41.  return shift->{TARGET};
  42. }
  43.  
  44. sub Name
  45. {
  46.  return shift->target->Name;
  47. }
  48.  
  49. sub Base
  50. {
  51.  my $name = shift->target->Name;
  52.  $name =~ s/\.[^.]+$//;
  53.  return $name;
  54. }
  55.  
  56. sub Info
  57. {
  58.  return shift->target->Info;
  59. }
  60.  
  61. sub depend
  62. {
  63.  my $self = shift;
  64.  if (@_)
  65.   {
  66.    my $dep = shift;
  67.    confess "dependants $dep are not an array reference" unless ('ARRAY' eq ref $dep); 
  68.    my $file;
  69.    foreach $file (@$dep)
  70.     {
  71.      unless (exists $self->{DEPHASH}{$file})
  72.       {
  73.        $self->{DEPHASH}{$file} = 1;
  74.        push(@{$self->{DEPEND}},$file);
  75.       }
  76.     }
  77.   }
  78.  return (wantarray) ? @{$self->{DEPEND}} : $self->{DEPEND};
  79. }
  80.  
  81. sub command
  82. {
  83.  my $self = shift;
  84.  if (@_)
  85.   {
  86.    my $cmd = shift;
  87.    confess "commands $cmd are not an array reference" unless ('ARRAY' eq ref $cmd); 
  88.    if (@$cmd)
  89.     {
  90.      if (@{$self->{COMMAND}})
  91.       {
  92.        warn "Command for ".$self->Name," redefined";
  93.        print STDERR "Was:",join("\n",@{$self->{COMMAND}}),"\n";
  94.        print STDERR "Now:",join("\n",@$cmd),"\n";
  95.       }
  96.      $self->{COMMAND} = $cmd;
  97.     }
  98.    else
  99.     {
  100.      if (@{$self->{COMMAND}})
  101.       { 
  102.        # warn "Command for ".$self->Name," retained";
  103.        # print STDERR "Was:",join("\n",@{$self->{COMMAND}}),"\n";
  104.       }
  105.     } 
  106.   }
  107.  return (wantarray) ? @{$self->{COMMAND}} : $self->{COMMAND};
  108. }
  109.  
  110. #
  111. # The key make test - is target out-of-date as far as this rule is concerned
  112. # In scalar context - boolean value of 'do we need to apply the rule'
  113. # In list context the things we are out-of-date with e.g. magic $? variable
  114. #
  115. sub out_of_date
  116. {
  117.  my $self  = shift;
  118.  my $info  = $self->Info;
  119.  my @dep = ();
  120.  my $tdate  = $self->target->date;
  121.  my $dep;
  122.  my $count = 0;
  123.  foreach $dep ($self->exp_depend)
  124.   {
  125.    my $date = $info->date($dep);
  126.    $count++;
  127.    if (!defined($date) || !defined($tdate) || $date < $tdate)
  128.     {
  129.      push(@dep,$dep);
  130.     }
  131.   }
  132.  # Note special case of no dependencies means it is always  out-of-date!
  133.  return (wantarray) ? @dep : (!$count || @dep);
  134. }
  135.  
  136. #
  137. # Return list of things rule depends on with variables expanded
  138. # - May need pathname and vpath processing as well
  139. #
  140. sub exp_depend
  141. {
  142.  my $self = shift;
  143.  my $info = $self->Info;
  144.  my @dep = map(split(/\s+/,$info->subsvars($_)),$self->depend);
  145.  return (wantarray) ? @dep : \@dep;
  146. }
  147.  
  148. #
  149. # Return commands to apply rule with variables expanded
  150. # - No pathname processing needed, commands should always chdir()
  151. #   to logical place (at least till we get very clever at bourne shell parsing).
  152. # - May need vpath processing
  153. #
  154. sub exp_command
  155. {
  156.  my $self   = shift;
  157.  my $info   = $self->Info;
  158.  my $base   = $self->Name;
  159.  my %var;
  160.  tie %var,'Make::Rule::Vars',$self;
  161.  my @cmd  = map($info->subsvars($_,\%var),$self->command);
  162.  return (wantarray) ? @cmd : \@cmd;
  163. }
  164.  
  165. #
  166. # clone creates a new rule derived from an existing rule, but 
  167. # with a different target. Used when left hand side was a variable.
  168. # perhaps should be used for dot/pattern rule processing too.
  169. #
  170. sub clone
  171. {
  172.  my ($self,$target) = @_;
  173.  my %hash = %$self;
  174.  $hash{TARGET} = $target;
  175.  return bless \%hash,ref $self;
  176. }
  177.  
  178. sub new
  179. {
  180.  my $class = shift;
  181.  my $target = shift;
  182.  my $kind   = shift;
  183.  # return shift->clone($target) if (@_ == 1);
  184.  my $self = bless { TARGET => $target,             # parent target (left hand side)
  185.                     KIND => $kind,                 # : or ::
  186.                     DEPEND => [], DEPHASH => {},   # right hand args
  187.                     COMMAND => []                  # command(s)  
  188.                   },$class;        
  189.  $self->depend(shift) if (@_);
  190.  $self->command(shift) if (@_);
  191.  return $self;
  192. }
  193.  
  194. #
  195. # This code has to go somewhere but no good home obvious yet.
  196. #  - only applies to ':' rules, but needs top level database
  197. #  - perhaps in ->commands of derived ':' class?
  198. #
  199. sub find_commands
  200. {
  201.  my ($self) = @_;
  202.  if (!@{$self->{COMMAND}} && @{$self->{DEPEND}})
  203.   {
  204.    my $info = $self->Info;
  205.    my $name = $self->Name;
  206.    my @dep  = $self->depend;
  207.    my @rule = $info->patrule($self->Name);
  208.    if (@rule)
  209.     {
  210.      $self->depend($rule[0]);
  211.      $self->command($rule[1]);
  212.     }
  213.   }
  214. }
  215.  
  216. #
  217. # Spew a shell script to perfom the 'make' e.g. make -n 
  218. #
  219. sub Script
  220. {
  221.  my $self = shift;
  222.  return unless $self->out_of_date;
  223.  my @cmd = $self->exp_command;
  224.  if (@cmd)
  225.   {
  226.    my $file;
  227.   my $com = ($^O eq 'MSWin32') ? 'rem ': ($^O eq 'riscos') ? '| ' : '# ';
  228.    print  $com,$self->Name,"\n";
  229.    foreach $file ($self->exp_command)
  230.     {
  231.      $file =~ s/^[\@\s-]*//;
  232.      print "$file\n";
  233.     }
  234.   }
  235. }
  236.  
  237. #
  238. # Normal 'make' method
  239. #
  240. sub Make
  241. {
  242.  my $self = shift;
  243.  my $file;
  244.  return unless $self->out_of_date;
  245.  my @cmd = $self->exp_command;
  246.  my $info = $self->Info;
  247.  if (@cmd)
  248.   {
  249.    # print "# ",$self->Name,"\n";
  250.    foreach my $file ($self->exp_command)
  251.     {
  252.      $file =~ s/^([\@\s-]*)//;
  253.      my $prefix = $1;
  254.      print  "$file\n" unless ($prefix =~ /\@/);
  255.      my $code = $info->exec($file);
  256.      if ($code && $prefix !~ /-/)
  257.       {
  258.        die "Code $code from $file";
  259.       }
  260.     }
  261.   }
  262. }
  263.  
  264. #
  265. # Print rule out in makefile syntax 
  266. # - currently has variables expanded as debugging aid.
  267. # - will eventually become make -p 
  268. # - may be useful for writing makefiles from MakeMaker too...
  269. #
  270. sub Print
  271. {
  272.  my $self = shift;
  273.  my $file;
  274.  print $self->Name,' ',$self->{KIND},' ';
  275.  foreach $file ($self->exp_depend)
  276.   {
  277.    print " \\\n   $file";
  278.   }
  279.  print "\n";
  280.  my @cmd = $self->exp_command;
  281.  if (@cmd)
  282.   {
  283.    foreach $file ($self->exp_command)
  284.     {
  285.      print "\t",$file,"\n";
  286.     }
  287.   }
  288.  else
  289.   {
  290.    print STDERR "No commands for ",$self->Name,"\n" unless ($self->target->phony); 
  291.   }
  292.  print "\n";
  293. }
  294.  
  295. package Make::Target;
  296. use Carp;
  297. use strict;
  298. use Cwd;
  299.  
  300. #
  301. # Intermediate 'target' package
  302. # There is an instance of this for each 'target' that apears on 
  303. # the left hand side of a rule i.e. for each thing that can be made.
  304. # 
  305. sub new
  306. {
  307.  my ($class,$info,$target) = @_;
  308.  return bless { NAME => $target,     # name of thing
  309.                 MAKEFILE => $info,   # Makefile context 
  310.                 Pass => 0            # Used to determine if 'done' this sweep
  311.               },$class;
  312. }
  313.  
  314. sub date
  315. {
  316.  my $self = shift;
  317.  my $info = $self->Info;
  318.  return $info->date($self->Name);
  319. }
  320.  
  321. sub phony
  322. {
  323.  my $self = shift;
  324.  return $self->Info->phony($self->Name);
  325. }
  326.  
  327. sub colon
  328. {
  329.  my $self = shift;
  330.  if (@_)
  331.   {
  332.    if (exists $self->{COLON})
  333.     {
  334.      my $dep = $self->{COLON};
  335.      if (@_ == 1)
  336.       {
  337.        my $other = shift;
  338.        $dep->depend(scalar $other->depend);
  339.        $dep->command(scalar $other->command);
  340.       }
  341.      else
  342.       {
  343.        $dep->depend(shift);
  344.        $dep->command(shift);
  345.       }
  346.     }
  347.    else
  348.     {
  349.      $self->{COLON} = (@_ == 1) ? shift->clone($self) : Make::Rule->new($self,':',@_);
  350.     }
  351.   }
  352.  if (exists $self->{COLON})
  353.   {
  354.    return (wantarray) ? ($self->{COLON}) : $self->{COLON};
  355.   }
  356.  else
  357.   {
  358.    return (wantarray) ? () : undef;
  359.   }
  360. }
  361.  
  362. sub dcolon
  363. {
  364.  my $self = shift;
  365.  if (@_)
  366.   {
  367.    my $rule = (@_ == 1) ? shift->clone($self) : Make::Rule->new($self,'::',@_);
  368.    $self->{DCOLON} = [] unless (exists $self->{DCOLON});
  369.    push(@{$self->{DCOLON}},$rule);
  370.   }
  371.  return (exists $self->{DCOLON}) ? @{$self->{DCOLON}} : ();
  372. }
  373.  
  374. sub Name
  375. {
  376.  return shift->{NAME};
  377. }
  378.  
  379. sub Info
  380. {
  381.  return shift->{MAKEFILE};
  382. }
  383.  
  384. sub ProcessColon
  385. {
  386.  my ($self) = @_;
  387.  my $c = $self->colon;
  388.  $c->find_commands if $c;
  389. }
  390.  
  391. sub ExpandTarget
  392. {
  393.  my ($self) = @_;
  394.  my $target = $self->Name;
  395.  my $info   = $self->Info;
  396.  my $colon  = delete $self->{COLON};
  397.  my $dcolon = delete $self->{DCOLON};
  398.  foreach my $expand (split(/\s+/,$info->subsvars($target)))
  399.   {
  400.    next unless defined($expand);
  401.    my $t = $info->Target($expand);
  402.    if (defined $colon)
  403.     {
  404.      $t->colon($colon); 
  405.     }
  406.    foreach my $d (@{$dcolon})
  407.     {
  408.      $t->dcolon($d);
  409.     }
  410.   }
  411. }
  412.  
  413. sub done
  414. {
  415.  my $self = shift;
  416.  my $info = $self->Info;
  417.  my $pass = $info->pass;
  418.  return 1 if ($self->{Pass} == $pass);
  419.  $self->{Pass} = $pass;
  420.  return 0;
  421. }
  422.  
  423. sub recurse
  424. {
  425.  my ($self,$method,@args) = @_;
  426.  my $info = $self->Info;
  427.  my $rule;
  428.  foreach $rule ($self->colon,$self->dcolon)
  429.   {
  430.    my $dep;
  431.    foreach $dep ($rule->exp_depend)
  432.     {
  433.      my $t = $info->{Depend}{$dep};
  434.      if (defined $t)
  435.       {
  436.        $t->$method(@args) 
  437.       }
  438.      else
  439.       {
  440.        my $dir = cwd(); 
  441.        die "Cannot recurse $method - no target $dep in $dir" unless ($info->exists($dep));
  442.       }
  443.     }
  444.   }
  445. }
  446.  
  447. sub Script
  448. {
  449.  my $self = shift;
  450.  my $info = $self->Info;
  451.  my $rule = $self->colon;
  452.  return if ($self->done);
  453.  $self->recurse('Script');
  454.  foreach $rule ($self->colon,$self->dcolon)
  455.   {
  456.    $rule->Script;
  457.   }
  458. }
  459.  
  460. sub Make
  461. {
  462.  my $self = shift;
  463.  my $info = $self->Info;
  464.  my $rule = $self->colon;
  465.  return if ($self->done);
  466.  $self->recurse('Make');
  467.  foreach $rule ($self->colon,$self->dcolon)
  468.   {
  469.    $rule->Make;
  470.   }
  471. }
  472.  
  473. sub Print
  474. {
  475.  my $self = shift;
  476.  my $info = $self->Info;
  477.  return if ($self->done);
  478.  my $rule = $self->colon;
  479.  foreach $rule ($self->colon,$self->dcolon)
  480.   {
  481.    $rule->Print;
  482.   }
  483.  $self->recurse('Print');
  484. }
  485.  
  486. package Make;
  487. use 5.005;  # Need look-behind assertions
  488. use Carp;
  489. use strict;
  490. use Config;
  491. use Cwd;
  492. use File::Spec;
  493. use vars qw($VERSION);
  494. $VERSION = '0.03';
  495.  
  496. sub phony
  497. {
  498.  my ($self,$name) = @_;
  499.  return exists $self->{PHONY}{$name};
  500. }
  501.  
  502. sub suffixes
  503. {
  504.  my ($self) = @_;
  505.  return keys %{$self->{'SUFFIXES'}};
  506. }
  507.  
  508. #
  509. # Construct a new 'target' (or find old one)
  510. # - used by parser to add to data structures
  511. #
  512. sub Target
  513. {
  514.  my ($self,$target) = @_;
  515.  unless (exists $self->{Depend}{$target})
  516.   {
  517.    my $t = Make::Target->new($self,$target);
  518.    $self->{Depend}{$target} = $t;
  519.   if ($target =~ /%/)
  520.    {
  521.     $self->{Pattern}{$target} = $t;
  522.    }
  523.   elsif ($target =~ /^\./)
  524.    {
  525.     $self->{Dot}{$target} = $t;
  526.    }
  527.   else
  528.    {
  529.     push(@{$self->{Targets}},$t);
  530.    }
  531.   }
  532.  return $self->{Depend}{$target};
  533. }
  534.  
  535. #
  536. # Utility routine for patching %.o type 'patterns'
  537. #
  538. sub patmatch
  539. {
  540.  my $key = shift;
  541.  local $_ = shift;
  542.  my $pat = $key;
  543.  $pat =~ s/\./\\./;
  544.  $pat =~ s/%/(\[^\/\]*)/;
  545.  if (/$pat$/)
  546.   {
  547.    return $1;
  548.   }
  549.  return undef;
  550. }
  551.  
  552. #
  553. # old vpath lookup routine 
  554. #
  555. sub locate
  556. {
  557.  my $self = shift;
  558.  local $_ = shift;
  559.  return $_ if (-r $_);
  560.  my $key;
  561.  foreach $key (keys %{$self->{vpath}})
  562.   {
  563.    my $Pat;
  564.    if (defined($Pat = patmatch($key,$_)))
  565.     {
  566.      my $dir;
  567.      foreach $dir (split(/:/,$self->{vpath}{$key}))
  568.       {
  569.        return "$dir/$_"  if (-r "$dir/$_");
  570.       }
  571.     }
  572.   }
  573.  return undef;
  574. }
  575.  
  576. #
  577. # Convert traditional .c.o rules into GNU-like into %o : %c
  578. #
  579. sub dotrules
  580. {
  581.  my ($self) = @_;
  582.  my $t;
  583.  foreach $t (keys %{$self->{Dot}})
  584.   {
  585.    my $e = $self->subsvars($t);
  586.    $self->{Dot}{$e} = delete $self->{Dot}{$t} unless ($t eq $e);
  587.   }
  588.  my (@suffix) = $self->suffixes;
  589.  foreach $t (@suffix)
  590.   {
  591.    my $d;
  592.    my $r = delete $self->{Dot}{$t};
  593.    if (defined $r)
  594.     {
  595.      my @rule = ($r->colon) ? $r->colon->depend : ();
  596.      if (@rule)
  597.       {
  598.        delete $self->{Dot}{$t->Name};
  599.        print STDERR $t->Name," has dependants\n";
  600.        push(@{$self->{Targets}},$r);
  601.       }
  602.      else
  603.       {
  604.        # print STDERR "Build \% : \%$t\n";                   
  605.        $self->Target('%')->dcolon(['%'.$t],scalar $r->colon->command);
  606.       }
  607.     }
  608.    foreach $d (@suffix)
  609.     {
  610.      $r = delete $self->{Dot}{$t.$d};
  611.      if (defined $r)
  612.       {
  613.        # print STDERR "Build \%$d : \%$t\n";
  614.        $self->Target('%'.$d)->dcolon(['%'.$t],scalar $r->colon->command);
  615.       }
  616.     }
  617.   }
  618.  foreach $t (keys %{$self->{Dot}})
  619.   {
  620.    push(@{$self->{Targets}},delete $self->{Dot}{$t});
  621.   }
  622. }
  623.  
  624. #
  625. # Return 'full' pathname of name given directory info. 
  626. # - may be the place to do vpath stuff ?
  627. #
  628. sub pathname
  629. {
  630.  my ($self,$name) = @_;
  631.  return $name if File::Spec->file_name_is_absolute($name);
  632.  $name =~ s,^\./,,;
  633.  return File::Spec->catfile($self->{Dir},$name);
  634. }
  635.  
  636. #
  637. # Return modified date of name if it exists
  638. # 
  639. sub date
  640. {
  641.  my ($self,$name) = @_;
  642.  my $path = $self->pathname($name);
  643.  my $r = -M $path;
  644.  # print STDERR "$path date is $r\n" if (defined $r);
  645.  return $r;
  646. }
  647.  
  648. #
  649. # Check to see if name is a target we can make or an existing
  650. # file - used to see if pattern rules are valid
  651. # - Needs extending to do vpath lookups
  652. #
  653. sub exists
  654. {
  655.  my ($self,$name) = @_;
  656.  return 1 if (exists $self->{Depend}{$name});
  657.  my $path = $self->pathname($name);
  658.  return 1 if (-e $path);
  659.  # print STDERR "$name '$path' does not exist\n";
  660.  return 0;
  661. }
  662.  
  663. #
  664. # See if we can find a %.o : %.c rule for target
  665. # .c.o rules are already converted to this form 
  666. #
  667. sub patrule
  668. {
  669.  my ($self,$target) = @_;
  670.  my $key;
  671.  # print STDERR "Trying pattern for $target\n";
  672.  foreach $key (keys %{$self->{Pattern}})
  673.   {
  674.    my $Pat;
  675.    if (defined($Pat = patmatch($key,$target)))
  676.     {
  677.      my $t = $self->{Pattern}{$key};
  678.      my $rule;
  679.      foreach $rule ($t->dcolon)
  680.       {
  681.        my @dep = $rule->exp_depend;
  682.        if (@dep)
  683.         {
  684.          my $dep = $dep[0];
  685.          $dep =~ s/%/$Pat/g;
  686.          # print STDERR "Try $target : $dep\n";
  687.          if ($self->exists($dep)) 
  688.           {
  689.            foreach (@dep)
  690.             {
  691.              s/%/$Pat/g;
  692.             }
  693.            return (\@dep,scalar $rule->command);
  694.           }
  695.         }
  696.       }
  697.     }
  698.   }
  699.  return ();
  700. }
  701.  
  702. #
  703. # Old code to handle vpath stuff - not used yet
  704. #
  705. sub needs
  706. {my ($self,$target) = @_;
  707.  unless ($self->{Done}{$target})
  708.   {
  709.    if (exists $self->{Depend}{$target})
  710.     {
  711.      my @depend = split(/\s+/,$self->subsvars($self->{Depend}{$target}));
  712.      foreach (@depend)
  713.       {
  714.        $self->needs($_);
  715.       }
  716.     }
  717.    else
  718.     {
  719.      my $vtarget = $self->locate($target);
  720.      if (defined $vtarget)
  721.       {
  722.        $self->{Need}{$vtarget} = $target;
  723.       }
  724.      else
  725.       {
  726.        $self->{Need}{$target}  = $target;
  727.       }
  728.     }
  729.   }
  730. }
  731.  
  732. #
  733. # Substitute $(xxxx) and $x style variable references
  734. # - should handle ${xxx} as well
  735. # - recurses still they all go rather than doing one level,
  736. #   which may need fixing
  737. #
  738. sub subsvars
  739. {
  740.  my $self = shift;
  741.  local $_ = shift;
  742.  my @var = @_;
  743.  push(@var,$self->{Override},$self->{Vars},\%ENV);
  744.  croak("Trying to subsitute undef value") unless (defined $_); 
  745.  while (/(?<!\$)\$\(([^()]+)\)/ || /(?<!\$)\$([<\@^?*])/)
  746.   {
  747.    my ($key,$head,$tail) = ($1,$`,$');
  748.    my $value;
  749.    if ($key =~ /^([\w._]+|\S)(?::(.*))?$/)
  750.     {
  751.      my ($var,$op) = ($1,$2);
  752.      foreach my $hash (@var)
  753.       {
  754.        $value = $hash->{$var};
  755.        if (defined $value)
  756.         {
  757.          last; 
  758.         }
  759.       }
  760.      unless (defined $value)
  761.       {
  762.        die "$var not defined in '$_'" unless (length($var) > 1); 
  763.        $value = '';
  764.       }
  765.      if (defined $op)
  766.       {
  767.        if ($op =~ /^s(.).*\1.*\1/)
  768.         {
  769.          local $_ = $self->subsvars($value);
  770.          $op =~ s/\\/\\\\/g;
  771.          eval $op.'g';
  772.          $value = $_;
  773.         }
  774.        else
  775.         {
  776.          die "$var:$op = '$value'\n"; 
  777.         }   
  778.       }
  779.     }
  780.    elsif ($key =~ /wildcard\s*(.*)$/)
  781.     {
  782.      $value = join(' ',glob($self->pathname($1)));
  783.     }
  784.    elsif ($key =~ /shell\s*(.*)$/)
  785.     {
  786.      $value = join(' ',split('\n',`$1`));
  787.     }
  788.    elsif ($key =~ /addprefix\s*([^,]*),(.*)$/)
  789.     {
  790.      $value = join(' ',map($1 . $_,split('\s+',$2)));
  791.     }
  792.    elsif ($key =~ /notdir\s*(.*)$/)
  793.     {
  794.      my @files = split(/\s+/,$1);
  795.      foreach (@files)
  796.       {
  797.        s#^.*/([^/]*)$#$1#;
  798.       }
  799.      $value = join(' ',@files);
  800.     }
  801.    elsif ($key =~ /dir\s*(.*)$/)
  802.     {
  803.      my @files = split(/\s+/,$1);
  804.      foreach (@files)
  805.       {
  806.        s#^(.*)/[^/]*$#$1#;
  807.       }
  808.      $value = join(' ',@files);
  809.     }
  810.    elsif ($key =~ /^subst\s+([^,]*),([^,]*),(.*)$/)
  811.     {
  812.      my ($a,$b) = ($1,$2);
  813.      $value = $3;
  814.      $a =~ s/\./\\./;
  815.      $value =~ s/$a/$b/; 
  816.     }
  817.    elsif ($key =~ /^mktmp,(\S+)\s*(.*)$/)
  818.     {
  819.      my ($file,$content) = ($1,$2);
  820.      open(TMP,">$file") || die "Cannot open $file:$!";
  821.      $content =~ s/\\n//g;
  822.      print TMP $content;
  823.      close(TMP);
  824.      $value = $file;
  825.     }
  826.    else
  827.     {
  828.      warn "Cannot evaluate '$key' in '$_'\n";
  829.     }
  830.    $_ = "$head$value$tail";
  831.   }
  832.  s/\$\$/\$/g;
  833.  return $_;
  834. }
  835.  
  836. #
  837. # Split a string into tokens - like split(/\s+/,...) but handling
  838. # $(keyword ...) with embedded \s
  839. # Perhaps should also understand "..." and '...' ?
  840. #
  841. sub tokenize
  842. {
  843.  local $_ = $_[0];
  844.  my @result = ();
  845.  s/\s+$//;
  846.  while (length($_))
  847.   {
  848.    s/^\s+//;
  849.    last unless (/^\S/);
  850.    my $token = "";
  851.    while (/^\S/)
  852.     {
  853.      if (s/^\$([\(\{])//)
  854.       {
  855.        $token .= $&; 
  856.        my $paren = $1 eq '(';
  857.        my $brace = $1 eq '{';
  858.        my $count = 1;
  859.        while (length($_) && ($paren || $brace))
  860.         {
  861.          s/^.//;
  862.          $token .= $&; 
  863.          $paren += ($& eq '(');
  864.          $paren -= ($& eq ')');
  865.          $brace += ($& eq '{');
  866.          $brace -= ($& eq '}');
  867.         }
  868.        die "Mismatched {} in $_[0]" if ($brace);
  869.        die "Mismatched () in $_[0]" if ($paren);
  870.       }
  871.      elsif (s/^(\$\S?|[^\s\$]+)//)
  872.       {
  873.        $token .= $&;
  874.       }
  875.     }
  876.    push(@result,$token);
  877.   }
  878.  return (wantarray) ? @result : \@result;
  879. }
  880.  
  881.  
  882. #
  883. # read makefile (or fragment of one) either as a result
  884. # of a command line, or an 'include' in another makefile.
  885. # 
  886. sub makefile
  887. {
  888.  my ($self,$makefile,$name) = @_;
  889.  local $_;
  890.  print STDERR "Reading $name\n";
  891. Makefile:
  892.  while (<$makefile>)
  893.   {
  894.    last unless (defined $_);
  895.    chomp($_);
  896.    if (/\\$/)
  897.     {
  898.      chop($_);
  899.      s/\s*$//;
  900.      my $more = <$makefile>;
  901.      $more =~ s/^\s*/ /; 
  902.      $_ .= $more;
  903.      redo;
  904.     }
  905.    next if (/^\s*#/);
  906.    next if (/^\s*$/);
  907.    s/#.*$//;
  908.    s/^\s+//;
  909.    if (/^(-?)include\s+(.*)$/)
  910.     {
  911.      my $opt = $1;
  912.      my $file;
  913.      foreach $file (tokenize($self->subsvars($2)))
  914.       {
  915.        local *Makefile;
  916.        my $path = $self->pathname($file);
  917.        if (open(Makefile,"<$path"))
  918.         {
  919.          $self->makefile(\*Makefile,$path);
  920.          close(Makefile);
  921.         }
  922.        else
  923.         {
  924.          warn "Cannot open $path:$!" unless ($opt eq '-') ;
  925.         }
  926.       }
  927.     }
  928.    elsif (/^\s*([\w._]+)\s*:?=\s*(.*)$/)
  929.     {
  930.      $self->{Vars}{$1} = (defined $2) ? $2 : "";
  931. #    print STDERR "$1 = ",$self->{Vars}{$1},"\n";
  932.     }
  933.    elsif (/^vpath\s+(\S+)\s+(.*)$/)
  934.     {my ($pat,$path) = ($1,$2);
  935.      $self->{Vpath}{$pat} = $path;
  936.     }
  937.    elsif (/^\s*([^:]*)(::?)\s*(.*)$/)
  938.     {
  939.      my ($target,$kind,$depend) = ($1,$2,$3);
  940.      my @cmnds;
  941.      if ($depend =~ /^([^;]*);(.*)$/)
  942.       {
  943.        ($depend,$cmnds[0])  = ($1,$2);
  944.       }
  945.      while (<$makefile>)
  946.       {
  947.        next if (/^\s*#/);
  948.        next if (/^\s*$/);
  949.        last unless (/^\t/);
  950.        chop($_);         
  951.        if (/\\$/)        
  952.         {                
  953.          chop($_);
  954.          $_ .= ' ';
  955.          $_ .= <$makefile>;
  956.          redo;           
  957.         }                
  958.        next if (/^\s*$/);
  959.        s/^\s+//;
  960.        push(@cmnds,$_);
  961.       }
  962.      $depend =~ s/\s\s+/ /;
  963.      $target =~ s/\s\s+/ /;
  964.      my @depend = tokenize($depend);
  965.      foreach (tokenize($target))
  966.       {
  967.        my $t = $self->Target($_);
  968.        my $index = 0;
  969.        if ($kind eq '::' || /%/)
  970.         {
  971.          $t->dcolon(\@depend,\@cmnds);
  972.         }
  973.        else
  974.         {
  975.          $t->colon(\@depend,\@cmnds);
  976.         }
  977.       }
  978.      redo Makefile;
  979.     }
  980.    else
  981.     {
  982.      warn "Ignore '$_'\n";
  983.     }
  984.   }
  985. }
  986.  
  987. sub pseudos
  988. {
  989.  my $self = shift;
  990.  my $key;
  991.  foreach $key (qw(SUFFIXES PHONY PRECIOUS PARALLEL))
  992.   {
  993.    my $t = delete $self->{Dot}{'.'.$key};
  994.    if (defined $t)
  995.     {
  996.      my $dep;
  997.      $self->{$key} = {};
  998.      foreach $dep ($t->colon->exp_depend)
  999.       {
  1000.        $self->{$key}{$dep} = 1;
  1001.       }
  1002.     }
  1003.   }
  1004. }
  1005.  
  1006.  
  1007. sub ExpandTarget
  1008. {
  1009.  my $self = shift;
  1010.  foreach my $t (@{$self->{'Targets'}})
  1011.   {
  1012.    $t->ExpandTarget;
  1013.   }
  1014.  foreach my $t (@{$self->{'Targets'}})
  1015.   {
  1016.    $t->ProcessColon;
  1017.   }
  1018. }
  1019.  
  1020. sub parse
  1021. {
  1022.  my ($self,$file) = @_;
  1023.  if (defined $file)
  1024.   {
  1025.    $file = $self->pathname($file);
  1026.   }
  1027.  else
  1028.   {
  1029.    my @files = qw(makefile Makefile);
  1030.    unshift(@files,'GNUmakefile') if ($self->{GNU});
  1031.    my $name;
  1032.    foreach $name (@files)
  1033.     {
  1034.      $file = $self->pathname($name);
  1035.      if (-r $file)
  1036.       {
  1037.        $self->{Makefile} = $name;
  1038.        last; 
  1039.       }
  1040.     }
  1041.   }
  1042.  local (*Makefile);
  1043.  open(Makefile,"<$file") || croak("Cannot open $file:$!");
  1044.  $self->makefile(\*Makefile,$file);
  1045.  close(Makefile);
  1046.  
  1047.  # Next bits should really be done 'lazy' on need.
  1048.  
  1049.  $self->pseudos;         # Pull out .SUFFIXES etc. 
  1050.  $self->dotrules;        # Convert .c.o into %.o : %.c
  1051. }
  1052.  
  1053. sub PrintVars
  1054. {
  1055.  my $self = shift;
  1056.  local $_;
  1057.  foreach (keys %{$self->{Vars}})
  1058.   {
  1059.    print "$_ = ",$self->{Vars}{$_},"\n";
  1060.   }
  1061.  print "\n";
  1062. }
  1063.  
  1064. sub exec
  1065. {
  1066.  my $self = shift;
  1067.  if ($^O eq 'MSWin32' or $^O eq 'riscos')
  1068.   {
  1069.    my $cwd = cwd();
  1070.    my $ret;
  1071.    chdir $self->{Dir};
  1072.    if ($^O eq 'riscos') {
  1073.       my $com = join ' ', @_;
  1074.       $com =~ tr/\t/ /;
  1075.       # shortcut known no-ops (OSCLI comments start with a '|')
  1076.       $ret = ($com =~ /^\*\|/) ? 0 : system('dumbshell', '-c', $com);
  1077.    } else {
  1078.       $ret = system(@_);
  1079.    }
  1080.    chdir $cwd;
  1081.    return $ret;
  1082.   }
  1083.  else
  1084.   {
  1085.    my $pid  = fork;
  1086.    if ($pid)
  1087.     {
  1088.      waitpid $pid,0;
  1089.      return $?;
  1090.     }
  1091.    else
  1092.     {
  1093.      my $dir = $self->{Dir}; 
  1094.      chdir($dir) || die "Cannot cd to $dir";
  1095.      # handle leading VAR=value here ?
  1096.      # To handle trivial cases like ': libpTk.a' force using /bin/sh
  1097.      exec("/bin/sh","-c",@_) || confess "Cannot exec ".join(' ',@_);
  1098.     }
  1099.   }
  1100. }
  1101.  
  1102. sub NextPass { shift->{Pass}++ }
  1103. sub pass     { shift->{Pass} }
  1104.  
  1105. sub apply
  1106. {
  1107.  my $self = shift;
  1108.  my $method = shift;
  1109.  $self->NextPass;
  1110.  my @targets = ();
  1111.  # print STDERR join(' ',Apply => $method,@_),"\n";
  1112.  foreach (@_)
  1113.   {
  1114.    if (/^(\w+)=(.*)$/)
  1115.     {
  1116.      # print STDERR "OVERRIDE: $1 = $2\n";
  1117.      $self->{Override}{$1} = $2;
  1118.     }
  1119.    else
  1120.     {
  1121.      push(@targets,$_);
  1122.     }
  1123.   }
  1124.  #
  1125.  # This expansion is dubious as it alters the database
  1126.  # as a function of current values of Override.
  1127.  # 
  1128.  $self->ExpandTarget;    # Process $(VAR) : 
  1129.  @targets = ($self->{'Targets'}[0])->Name unless (@targets);
  1130.  # print STDERR join(' ',Targets => $method,map($_->Name,@targets)),"\n";
  1131.  foreach (@targets)
  1132.   {
  1133.    my $t = $self->{Depend}{$_};
  1134.    unless (defined $t)
  1135.     {
  1136.      print STDERR join(' ',$method,@_),"\n";
  1137.      die "Cannot `$method' - no target $_" 
  1138.     }
  1139.    $t->$method();
  1140.   }
  1141. }
  1142.  
  1143. sub Script
  1144. {
  1145.  shift->apply(Script => @_);
  1146. }
  1147.  
  1148. sub Print
  1149. {
  1150.  shift->apply(Print => @_);
  1151. }
  1152.  
  1153. sub Make
  1154. {
  1155.  shift->apply(Make => @_);
  1156. }
  1157.  
  1158. sub new
  1159. {
  1160.  my ($class,%args) = @_;
  1161.  unless (defined $args{Dir})
  1162.   {
  1163.    chomp($args{Dir} = cwd());
  1164.   }
  1165.  my $self = bless { %args, 
  1166.                    Pattern  => {},  # GNU style %.o : %.c 
  1167.                    Dot      => {},  # Trad style .c.o
  1168.                    Vpath    => {},  # vpath %.c info 
  1169.                    Vars     => {},  # Variables defined in makefile
  1170.                    Depend   => {},  # hash of targets
  1171.                    Targets  => [],  # ordered version so we can find 1st one
  1172.                    Pass     => 0,   # incremented each sweep
  1173.                    Need     => {},
  1174.                    Done     => {},
  1175.                  },$class;
  1176.  $self->{Vars}{CC}     = $Config{cc};
  1177.  $self->{Vars}{AR}     = $Config{ar};
  1178.  $self->{Vars}{CFLAGS} = $Config{optimize};
  1179.  $self->makefile(\*DATA,__FILE__);
  1180.  $self->parse($self->{Makefile});
  1181.  return $self;
  1182. }
  1183.  
  1184. =head1 NAME
  1185.  
  1186. Make - module for processing makefiles 
  1187.  
  1188. =head1 SYNOPSIS
  1189.  
  1190.     require Make;
  1191.     my $make = Make->new(...);
  1192.     $make->parse($file);   
  1193.     $make->Script(@ARGV)
  1194.     $make->Make(@ARGV)
  1195.     $make->Print(@ARGV)
  1196.  
  1197.         my $targ = $make->Target($name);
  1198.         $targ->colon([dependancy...],[command...]);
  1199.         $targ->dolon([dependancy...],[command...]);
  1200.         my @depends  = $targ->colon->depend;
  1201.         my @commands = $targ->colon->command;
  1202.  
  1203. =head1 DESCRIPTION
  1204.  
  1205. Make->new creates an object if C<new(Makefile =E<gt> $file)> is specified
  1206. then it is parsed. If not the usual makefile Makefile sequence is 
  1207. used. (If GNU => 1 is passed to new then GNUmakefile is looked for first.) 
  1208.  
  1209. C<$make-E<gt>Make(target...)> 'makes' the target(s) specified
  1210. (or the first 'real' target in the makefile).
  1211.  
  1212. C<$make-E<gt>Print> can be used to 'print' to current C<select>'ed stream
  1213. a form of the makefile with all variables expanded. 
  1214.  
  1215. C<$make-E<gt>Script(target...)> can be used to 'print' to 
  1216. current C<select>'ed stream the equivalent bourne shell script
  1217. that a make would perform i.e. the output of C<make -n>.
  1218.  
  1219. There are other methods (used by parse) which can be used to add and 
  1220. manipulate targets and their dependants. There is a hierarchy of classes
  1221. which is still evolving. These classes and their methods will be documented when
  1222. they are a little more stable.
  1223.  
  1224. The syntax of makefile accepted is reasonably generic, but I have not re-read
  1225. any documentation yet, rather I have implemented my own mental model of how
  1226. make works (then fixed it...).
  1227.  
  1228. In addition to traditional 
  1229.  
  1230.     .c.o : 
  1231.         $(CC) -c ...
  1232.  
  1233. GNU make's 'pattern' rules e.g. 
  1234.  
  1235.     %.o : %.c 
  1236.         $(CC) -c ...
  1237.  
  1238. Likewise a subset of GNU makes $(function arg...) syntax is supported.
  1239.  
  1240. Via pmake Make has built perl/Tk from the C<MakeMaker> generated Makefiles...
  1241.  
  1242. =head1 BUGS
  1243.  
  1244. At present C<new> must always find a makefile, and
  1245. C<$make-E<gt>parse($file)> can only be used to augment that file.
  1246.  
  1247. More attention needs to be given to using the package to I<write> makefiles.
  1248.  
  1249. The rules for matching 'dot rules' e.g. .c.o   and/or pattern rules e.g. %.o : %.c
  1250. are suspect. For example give a choice of .xs.o vs .xs.c + .c.o behaviour
  1251. seems a little odd.
  1252.  
  1253. Variables are probably substituted in different 'phases' of the process
  1254. than in make(1) (or even GNU make), so 'clever' uses will probably not
  1255. work.
  1256.  
  1257. UNIXisms abound. 
  1258.  
  1259. =head1 SEE ALSO 
  1260.  
  1261. L<pmake>
  1262.  
  1263. =head1 AUTHOR
  1264.  
  1265. Nick Ing-Simmons
  1266.  
  1267. =cut 
  1268.  
  1269. 1;
  1270. #
  1271. # Remainder of file is in makefile syntax and constitutes
  1272. # the built in rules
  1273. #
  1274. __DATA__
  1275.  
  1276. .SUFFIXES: .o .c .y .h .sh .cps
  1277.  
  1278. .c.o :
  1279.     $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ $< 
  1280.  
  1281. .c   :
  1282.     $(CC) $(CFLAGS) $(CPPFLAGS) -o $@ $< $(LDFLAGS) $(LDLIBS)
  1283.  
  1284. .y.o:
  1285.     $(YACC) $<
  1286.     $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ y.tab.c
  1287.     $(RM) y.tab.c
  1288.  
  1289. .y.c:
  1290.     $(YACC) $<
  1291.     mv y.tab.c $@
  1292.  
  1293.  
  1294.