package Slay::MakerRule ;
#
# Copyright (c) 1999 by Barrie Slaymaker, rbs@telerama.com
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#
=head1 NAME
Slay::MakerRule - a class for making things with dependancies
=head1 SYNOPSIS
use strict ;
use Slay::MakerRule ;
$t1 = Slay::MakerRule->new(
\@target, ## Filenames made by \@actions
\@dependencies, ## Files or Slay::MakerRule objects
\@actions, ## Command lines or sub{}
) ;
Any or all of the three parameters may be scalars if there is only one
thing to pass:
$t1 = Slay::MakerRule->new(
$target,
$dependency,
$action,
) ;
=head1 DESCRIPTION
=over
=cut
use strict ;
use Carp ;
use Fcntl qw( :DEFAULT :flock ) ;
use File::Basename ;
use File::Path ;
use IPC::Run qw( run ) ;
use fields qw(
ACTS
CMD
COMPILED_PATS
DEPS
OPTS
PATS
_IN_MAKE
) ;
sub new {
my $proto = shift ;
my Slay::MakerRule $self ;
my $class = ref $proto || $proto ;
{
no strict 'refs' ;
$self = bless [ \%{"$class\::FIELDS"} ], $class ;
}
$self->{PATS} = [] ;
$self->{DEPS} = [] ;
$self->{ACTS} = [] ;
$self->{OPTS} = {} ;
if ( ref $_[0] eq 'HASH' ) {
## It's a hash-style initter.
my ( $h ) = @_ ;
for ( keys %$h ) {
if ( /^(?:PATS|DEPS|ACTS)$/ ) {
$self->{$_} = $h->{$_} ;
}
else {
$self->{OPTS}->{$_} = $h->{$_} ;
}
}
}
else {
## It's qw( patterns, ':', dependencies, '=', actions ).
## NB: The ':' and '=' may appear as the last char of a scalar param.
$self->{OPTS} = pop if ref $_[-1] eq 'HASH' ;
my $a = $self->{PATS} ;
my $e ;
my $na ;
for ( @_ ) {
$e = $_ ;
$na = undef ; ;
unless ( ref $e ) {
if ( $e =~ /^:$/ ) { $a = $self->{DEPS} ; next }
if ( $e =~ /^=$/ ) { $a = $self->{ACTS} ; next }
if ( $e =~ s/:$// ) { $na = $self->{DEPS} }
if ( $e =~ s/=$// ) { $na = $self->{ACTS} }
}
push @$a, $e ;
$a = $na if defined $na ;
}
}
return $self ;
}
=item check
Builds the queue of things to make if this target or it's dependencies are
out of date.
=cut
sub check {
my Slay::MakerRule $self = shift ;
my $user_options = ref $_[-1] ? pop : {} ;
my ( $make, $target, $matches ) = @_ ;
## We join the options sets so that passed-in override new()ed, and
## we copy them in case somebody changes their mind.
my $options = {
%{$make->options},
%{$self->{OPTS}},
%$user_options,
} ;
print STDERR "$target: checking ".$self->targets." ", %$options, "\n"
if $options->{debug} ;
if ( $self->{_IN_MAKE} ) {
warn "Ignoring recursive dependency on " . $self->targets ;
return ;
}
my @required ;
push @required, "forced" if $options->{force} ;
push @required, "!exists" unless $make->e( $target ) ;
if ( $options->{debug} && $make->e( $target ) ) {
print STDERR (
"$target: size, atime, mtime: ",
join(
', ',
$make->size( $target ),
scalar( localtime $make->atime( $target ) ),
scalar( localtime $make->mtime( $target ) ),
),
"\n"
) ;;
}
## If the queue grows when our dependencies are checked, then we must
## be remade as well.
my $count = $make->queue_size ;
my @deps = map {
if ( ref $_ eq 'CODE' ) {
$_->( $make, $target, $matches ) ;
}
elsif ( /\$/ ) {
my $dep = $_ ;
## TODO: Error out or provide a '' if $matches[n] undefined.
## TODO: Make this in to 1 s/// so that double interpolation
## won't occur if, say, $matches->[0] contains '${1}'
$dep =~ s/\$(\d+)/$matches->[$1-1]/g ;
$dep =~ s/\$\{(\d+)\}/$matches->[$1-1]/g ;
## TODO: allow s///s from $ENV here
$dep =~ s/\$\{TARGET\}/$target/g ;
$dep ;
}
else {
$_ ;
}
} @{$self->{DEPS}} ;
print STDERR "$target: deps: ", join( ', ', @deps ), "\n"
if $options->{debug} && @deps ;
$make->check_targets( @deps, $user_options ) ;
push @required, "!deps" if $make->queue_size > $count ;
unless ( @required ) {
## The target exists && no deps need to be rebuilt. See if the
## target is up to date.
my $max_mtime ;
for ( @deps ) {
print STDERR "$target: checking " . Cwd::cwd() . " $_\n"
if $options->{debug} ;
my $dep_mtime = $make->mtime( $_ ) ;
print STDERR "$target: $_ mtime " . localtime( $dep_mtime ) . "\n"
if $options->{debug} ;
$max_mtime = $dep_mtime
if defined $dep_mtime
&& ( ! defined $max_mtime || $dep_mtime > $max_mtime ) ;
}
push @required, "out of date"
if defined $max_mtime && $max_mtime > $make->mtime( $target ) ;
}
if ( @required ) {
print STDERR "$target: required ( ", join( ', ', @required ), " )\n"
if $options->{debug} ;
$make->push( $target, $self, \@deps, $matches, $options ) ;
}
else {
print STDERR "$target: not required\n"
if $options->{debug} ;
}
}
sub _compile_pattern {
my ( $pat ) = @_ ;
my $exactness = -1 ;
my $lparens = 0 ;
my $re ;
if ( ref $pat ne 'Regexp' ) {
$re = $pat ;
## '\a' => 'a'
## '\*' => '\*'
## '**' => '.*'
## '*' => '[^/]*'
## '?' => '.'
$re =~ s{
( \\.
| \*\*
| .
)
}{
if ( $1 eq '?' ) {
--$exactness ;
'[^/]' ;
}
elsif ( $1 eq '*' ) {
--$exactness ;
'[^/]*' ;
}
elsif ( $1 eq '**' ) {
--$exactness ;
'.*' ;
}
elsif ( $1 eq '(' ) {
++$lparens ;
'(' ;
}
elsif ( $1 eq ')' ) {
')' ;
}
elsif ( length $1 > 1 ) {
quotemeta(substr( $1, 1 ) );
}
else {
quotemeta( $1 ) ;
}
}xeg ;
$re = "^$re\$" ;
}
else {
## Destroy it in order to get metrics.
$re = "$pat" ;
$re =~ s{
(
\\.
|\(\??
|(?:
.[?+*]+
|\.[?+*]*
)+
)
}{
if ( substr( $1, 0, 1 ) eq '\\' ) {
# print STDERR "\\:$1\n" if $options->{DEBUG} ;
}
elsif ( substr( $1, 0, 1 ) eq '(' ) {
# print STDERR "(:$1\n" if $options->{debug} ;
++$lparens
if substr( $1, 0, 2 ) ne '(?' ;
}
else {
# print STDERR "*:$1\n" if $options->{debug} ;
--$exactness ;
}
## Return the original value, just for speed's sake
$1 ;
}xeg ;
## Ok, now copy it for real
$re = $pat ;
}
# print STDERR (
# "re: $re\n",
# "lparens: $lparens\n",
# "exactness: $exactness\n",
# ) if $options->{debug} ;
return [ $re, $exactness, $lparens ] ;
}
=item exec
Executes the action(s) associated with this rule.
=cut
sub exec {
my Slay::MakerRule $self = shift ;
my $options = ref $_[-1] eq 'HASH' ? pop : {} ;
my ( $make, $target, $deps, $matches ) = @_ ;
my @output ;
print STDERR "$target: in exec() for ". $self->targets.", ", %$options, "\n"
if $options->{debug} ;
my $target_backup ;
if ( ( $options->{detect_no_size_change} || $options->{detect_no_diffs} )
&& ! -d $target
) {
$target_backup = $make->backup(
$target,
{
stat_only => ! $options->{detect_no_diffs},
move => $options->{can_move_target},
debug => $options->{debug},
}
) ;
}
if ( $options->{auto_create_dirs} ) {
## Use dirname so that 'a/b/c/' only makes 'a/b', leaving it up to the
## make rule to mkdir c/. fileparse would return 'a/b/c'.
my ( $dir ) = dirname( $target ) ;
if ( ! -d $dir ) {
mkpath( [ $dir ] ) ;
warn "Failed to create $dir" unless -d $dir ;
}
}
for my $act ( @{$self->{ACTS}} ) {
local %ENV = %ENV ;
$ENV{TARGET} = $target ;
delete $ENV{$act} for grep {/^DEP\d+/} keys %ENV ;
$ENV{"DEP$_"} = $deps->[$_] for (0..$#$deps) ;
if ( ref $act eq 'CODE' ) {
print STDERR "$target: execing CODE\n"
if $options->{debug} ;
my $out = $act->( $make, $target, $deps, $matches ) ;
$out = '' unless defined $out ;
push @output, $out ;
}
elsif ( ref $act eq 'ARRAY' ) {
print STDERR "$target: execing ", join( ' ', map {"'$_'"} @$act ), "\n"
if $options->{debug} ;
## It's a command line in list form, so don't exec the shell
my $out ;
run $act, \undef, \$out ;
push( @output, $out ) ;
}
elsif ( ! ref $act ) {
print STDERR "$target: execing '$act' \n"
if $options->{debug} ;
## It's a command line in string form
my $out ;
run [ 'sh', '-c', $act ], \undef, \$out ;
$act =~ m{(\S*)} ;
my $cmd = $1 ;
push( @output, $out ) ;
}
else {
confess "Invalid type for a Slay::MakerRule rule: " . ref $act ;
}
}
$make->clear_stat( $target ) ;
my @new_stats = $make->stat( $target ) ;
if ( defined $target_backup ) {
$make->remove_backup(
$target_backup,
{
restore_if_unchanged => 1,
deps => $deps
}
) ;
}
return wantarray ? @output : join( '', @output ) ;
}
=item targets
returns either ( target1, target2, ... ) or "target1, target2, ..." depending
on context.
=cut
sub targets {
my Slay::MakerRule $self = shift ;
return wantarray ? @{$self->{PATS}} : join( ', ', @{$self->{PATS}} );
}
=item matches
Checks the target list to see if it matches the target passed in.
=cut
sub matches {
my Slay::MakerRule $self = shift ;
my $options = ref $_[-1] eq 'HASH' ? pop : {} ;
my ( $target ) = @_ ;
my $max_exactness ;
my @matches ;
if ( ! $self->{COMPILED_PATS} ) {
$self->{COMPILED_PATS} = [
map {
_compile_pattern $_
} grep {
ref $_ ne 'CODE'
} @{$self->{PATS}}
] ;
}
#print STDERR join("\n",map { join(',', @$_ ) } @{$self->{COMPILED_PATS}} ), "\n" ;
for ( @{$self->{COMPILED_PATS}} ) {
my ( $re, $exactness, $lparens ) = @$_ ;
#print STDERR "$target: ?= $re\n" ;
if ( $target =~ $re &&
( ! defined $max_exactness || $exactness > $max_exactness )
) {
$max_exactness = $exactness ;
no strict 'refs' ;
@matches = map {
${$_}
} (1..$lparens) ;
# print STDERR (
# "$target: matches: ",
# join( ',', map { defined $_ ? "'$_'" : '<undef>' } @matches),
# "\n"
# ) if $options->{debug} ;
}
}
return defined $max_exactness ? ( $max_exactness, \@matches ) : () ;
}
=back
=cut
1 ;