# $Id: Cmds.pm,v 1.75 2017/08/06 21:19:08 pfeiffer Exp $
=head1 NAME
Mpp::Cmds - Builtin commands for makefiles
=head1 DESCRIPTION
This package contains builtin commands similar to common utilities, which can
be called from a rule, as well as in a functional way or as top level
statements.
=cut
# TODO: autoload these commands only when needed
# Use file_info -- or don't, because we'd have to refresh it before every new cmd.
# builtin commands
package Mpp::Cmds;
use strict;
use Mpp::Text ();
use Mpp::File;
use Mpp::Subs;
use POSIX ();
BEGIN {
my $ln_cp = $ENV{MAKEPP_LN_CP} || 0;
*NO_LINK = $Mpp::Text::N[$ln_cp & 2 ? 1 : 0];
*NO_SYMLINK = $Mpp::Text::N[$ln_cp & 1 || 0];
}
sub eval_or_die($) {
$Mpp::Rule::unsafe = 1;
Mpp::Subs::eval_or_die $_[0], $Mpp::Subs::rule->{MAKEFILE}, $Mpp::Subs::rule->{RULE_SOURCE};
}
# perform one step and log or die as appropriate
our( $install_date, $install_log );
sub perform(&$;$) {
if( eval { &{$_[0]} } && !$@ ) {
print STDERR "$0: $_[1]\n" if $Mpp::verbose;
if( $install_log ) {
my $msg = $_[1];
my $cwd = absolute_filename $CWD_INFO;
$msg =~ s|`(?=[^/`][^`]*$)|`$cwd/|;
if( $Mpp::Event::max_proc > 1 ) {
flock $install_log, 2; # Lock exclusive.
if( $install_date =~ /^ / ) { # Additional output
if( (stat $install_log)[7] > tell $install_log ) {
# Size changed by concurrent proc
seek $install_log, 0, 2;
print $install_log "$install_date $msg\n" or die $!;
} else {
print $install_log " $msg\n" or die $!;
}
} else {
seek $install_log, 0, 2;
print $install_log "$install_date $msg\n" or die $!;
$install_date = " $install_date";
}
flock $install_log, 8; # Unlock.
} else {
print $install_log "$install_date $msg\n" or die $!;
}
$install_date = '';
}
1;
} elsif( !$_[2] ) {
die "could not $_[1]--". ($@ || $!) . "\n";
}
}
# deletion files first, then directories depth first
sub _rm {
my @dirs;
perform { unlink } "delete `$_'"
for grep { -l || !-d _ ? $_ : !push @dirs, $_ } @_;
perform { rmdir } "delete directory `$_'"
for sort { ($b =~ tr:/::) <=> ($a =~ tr:/::) } @dirs;
}
# Explicit variables for options shared by several commands.
my( $noescape, $force, $inpipe, $print, $print_nl, $synclines, $last_file, $last_line );
# Do buffered output of $_ with optional synclines.
sub print {
if( defined and length ) {
if( $synclines ) {
if( $last_file ne $ARGV ) {
$print_nl or $print .= "\n";
$print .= "#line $. \"$ARGV\"\n";
$last_file = $ARGV;
$last_line = $.;
} elsif( ++$last_line != $. ) {
$print_nl or $print .= "\n";
$print .= "#line $.\n";
$last_line = $.;
}
if( /^\s*#\s*line\s+\d+(\s+\")?/m ) { # Replacement contains #line.
$_ .= '#line ' . ($. + 1) . ($1 ? " \"$ARGV\"\n" : "\n");
} else {
s/\n(?!\z)/\n#line $.\n/g; # Multiple lines generated from one source line.
}
$print_nl = /\n\z/; # Did we end with a nl?
}
$print .= $_; # Buffer up to about 8kb.
if( 8 * 1024 < length $print ) {
# Mixing this with a final print is ok, as buffering comes last. syswrite is faster only from 3kb upwards.
syswrite select, $print or die $!;
$print = '';
}
}
}
# Frame which handles options, I/O and adds omnipresent --verbose.
sub frame(&@) {
my( $code, @opts, @stdopts ) = @_;
local $Mpp::verbose = $Mpp::verbose;
my( $infail, $inout, $output, $pipe, $select, $outfail, $separator );
# Standard options shared by several commands.
my %opt =
(E => ['E', qr/no[-_]?escape/, \$noescape],
f => [qw(f force), \$force],
i => [qw(i inpipe), \$inpipe, 1],
I => [qw(I infail), \$infail],
o => [qw(o output), \$output, 1],
O => [qw(O outfail), \$outfail],
r => ['r', qr/record[-_]?size/, \$separator, 1, sub { $separator = eval "\\$separator" }],
s => [qw(s separator), \$separator, 1],
S => ['S', qr/sync[-_]?lines/, \$synclines]);
@opts = grep { # Put stds last, so they don't override short opts.
ref or !push @stdopts, $opt{$_};
} @opts;
Mpp::Text::getopts @opts, @stdopts,
[qw(v verbose), \$Mpp::verbose];
# Setup input context.
local $/ = ref $separator && $$separator == 0 ? undef : $separator if defined $separator; # \0 deprecated in 5.20
#local *STDIN if $inpipe or $output && $output =~ /^\+</; # Causes input to hang :-(
if( $inpipe ) {
$inpipe =~ s/\|$//s;
perform { open STDIN, '-|', $inpipe } "call `$inpipe|'";
}
local $SIG{__WARN__} = sub {
if( $_[0] =~ /^Can't open (.*?): $! at/ ) {
die "$0: cannot open `$1'--$!\n";
} else {
warn $_[0];
}
};
# Setup output context.
$print = ''; $print_nl = 1;
$last_file = '' if $synclines;
local *STDOUT if $output;
if( $output ) {
my $first = ord $output;
$pipe = $first == ord '|';
if( $pipe or $first != ord '+' or $output !~ /^\+</ ) {
if( !$pipe and $force ) {
my $file = $output;
$file =~ s/^>\s*//;
_rm $file if -e $file;
}
perform { open STDOUT, ($pipe or $first == ord '>') ? $output : ">$output" } "write `$output'";
} else {
$output =~ s/^\+<((.*?)[^\/]+)$/$1/;
# open temp file in same dir as output, so we can rename later
$inout = "$2.makepp.$$" . substr rand, 1;
perform { open STDIN, $output and open STDOUT, '>', $inout }
"read `$output' and write to tempfile";
}
$select = select STDOUT;
}
local $SIG{PIPE} = 'IGNORE' if $pipe;
my @res = eval { &$code };
my $err = $@;
# throw the proper diagnostics as to why close failed
sub _closedie($) {
die "`$_[0]' ",
$! ? "failed to close--$!" :
($? & 127) ? "died with signal " . ($? & 127) :
"exited with value " . ($? >> 8);
}
# Cleanup if any I/O is open.
if( $inpipe && $infail or $inout ) {
Mpp::is_windows > 0 or # fake fork, child already closed ours
close STDIN or _closedie $inpipe;
open STDIN, '<', '/dev/null'; # placeholder file handle as long as not local
}
print $print or die $! if length $print;
$print = ''; # In case of nested commands.
if( $output ) {
close STDOUT or $outfail && _closedie $output;
perform { rename $inout, $output } "rename tempfile to `$output'" if $inout;
select $select;
}
undef ${$$_[2]} for @stdopts;
die $err if $err;
@res;
}
# variant that returns what it chomped
sub _chomp(\$) {
return '' if ref $/;
my $tail = ${$_[0]};
my $len = chomp ${$_[0]};
return '' unless $len;
substr $tail, -$len;
}
sub c_cat {
local @ARGV = @_;
frame {
require File::Copy;
if( $synclines ) {
local $/ = \8192;
while( <> ) {
if( $. == 1 ) { # Can't use &print, as that "corrects" \n to same #line directive
print $print_nl ? '' : "\n", "#line 1 \"$ARGV\"\n$_";
} else {
print;
}
$print_nl = /\n\z/; # Did we end with a nl?
close ARGV if eof;
}
} else {
perform { File::Copy::copy( $_, \*STDOUT ) } "copy `$_'" for @ARGV;
}
} qw(f i I o O S);
}
sub c_chmod {
local @ARGV = @_;
frame {
my $mode = oct shift @ARGV;
perform { chmod $mode, $_ } "set mode for `$_'"
for @ARGV;
};
}
sub c_cp {
my $mv; # must separate my from if, or it survives multiple calls
local @ARGV = @_;
$mv = shift @ARGV if ref $_[0];
my( $link, $symbolic );
frame {
undef $link if NO_LINK;
undef $symbolic if NO_SYMLINK;
my $dest = @ARGV == 1 ? '.' : pop @ARGV;
require File::Copy;
my $cmd = $mv ? 'move' : 'copy';
$mv = $mv ? \&File::Copy::move : \&File::Copy::syscopy;
for( @ARGV ) {
my $d = -d $dest;
my $dirdest = $d ? $dest . '/' . f_notdir $_ : $dest;
_rm $dirdest if $force && ($d ? -e( $dirdest ) : defined $d);
$link && perform { link $_, $dirdest } "link `$_' to `$dirdest'", 1
or $symbolic && perform { symlink f_relative_to( $_ . ',' . f_dir $dirdest ), $dirdest } "link `$_' to `$dirdest' symbolically", 1
or perform { &$mv( $_, $dirdest ) } "$cmd `$_' to `$dirdest'";
}
} 'f',
$mv ? () :
([qw(l link), \$link],
['s', qr/sym(?:bolic(?:[-_]?link)?|link)/, \$symbolic]);
}
sub c_mv { c_cp \1, @_ }
sub c_cut {
local @ARGV = @_; # for <>
my( $delimiter, $characters, $fields, $lines, $matching, $printf, $only_delim ) = "\t";
my $err = "$0: one of --characters, --fields or --lines must be given\n";
frame {
my( @idxs, $eol );
local @::F; # Use Perl's autosplit variable into Makeppfile's package
@idxs = eval_or_die $fields
unless $fields =~ /^[-+.,\d\s]+$/ &&
$fields =~ s/((?:,|^)\d+\.\.)-/"$1\$#::F+" . (defined $lines ? '2-' : '1-')/eg;
if( defined $lines ) {
warn "$0: options --matching or --printf make no sence with --lines\n" if $matching || $only_delim || $printf;
while( <> ) {
push @::F, $_;
if( eof ) {
for my $line (@idxs ? @idxs : eval_or_die $fields) {
$line or die "$0: line numbers start at 1, not 0\n";
$. = $line > 0 ? $line : @::F + 1 + $line; # Lines count from 1.
$_ = $::F[$. - 1];
&print;
}
close ARGV;
@::F = ();
}
}
} elsif( defined $fields ) {
if( $printf && !$noescape ) {
$printf =~ s/([\$\@!])/\\$1/g; # protect variable chars and next line's quote
$printf = eval "qq!$printf!";
die $@ if $@;
}
my $re = qr/\Q$delimiter/ unless $characters;
while( <> ) {
$eol = _chomp $_;
if( (@::F = $re ? split( $re, $_, -1 ) : unpack '(a1)*', $_) > 1 ) {
@::F = map { defined() ? $_ : $matching ? next : '' } @::F[@idxs ? @idxs : eval_or_die $fields];
$_ = $printf ?
sprintf( $printf, @::F ) :
join( $delimiter, @::F ) . $eol;
} elsif( $matching || $only_delim ) {
next;
} elsif( $printf ) {
$_ = sprintf $printf, $_;
} else {
$_ .= $eol;
}
&print;
close ARGV if $synclines && eof;
}
} else {
die $err;
}
} qw(E f i I o O r s S),
[qw(c characters), \$characters, 1, sub { $delimiter = ''; warn $err if defined $fields; $fields = $characters }],
[qw(d delimiter), \$delimiter, 1],
[qw(f fields), \$fields, 1, sub { warn $err if defined $characters or defined $lines }],
[qw(l lines), \$lines, 1, sub { warn $err if defined $fields; $fields = $lines }],
[qw(m matching), \$matching],
[qw(p printf), \$printf, 1],
['s', qr/only[-_]?delimited/, \$only_delim];
}
sub c_echo {
my $cmd = 0;
local @ARGV = @_;
$cmd = ${shift @ARGV} if ref $_[0];
my $nonewline;
frame {
my $res;
if( $cmd == 1 ) {
$res = eval_or_die "@ARGV" if @ARGV;
$res = '' unless defined $res;
} else {
$res = $cmd == 2 ? shift @ARGV : "@ARGV";
unless( $noescape ) {
$res =~ s/([\$\@!])/\\$1/g; # protect variable chars and next line's quote
$res = eval "qq!$res!";
die $@ if $@;
}
$res = sprintf $res, @ARGV if $cmd == 2;
}
if( $cmd == 3 ) {
$res ||= 'y';
# This will break out when the pipe reader exits, but not die
1 while print $res, $nonewline ? () : "\n";
} else {
print $res, $nonewline || $cmd == 2 ? () : "\n" or die $!;
}
die "false\n" if $cmd == 1 && !$res;
} qw(f o O),
$cmd != 1 ? 'E' : (),
$cmd != 2 ? ['n', qr/no[-_]?newline/, \$nonewline] : ();
}
sub c_expr { c_echo \1, @_ }
sub c_printf { c_echo \2, @_ }
sub c_yes { c_echo \3, @_ }
sub c_grep {
my $cmd;
local @ARGV = @_; # for <>
$cmd = ${shift @ARGV} if ref $_[0];
my( $fn, $n, $revert, $count, $list, $waste ) = (0, 0, 0);
frame {
my $prog = eval_or_die 'sub {' . shift( @ARGV ) . "\n}";
perform {
open my $fh, '>', $waste;
$waste = $fh;
} "write `$waste'" if $waste;
while( <> ) {
if( $cmd ) {
&$prog;
&print if $cmd == 2;
} elsif( $revert == 1 ? !&$prog : &$prog ) {
$n++;
if( !$list ) {
$count or &print;
} elsif( $revert == 2 ) {
$fn++ ;
} else {
print "$ARGV\n" or die $!;
close ARGV;
}
} elsif( $waste ) {
print $waste $_ or die $!;
}
if( $list && $revert > 1 && eof ) {
print "$ARGV\n" or die $! if !$fn;
$fn = 0;
}
close ARGV if $synclines && eof;
}
print "$n\n" or die $! if $count;
close $waste if $waste;
die "no matches\n" unless $cmd or $n or $count;
} qw(f i I o O r s S),
($cmd ? () :
([qw(c count), \$count],
['l', qr/list|files[-_]?with[-_]?matches/, \$list],
['v', qr/vice[-_]?versa|(?:re|in)vert[-_]?match/, \$revert],
['w', qr/waste[-_]?file/, \$waste, 1]));
}
sub c_perl { c_grep \1, @_ }
sub c_sed { c_grep \2, @_ }
sub c_install {
local @ARGV = @_;
my $dest = pop @ARGV;
my( $mode, $gid, $uid, $copy, $link, $symbolic, $resolve, $log, $directory, $strip ) = 755;
frame {
my $i = 2;
--$i, defined() && !/^\d+$/ and
defined( $_ = $i ? getpwnam( $_ ) : getgrnam( $_ )) || die $i ? 'user' : 'group', " unknown\n"
for $uid, $gid;
local $install_date = localtime() . " [$$]\n";
my $fh; # Don't open $install_log directly as that logs to itself.
$log ||= $ENV{INSTALL_LOG} ||
($CWD_INFO->{ROOT} ? relative_filename( $CWD_INFO->{ROOT} ) : '.') .
'/.install_log';
perform { open $fh, '>>', $log } "append to `$log'";
local $install_log = $fh;
my @dest;
if( $directory ) {
warn "$0: options --copy, --link or --strip make no sence with --directory\n"
if $copy || $link || $symbolic || $resolve || $strip;
@dest = c_mkdir( '-pm', $mode, @ARGV, $dest );
} else {
($copy, $link) = $link ? (\&c_cp, '-l') :
$copy ? \&c_cp :
$symbolic ? (\&c_ln, '-s') :
$resolve ? (\&c_ln, '-r') :
\&c_mv;
for( @ARGV ) {
&$copy( $link ? $link : (), $_, $dest );
-d( $dest ) ? s!^(?:.*/)?!$dest/! : ($_ = $dest);
push @dest, $_;
}
perform { system 'strip', @dest } "strip `@dest'" if $strip;
c_chmod $mode, @dest;
}
if( defined $uid || defined $gid ) {
# Why doesn't Perl make undef the portable way of leaving id unchanged? :-(
perform { chown defined $uid ? $uid : (stat)[4], defined $gid ? $gid : (stat)[5], $_ }
defined $uid && defined $gid ? "set owner $uid and group $gid for `$_'" :
defined $uid ? "set owner $uid for `$_'" :
"set group $gid for `$_'"
for @dest;
}
} [qw(c copy), \$copy],
[qw(d directory), \$directory],
[qw(g group), \$gid, 1],
[qw(l link), \$link],
[undef, qr/log(?:file)?/, \$log, 1],
[qw(m mode), \$mode, 1],
[qw(o owner), \$uid, 1],
['S', qr/sym(?:bolic(?:[-_]?link)?|link)/, \$symbolic],
['r', qr/resolve[-_]?(?:sym(?:bolic(?:[-_]?link)?|link))?/, \$resolve],
[qw(s strip), \$strip];
}
sub c_ln {
local @ARGV = @_;
my( $symbolic, $resolve );
frame {
my $dest = @ARGV == 1 ? '.' : pop @ARGV;
$dest =~ s|/+$||;
my $d = -d $dest;
for( @ARGV ) {
my $dirdest = $d ? $dest . '/' . f_notdir $_ : $dest;
_rm $dirdest if $force && ($d ? -l( $dirdest ) || -e _ : defined $d);
if( NO_LINK == NO_SYMLINK ? NO_LINK : NO_SYMLINK == ($resolve || $symbolic || 0) ) {
$_ = f_relative_filename f_dir( $dirdest ) . $_
if $symbolic && !$resolve;
require File::Copy;
perform { File::Copy::syscopy( $_, $dirdest ) } "copy `$_' to `$dirdest'";
} elsif( $resolve || $symbolic ) {
$_ = f_relative_to $_ . ',' . f_dir $dirdest if $resolve;
perform { symlink $_, $dirdest } "link `$_' to `$dirdest' symbolically";
} else {
perform { link $_, $dirdest } "link `$_' to `$dirdest'";
}
}
} 'f',
['r', qr/resolve[-_]?(?:sym(?:bolic(?:[-_]?link)?|link))?/, \$resolve],
['s', qr/sym(?:bolic(?:[-_]?link)?|link)/, \$symbolic];
}
sub c_mkdir {
local @ARGV = @_;
my( $mode, $parent );
frame {
$mode = umask ~oct $mode if defined $mode;
my @created;
for( @ARGV ) {
if( $parent ) {
my $dir = '';
for( split /(?=\/)/ ) {
$dir .= $_;
next if -d $dir;
_rm $dir if $force && -e _;
perform { (my $d = $dir) =~ s!/+$!!; mkdir $d or $! == POSIX::EEXIST && -d $dir } "create directory `$dir'";
push @created, $dir;
}
} elsif( ! -d ) {
_rm $_ if $force && -e _;
perform { (my $d = $_) =~ s!/+$!!; mkdir $d } "create directory `$_'";
push @created, $_;
}
}
umask $mode if defined $mode;
@created;
} 'f',
[qw(m mode), \$mode, 1],
[qw(p parent), \$parent];
}
my $package_seed = 0;
sub c_preprocess {
$Mpp::Rule::unsafe = 1; # Chdir`s and might perform some Perl code.
local @ARGV = @_;
my( $command_line_vars, $assignment, $tmp ) = {};
frame {
# Functions need not be eliminated because they get explicitly invoked via $(...), whereas
# any word at the beginning of line might be a statement, so import only the usefuls.
my $cwd = $CWD_INFO;
local $Mpp::Makefile::c_preprocess = $assignment ? 1 : 2;
for( @ARGV ) {
perform {
my $finfo = file_info $_, $cwd;
local $Mpp::Makefile::makefile = bless
{ MAKEFILE => $finfo,
PACKAGE => 'preprocess_' . $package_seed++,
CWD => $finfo->{'..'},
COMMAND_LINE_VARS => $command_line_vars,
ENVIRONMENT => $Mpp::Subs::rule->{MAKEFILE}{ENVIRONMENT}
}, 'Mpp::Makefile';
chdir $finfo->{'..'};
eval "package $Mpp::Makefile::makefile->{PACKAGE}; use Mpp::Subs qr/f_|s_(?:_?include|(?:make)?(?:perl|sub)|perl_begin" .
($assignment ? '|unexport' : '') .
')/';
Mpp::Makefile::read_makefile( $Mpp::Makefile::makefile, $finfo ); 1;
} "preprocess `$_'";
}
} $command_line_vars,
qw(f o O S),
[qw(a assignment), \$assignment],
[qw(h hashref), \$tmp, 1, sub { $tmp = eval_or_die $tmp; $command_line_vars->{$_} = $tmp->{$_} for keys %$tmp }];
}
sub c_rm {
local @ARGV = @_;
my $meta;
frame {
my %makepp;
if( $meta ) {
for( @ARGV ) {
m!(.*?)([^/]+)$!;
$makepp{"$1.makepp"} = 1 if unlink "$1.makepp/$2.mk";
}
}
@ARGV = grep -e || -l, @ARGV if $force;
rmdir for keys %makepp;
_rm @ARGV;
} 'f',
[qw(m metainfo), \$meta];
}
sub c_sort {
local @ARGV = @_; # for <>
my( $uniq, $cmp, $rev, $transform, $detransform ) = '';
frame {
$uniq &&= 'grep { $a = $_, 1 if !defined $a or ' . ($cmp ? "do { \$b = \$_; $cmp }}" : '$a cmp $_ }');
$uniq .= ' reverse' if $rev;
print
$transform ? eval_or_die "map { $detransform } $uniq sort " . ($cmp ? "{ $cmp } " : '') . "map { $transform } <>" :
$cmp ? eval_or_die "$uniq sort { $cmp } <>" :
$uniq ? eval_or_die "$uniq sort <>" :
$rev ? reverse sort <> :
sort <>
or die $!;
eval_or_die 'undef $a' if $uniq;
} qw(f i I o O r s),
[qw(c compare), \$cmp, 1],
['n', qr/num(?:eric(?:[-_]?sort)?)?/, \$cmp, undef, q{ do { no warnings; $a <=> $b }}],
# Eliminate ugly warning about trailing non-digits
[qw(r reverse), \$rev],
[qw(t transform), \$transform, 1],
[qw(d detransform), \$detransform, 1],
['u', qr/uniq(?:ue)?/, \$uniq];
}
sub c_template {
local @ARGV = @_; # for <>
my( %macros, $tmp );
my( $pre, $suf, $Pre, $Suf, $afterPre, $afterSuf, $re ) = qw(@ @(?:\\\\\n)? @@ @@ @@(?:\\\\\n)?);
frame {
# Always have a () for multiline, in lst case one that never matches
my $pre_re = length( $Pre ) ? (length( $pre ) ? qr/$Pre()|$pre/ : qr/$Pre()/) : qr/$pre|$pre()/;
my $suf_re = length( $Suf ) ? (length( $suf ) ? $Pre eq $pre ? qr/$Suf()|$suf/ : qr/(?(2)$Suf()|$suf)/ : qr/$Suf()/) : qr/$suf/;
my $handler = sub {
my $line;
while( s/(.*?) $pre_re (?:($re)(?:\((.*?)\))? | \{(.*?)\} | (\w[-\w.]*)(?:(\?)?=(.*?) | \s*(\{.*?\})) | \#().*?) $suf_re//sx ) {
if( defined $line ) {
$line .= $1;
} else {
$line = $1;
}
my( $name, $args, $perl, $def, $optdef, $value, $defcode, $comment ) = ($3, $4, $5, $6, $7, $8, $9, $10);
if( defined $2 && defined $11 ) { # multiline?
my $end = $afterSuf ? qr/$name$afterSuf/ : '';
until( s/.*?$afterPre$end// ) {
if( eof ) {
warn "$ARGV:$.: $Pre$name$Suf unterminated\n";
$_ = '';
last;
}
$_ = <>;
}
}
next if defined $comment;
if( defined $def ) { # @macro=def@
if( exists $macros{$def} ) {
next if $optdef; # @macro?=def@
} else {
$re = ($re ? "$re|" : '') . $def;
}
$macros{$def} = $defcode ? eval_or_die( "sub $defcode" ) : $value;
# @macro { Perlcode }@
} elsif( defined $perl ) { # @{ Perlcode }@
$line .= eval_or_die $perl;
} else { # @macro@ or @macro(arg1,arg2...)@
if( defined( my $val = $macros{$name} ) ) {
my @args = map { s/$pre($re)$suf/$macros{$1}/g; $_ } split ',', $args if $args;
if( ref $val ) {
$val = &$val( @args );
} elsif( $args ) { # @macro(arg1,arg2...)@
$val =~ s/\$([1-9])/$1 > @args ? '' : $args[$1-1]/ge;
$val =~ s/\$\{([1-9]\d*)\}/$1 > @args ? '' : $args[$1-1]/ge;
}
$line .= $val;
}
}
}
substr $_, 0, 0, $line if defined $line; # push transformed stuff back to front
};
$macros{include} ||= sub {
$tmp = $.; # not reading this gets confused by switching filehandles at least till 5.20
local $_ = $_[0];
s/^\s+//; s/\s+$//;
open my $fh, '<', $_ or die "$ARGV:$.: can't open file `$_'--$!\n";
local $ARGV = $_;
my $res = '';
while( <$fh> ) {
&$handler;
$res .= $_;
}
$res;
};
$re = $re ? join( '|', keys %macros ) : qr/\w[-\w.]*/;
while( <> ) {
&$handler;
&print;
close ARGV if $synclines && eof;
}
} \%macros, qw(f i I o O r s S),
[qw(h hashref), \$tmp, 1, sub { $tmp = eval_or_die $tmp; $macros{$_} = $tmp->{$_} for keys %$tmp }],
[qw(s simple), \$pre, 1,
sub {
(undef, $pre, $suf) = split quotemeta( substr $pre, 0, 1 ), $pre;
}],
[qw(m multiline), \$Pre, 1,
sub {
(undef, $Pre, $Suf, $afterPre, $afterSuf) = split quotemeta( substr $Pre, 0, 1 ), $Pre;
}],
[qw(d defined), \$re];
}
sub c_touch {
local @ARGV = @_;
frame {
my $time = time; # 5.8.0 should but doesn't support undef, undef
for( @ARGV ) {
if( -f ) {
perform { utime $time, $time, $_ } "update timestamp on `$_'";
} else {
perform { open my $fh, '>', $_ } "create `$_'";
}
}
};
}
sub c_uninstall {
local @ARGV = @_; # for <>
frame {
@ARGV = $ENV{INSTALL_LOG} ||
($CWD_INFO->{ROOT} ? relative_filename( $CWD_INFO->{ROOT} ) : '.') .
'/.install_log'
unless $inpipe || @ARGV;
my %files;
/^ .* `(.+)'/ and $files{$1} = 1 while <>;
eval { _rm sort keys %files };
} qw(i I);
}
sub c_uniq {
local @ARGV = @_; # for <>
my $cmp;
frame {
$cmp = eval_or_die "sub {$cmp\n}" if $cmp;
no strict 'refs';
local *a = \${"$Mpp::Subs::rule->{MAKEFILE}{PACKAGE}::a"};
local *b = \${"$Mpp::Subs::rule->{MAKEFILE}{PACKAGE}::b"};
local *_ = \$b; # For print.
undef $a;
while( $b = <> ) {
&print if !defined $a or $cmp ? &$cmp() : $a ne $b;
$a = $b;
close ARGV if $synclines && eof;
}
} qw(f i I o O r s S),
[qw(c compare), \$cmp, 1];
}
1;