1# $Id: Cmds.pm,v 1.67 2011/08/27 16:25:22 pfeiffer Exp $ 2 3=head1 NAME 4 5Mpp::Cmds - Builtin commands for makefiles 6 7=head1 DESCRIPTION 8 9This package contains builtin commands similar to common utilities, which can 10be called from a rule, as well as in a functional way or as top level 11statements. 12 13=cut 14 15 16# TODO: autoload these commands only when needed 17# Use file_info -- or don't, because we'd have to refresh it before every new cmd. 18 19# builtin commands 20package Mpp::Cmds; 21 22use strict; 23use Mpp::Text (); 24use Mpp::File; 25use Mpp::Subs; 26use POSIX (); 27 28BEGIN { 29 my $ln_cp = $ENV{MAKEPP_LN_CP} || 0; 30 *NO_LINK = $Mpp::Text::N[$ln_cp & 2 ? 1 : 0]; 31 *NO_SYMLINK = $Mpp::Text::N[$ln_cp & 1 || 0]; 32} 33 34sub eval_or_die($) { 35 $Mpp::Rule::unsafe = 1; 36 Mpp::Subs::eval_or_die $_[0], $Mpp::Subs::rule->{MAKEFILE}, $Mpp::Subs::rule->{RULE_SOURCE}; 37} 38 39 40# perform one step and log or die as appropriate 41our( $install_date, $install_log ); 42sub perform(&$;$) { 43 if( eval { &{$_[0]} } && !$@ ) { 44 print STDERR "$0: $_[1]\n" if $Mpp::verbose; 45 if( $install_log ) { 46 my $msg = $_[1]; 47 my $cwd = absolute_filename $CWD_INFO; 48 $msg =~ s|`(?=[^/`][^`]*$)|`$cwd/|; 49 if( $Mpp::Event::max_proc > 1 ) { 50 flock $install_log, 2; # Lock exclusive. 51 if( $install_date =~ /^ / ) { # Additional output 52 if( (stat $install_log)[7] > tell $install_log ) { 53 # Size changed by concurrent proc 54 seek $install_log, 0, 2; 55 print $install_log "$install_date $msg\n" or die $!; 56 } else { 57 print $install_log " $msg\n" or die $!; 58 } 59 } else { 60 seek $install_log, 0, 2; 61 print $install_log "$install_date $msg\n" or die $!; 62 $install_date = " $install_date"; 63 } 64 flock $install_log, 8; # Unlock. 65 } else { 66 print $install_log "$install_date $msg\n" or die $!; 67 } 68 $install_date = ''; 69 } 70 1; 71 } elsif( !$_[2] ) { 72 die "could not $_[1]--". ($@ || $!) . "\n"; 73 } 74} 75 76 77# deletion files first, then directories depth first 78sub _rm { 79 my @dirs; 80 perform { unlink } "delete `$_'" 81 for grep { -l || !-d _ ? $_ : !push @dirs, $_ } @_; 82 perform { rmdir } "delete directory `$_'" 83 for sort { my( $A, $B ) = ($a, $b); ($B =~ tr:/::d) <=> ($A =~ tr:/::d) } @dirs; 84} 85 86 87# Explicit variables for options shared by several commands. 88my( $noescape, $force, $inpipe, $print, $print_nl, $synclines, $last_file, $last_line ); 89 90 91# Do buffered output of $_ with optional synclines. 92sub print { 93 if( defined and length ) { 94 if( $synclines ) { 95 if( $last_file ne $ARGV ) { 96 $print_nl or $print .= "\n"; 97 $print .= "#line $. \"$ARGV\"\n"; 98 $last_file = $ARGV; 99 $last_line = $.; 100 } elsif( ++$last_line != $. ) { 101 $print_nl or $print .= "\n"; 102 $print .= "#line $.\n"; 103 $last_line = $.; 104 } 105 if( /^\s*#\s*line\s+\d+(\s+\")?/m ) { # Replacement contains #line. 106 $_ .= '#line ' . ($. + 1) . ($1 ? " \"$ARGV\"\n" : "\n"); 107 } else { 108 s/\n(?!\z)/\n#line $.\n/g; # Multiple lines generated from one source line. 109 } 110 $print_nl = /\n\z/; # Did we end with a nl? 111 } 112 $print .= $_; # Buffer up to about 8kb. 113 if( 8 * 1024 < length $print ) { 114 # Mixing this with a final print is ok, as buffering comes last. syswrite is faster only from 3kb upwards. 115 syswrite select, $print or die $!; 116 $print = ''; 117 } 118 } 119} 120 121 122# Frame which handles options, I/O and adds omnipresent --verbose. 123sub frame(&@) { 124 my( $code, @opts, @stdopts ) = @_; 125 local $Mpp::verbose = $Mpp::verbose; 126 127 my( $infail, $inout, $output, $pipe, $select, $outfail, $separator ); 128 # Standard options shared by several commands. 129 my %opt = 130 (E => ['E', qr/no[-_]?escape/, \$noescape], 131 f => [qw(f force), \$force], 132 i => [qw(i inpipe), \$inpipe, 1], 133 I => [qw(I infail), \$infail], 134 o => [qw(o output), \$output, 1], 135 O => [qw(O outfail), \$outfail], 136 r => ['r', qr/record[-_]?size/, \$separator, 1, sub { $separator = eval "\\$separator" }], 137 s => [qw(s separator), \$separator, 1], 138 S => ['S', qr/sync[-_]?lines/, \$synclines]); 139 140 @opts = grep { # Put stds last, so they don't override short opts. 141 ref or !push @stdopts, $opt{$_}; 142 } @opts; 143 Mpp::Text::getopts @opts, @stdopts, 144 [qw(v verbose), \$Mpp::verbose]; 145 146 # Setup input context. 147 local $/ = $separator if defined $separator; 148 #local *STDIN if $inpipe or $output && $output =~ /^\+</; # Causes input to hang :-( 149 if( $inpipe ) { 150 $inpipe =~ s/\|$//s; 151 perform { open STDIN, '-|', $inpipe } "call `$inpipe|'"; 152 } 153 local $SIG{__WARN__} = sub { 154 if( $_[0] =~ /^Can't open (.*?): $! at/ ) { 155 die "$0: cannot open `$1'--$!\n"; 156 } else { 157 warn $_[0]; 158 } 159 }; 160 161 # Setup output context. 162 $print = ''; $print_nl = 1; 163 $last_file = '' if $synclines; 164 local *STDOUT if $output; 165 if( $output ) { 166 my $first = ord $output; 167 $pipe = $first == ord '|'; 168 if( $pipe or $first != ord '+' or $output !~ /^\+</ ) { 169 if( !$pipe and $force ) { 170 my $file = $output; 171 $file =~ s/^>\s*//; 172 _rm $file if -e $file; 173 } 174 perform { open STDOUT, ($pipe or $first == ord '>') ? $output : ">$output" } "write `$output'"; 175 } else { 176 $output =~ s/^\+<((.*?)[^\/]+)$/$1/; 177 # open temp file in same dir as output, so we can rename later 178 $inout = "$2.makepp.$$" . substr rand, 1; 179 perform { open STDIN, $output and open STDOUT, '>', $inout } 180 "read `$output' and write to tempfile"; 181 } 182 $select = select STDOUT; 183 } 184 local $SIG{PIPE} = 'IGNORE' if $pipe; 185 186 my @res = eval { &$code }; 187 my $err = $@; 188 189 # throw the proper diagnostics as to why close failed 190 sub _closedie($) { 191 die "`$_[0]' ", 192 $! ? "failed to close--$!" : 193 ($? & 127) ? "died with signal " . ($? & 127) : 194 "exited with value " . ($? >> 8); 195 } 196 197 # Cleanup if any I/O is open. 198 if( $inpipe && $infail or $inout ) { 199 close STDIN or _closedie $inpipe; 200 open STDIN, '/dev/null'; # placeholder file handle as long as not local 201 } 202 print $print or die $! if length $print; 203 $print = ''; # In case of nested commands. 204 if( $output ) { 205 close STDOUT or $outfail && _closedie $output; 206 perform { rename $inout, $output } "rename tempfile to `$output'" if $inout; 207 select $select; 208 } 209 undef ${$$_[2]} for @stdopts; 210 die $err if $err; 211 @res; 212} 213 214 215# variant that returns what it chomped 216sub _chomp(\$) { 217 return '' if ref $/; 218 my $tail = ${$_[0]}; 219 my $len = chomp ${$_[0]}; 220 return '' unless $len; 221 substr $tail, -$len; 222} 223 224 225sub c_cat { 226 local @ARGV = @_; 227 frame { 228 require File::Copy; 229 if( $synclines ) { 230 local $/ = \8192; 231 while( <> ) { 232 if( $. == 1 ) { # Can't use &print, as that "corrects" \n to same #line directive 233 print $print_nl ? '' : "\n", "#line 1 \"$ARGV\"\n$_"; 234 } else { 235 print; 236 } 237 $print_nl = /\n\z/; # Did we end with a nl? 238 close ARGV if eof; 239 } 240 } else { 241 perform { File::Copy::copy( $_, \*STDOUT ) } "copy `$_'" for @ARGV; 242 } 243 } 'f', qw(i I o O S); # fails in 5.6: qw(f i I o O S); 244} 245 246 247sub c_chmod { 248 local @ARGV = @_; 249 frame { 250 my $mode = oct shift @ARGV; 251 perform { chmod $mode, $_ } "set mode for `$_'" 252 for @ARGV; 253 }; 254} 255 256 257 258sub c_cp { 259 my $mv; # must separate my from if, or it survives multiple calls 260 local @ARGV = @_; 261 $mv = shift @ARGV if ref $_[0]; 262 my( $link, $symbolic ); 263 frame { 264 undef $link if NO_LINK; 265 undef $symbolic if NO_SYMLINK; 266 my $dest = @ARGV == 1 ? '.' : pop @ARGV; 267 require File::Copy; 268 my $cmd = $mv ? 'move' : 'copy'; 269 $mv = $mv ? \&File::Copy::move : \&File::Copy::syscopy; 270 for( @ARGV ) { 271 my $d = -d $dest; 272 my $dirdest = $d ? $dest . '/' . f_notdir $_ : $dest; 273 _rm $dirdest if $force && ($d ? -e( $dirdest ) : defined $d); 274 $link && perform { link $_, $dirdest } "link `$_' to `$dirdest'", 1 275 or $symbolic && perform { symlink f_relative_to( $_ . ',' . f_dir $dirdest ), $dirdest } "link `$_' to `$dirdest' symbolically", 1 276 or perform { &$mv( $_, $dirdest ) } "$cmd `$_' to `$dirdest'"; 277 } 278 } 'f', 279 $mv ? () : 280 ([qw(l link), \$link], 281 ['s', qr/sym(?:bolic(?:[-_]?link)?|link)/, \$symbolic]); 282} 283sub c_mv { c_cp \1, @_ } 284 285 286sub c_cut { 287 local @ARGV = @_; # for <> 288 my( $delimiter, $characters, $fields, $lines, $matching, $printf, $only_delim ) = "\t"; 289 my $err = "one of --characters, --fields or --lines must be given\n"; 290 frame { 291 my $split = eval 292 'sub { @::F = ' . (!$characters ? "split /\Q$delimiter\E/, \$_, -1 }" : 293 Mpp::is_perl_5_6 ? 'split //, $_, -1 }' : 294 'unpack "(a1)*", $_ }'); 295 my( @idxs, $eol ); 296 local @::F; # Use Perl's autosplit variable into Makeppfile's package 297 @idxs = eval_or_die $fields 298 unless $fields =~ /^[-+.,\d\s]+$/ && 299 $fields =~ s/((?:,|^)\d+\.\.)-/"$1\$#::F+" . (defined $lines ? '2-' : '1-')/eg; 300 if( defined $lines ) { 301 warn "options --matching or --printf make no sence with --lines\n" if $matching || $only_delim || $printf; 302 while( <> ) { 303 push @::F, $_; 304 if( eof ) { 305 for my $line (@idxs ? @idxs : eval_or_die $fields) { 306 $line or die "$0: line numbers start at 1, not 0\n"; 307 $. = $line > 0 ? $line : @::F + 1 + $line; # Lines count from 1. 308 $_ = $::F[$. - 1]; 309 &print; 310 } 311 close ARGV; 312 @::F = (); 313 } 314 } 315 } elsif( defined $fields ) { 316 if( $printf && !$noescape ) { 317 $printf =~ s/([\$\@!])/\\$1/g; # protect variable chars and next line's quote 318 $printf = eval "qq!$printf!"; 319 die $@ if $@; 320 } 321 while( <> ) { 322 $eol = _chomp $_; 323 &$split; 324 if( @::F > 1 ) { 325 @::F = map { defined() ? $_ : $matching ? next : '' } @::F[@idxs ? @idxs : eval_or_die $fields]; 326 $_ = $printf ? 327 sprintf( $printf, @::F ) : 328 join( $delimiter, @::F ) . $eol; 329 } elsif( $matching || $only_delim ) { 330 next; 331 } else { 332 $_ .= $eol; 333 } 334 &print; 335 close ARGV if $synclines && eof; 336 } 337 } else { 338 die $err; 339 } 340 } qw(E f i I o O r s S), 341 [qw(c characters), \$characters, 1, sub { $delimiter = ''; warn $err if defined $fields; $fields = $characters }], 342 [qw(d delimiter), \$delimiter, 1], 343 [qw(f fields), \$fields, 1, sub { warn $err if defined $characters or defined $lines }], 344 [qw(l lines), \$lines, 1, sub { warn $err if defined $fields; $fields = $lines }], 345 [qw(m matching), \$matching], 346 [qw(p printf), \$printf, 1], 347 ['s', qr/only[-_]?delimited/, \$only_delim]; 348} 349 350 351sub c_echo { 352 my $cmd = 0; 353 local @ARGV = @_; 354 $cmd = ${shift @ARGV} if ref $_[0]; 355 my $nonewline; 356 frame { 357 my $res; 358 if( $cmd == 1 ) { 359 $res = eval_or_die "@ARGV" if @ARGV; 360 $res = '' unless defined $res; 361 } else { 362 $res = $cmd == 2 ? shift @ARGV : "@ARGV"; 363 unless( $noescape ) { 364 $res =~ s/([\$\@!])/\\$1/g; # protect variable chars and next line's quote 365 $res = eval "qq!$res!"; 366 die $@ if $@; 367 } 368 $res = sprintf $res, @ARGV if $cmd == 2; 369 } 370 if( $cmd == 3 ) { 371 $res ||= 'y'; 372 # This will break out when the pipe reader exits, but not die 373 1 while print $res, $nonewline ? () : "\n"; 374 } else { 375 print $res, $nonewline || $cmd == 2 ? () : "\n" or die $!; 376 } 377 die "false\n" if $cmd == 1 && !$res; 378 } qw(f o O), 379 $cmd != 1 ? 'E' : (), 380 $cmd != 2 ? ['n', qr/no[-_]?newline/, \$nonewline] : (); 381} 382sub c_expr { c_echo \1, @_ } 383sub c_printf { c_echo \2, @_ } 384sub c_yes { c_echo \3, @_ } 385 386 387sub c_grep { 388 my $cmd; 389 local @ARGV = @_; # for <> 390 $cmd = ${shift @ARGV} if ref $_[0]; 391 my( $fn, $n, $revert, $count, $list, $waste ) = (0, 0, 0); 392 frame { 393 my $prog = eval_or_die 'sub {' . shift( @ARGV ) . "\n}"; 394 perform { 395 open my $fh, '>', $waste; 396 $waste = $fh; 397 } "write `$waste'" if $waste; 398 while( <> ) { 399 if( $cmd ) { 400 &$prog; 401 &print if $cmd == 2; 402 } elsif( $revert == 1 ? !&$prog : &$prog ) { 403 $n++; 404 if( !$list ) { 405 $count or &print; 406 } elsif( $revert == 2 ) { 407 $fn++ ; 408 } else { 409 print "$ARGV\n" or die $!; 410 close ARGV; 411 } 412 } elsif( $waste ) { 413 print $waste $_ or die $!; 414 } 415 if( $list && $revert > 1 && eof ) { 416 print "$ARGV\n" or die $! if !$fn; 417 $fn = 0; 418 } 419 close ARGV if $synclines && eof; 420 } 421 print "$n\n" or die $! if $count; 422 close $waste if $waste; # Sometimes needed on Solaris with V5.6. 423 die "no matches\n" unless $cmd or $n or $count; 424 } qw(f i I o O r s S), 425 ($cmd ? () : 426 ([qw(c count), \$count], 427 ['l', qr/list|files[-_]?with[-_]?matches/, \$list], 428 ['v', qr/vice[-_]?versa|(?:re|in)vert[-_]?match/, \$revert], 429 ['w', qr/waste[-_]?file/, \$waste, 1])); 430} 431sub c_perl { c_grep \1, @_ } 432sub c_sed { c_grep \2, @_ } 433 434 435sub c_install { 436 local @ARGV = @_; 437 my $dest = pop @ARGV; 438 my( $mode, $gid, $uid, $copy, $link, $symbolic, $resolve, $log, $directory, $strip ) = 755; 439 frame { 440 my $i = 2; 441 --$i, defined() && !/^\d+$/ and 442 defined( $_ = $i ? getpwnam( $_ ) : getgrnam( $_ )) || die $i ? 'user' : 'group', " unknown\n" 443 for $uid, $gid; 444 local $install_date = localtime() . " [$$]\n"; 445 my $fh; # Don't open $install_log directly as that logs to itself. 446 $log ||= $ENV{INSTALL_LOG} || 447 ($CWD_INFO->{ROOT} ? relative_filename( $CWD_INFO->{ROOT} ) : '.') . 448 '/.install_log'; 449 perform { open $fh, '>>', $log } "append to `$log'"; 450 local $install_log = $fh; 451 my @dest; 452 if( $directory ) { 453 warn "options --copy, --link or --strip make no sence with --directory\n" 454 if $copy || $link || $symbolic || $resolve || $strip; 455 @dest = c_mkdir( '-pm', $mode, @ARGV, $dest ); 456 } else { 457 ($copy, $link) = $link ? (\&c_cp, '-l') : 458 $copy ? \&c_cp : 459 $symbolic ? (\&c_ln, '-s') : 460 $resolve ? (\&c_ln, '-r') : 461 \&c_mv; 462 for( @ARGV ) { 463 &$copy( $link ? $link : (), $_, $dest ); 464 -d( $dest ) ? s!^(?:.*/)?!$dest/! : ($_ = $dest); 465 push @dest, $_; 466 } 467 perform { system 'strip', @dest } "strip `@dest'" if $strip; 468 c_chmod $mode, @dest; 469 } 470 if( defined $uid || defined $gid ) { 471 # Why doesn't Perl make undef the portable way of leaving id unchanged? :-( 472 perform { chown defined $uid ? $uid : (stat)[4], defined $gid ? $gid : (stat)[5], $_ } 473 defined $uid && defined $gid ? "set owner $uid and group $gid for `$_'" : 474 defined $uid ? "set owner $uid for `$_'" : 475 "set group $gid for `$_'" 476 for @dest; 477 } 478 } [qw(c copy), \$copy], 479 [qw(d directory), \$directory], 480 [qw(g group), \$gid, 1], 481 [qw(l link), \$link], 482 [undef, qr/log(?:file)?/, \$log, 1], 483 [qw(m mode), \$mode, 1], 484 [qw(o owner), \$uid, 1], 485 ['S', qr/sym(?:bolic(?:[-_]?link)?|link)/, \$symbolic], 486 ['r', qr/resolve[-_]?(?:sym(?:bolic(?:[-_]?link)?|link))?/, \$resolve], 487 [qw(s strip), \$strip]; 488} 489 490 491sub c_ln { 492 local @ARGV = @_; 493 my( $symbolic, $resolve ); 494 frame { 495 my $dest = @ARGV == 1 ? '.' : pop @ARGV; 496 $dest =~ s|/+$||; 497 my $d = -d $dest; 498 for( @ARGV ) { 499 my $dirdest = $d ? $dest . '/' . f_notdir $_ : $dest; 500 _rm $dirdest if $force && ($d ? -l( $dirdest ) || -e _ : defined $d); 501 if( NO_LINK == NO_SYMLINK ? NO_LINK : NO_SYMLINK == ($resolve || $symbolic || 0) ) { 502 $_ = f_relative_filename f_dir( $dirdest ) . $_ 503 if $symbolic && !$resolve; 504 require File::Copy; 505 perform { File::Copy::syscopy( $_, $dirdest ) } "copy `$_' to `$dirdest'"; 506 } elsif( $resolve || $symbolic ) { 507 $_ = f_relative_to $_ . ',' . f_dir $dirdest if $resolve; 508 perform { symlink $_, $dirdest } "link `$_' to `$dirdest' symbolically"; 509 } else { 510 perform { link $_, $dirdest } "link `$_' to `$dirdest'"; 511 } 512 } 513 } 'f', 514 ['r', qr/resolve[-_]?(?:sym(?:bolic(?:[-_]?link)?|link))?/, \$resolve], 515 ['s', qr/sym(?:bolic(?:[-_]?link)?|link)/, \$symbolic]; 516} 517 518 519sub c_mkdir { 520 local @ARGV = @_; 521 my( $mode, $parent ); 522 frame { 523 $mode = umask ~oct $mode if defined $mode; 524 my @created; 525 for( @ARGV ) { 526 if( $parent ) { 527 my $dir = ''; 528 for( split /(?=\/)/ ) { 529 $dir .= $_; 530 next if -d $dir; 531 _rm $dir if $force && -e _; 532 perform { (my $d = $dir) =~ s!/+$!!; mkdir $d or $! == POSIX::EEXIST && -d $dir } "create directory `$dir'"; 533 push @created, $dir; 534 } 535 } elsif( ! -d ) { 536 _rm $_ if $force && -e _; 537 perform { (my $d = $_) =~ s!/+$!!; mkdir $d } "create directory `$_'"; 538 push @created, $_; 539 } 540 } 541 umask $mode if defined $mode; 542 @created; 543 } 'f', 544 [qw(m mode), \$mode, 1], 545 [qw(p parent), \$parent]; 546} 547 548 549my $package_seed = 0; 550sub c_preprocess { 551 $Mpp::Rule::unsafe = 1; # Chdir`s and might perform some Perl code. 552 local @ARGV = @_; 553 my( $command_line_vars, $assignment, $tmp ) = {}; 554 frame { 555 # Functions need not be eliminated because they get explicitly invoked via $(...), whereas 556 # any word at the beginning of line might be a statement, so import only the usefuls. 557 my $cwd = $CWD_INFO; 558 local $Mpp::Makefile::c_preprocess = $assignment ? 1 : 2; 559 for( @ARGV ) { 560 perform { 561 my $finfo = file_info $_, $cwd; 562 local $Mpp::Makefile::makefile = bless 563 { MAKEFILE => $finfo, 564 PACKAGE => 'preprocess_' . $package_seed++, 565 CWD => $finfo->{'..'}, 566 COMMAND_LINE_VARS => $command_line_vars, 567 ENVIRONMENT => $Mpp::Subs::rule->{MAKEFILE}{ENVIRONMENT} 568 }, 'Mpp::Makefile'; 569 chdir $finfo->{'..'}; 570 eval "package $Mpp::Makefile::makefile->{PACKAGE}; use Mpp::Subs qr/f_|s_(?:_?include|(?:make)?(?:perl|sub)|perl_begin" . 571 ($assignment ? '|unexport' : '') . 572 ')/'; 573 Mpp::Makefile::read_makefile( $Mpp::Makefile::makefile, $finfo ); 1; 574 } "preprocess `$_'"; 575 } 576 } $command_line_vars, 577 qw(f o O S), 578 [qw(a assignment), \$assignment], 579 [qw(h hashref), \$tmp, 1, sub { $tmp = eval_or_die $tmp; $command_line_vars->{$_} = $tmp->{$_} for keys %$tmp }]; 580} 581 582 583sub c_rm { 584 local @ARGV = @_; 585 my $meta; 586 frame { 587 my %makepp; 588 if( $meta ) { 589 for( @ARGV ) { 590 m!(.*?)([^/]+)$!; 591 $makepp{"$1.makepp"} = 1 if unlink "$1.makepp/$2.mk"; 592 } 593 } 594 @ARGV = grep -e || -l, @ARGV if $force; 595 rmdir for keys %makepp; 596 _rm @ARGV; 597 } 'f', 598 [qw(m metainfo), \$meta]; 599} 600 601 602 603sub c_sort { 604 local @ARGV = @_; # for <> 605 my( $uniq, $cmp, $rev, $transform, $detransform ) = ''; 606 frame { 607 $uniq &&= 'grep { $a = $_, 1 if !defined $a or ' . ($cmp ? "do { \$b = \$_; $cmp }}" : '$a cmp $_ }'); 608 $uniq .= ' reverse' if $rev; 609 print 610 $transform ? eval_or_die "map { $detransform } $uniq sort " . ($cmp ? "{ $cmp } " : '') . "map { $transform } <>" : 611 $cmp ? eval_or_die "$uniq sort { $cmp } <>" : 612 $uniq ? eval_or_die "$uniq sort <>" : 613 $rev ? reverse sort <> : 614 sort <> 615 or die $!; 616 eval_or_die 'undef $a' if $uniq; 617 } qw(f i I o O r s), 618 [qw(c compare), \$cmp, 1], 619 ['n', qr/num(?:eric(?:[-_]?sort)?)?/, \$cmp, undef, q{ do { no warnings; $a <=> $b }}], 620 # Eliminate ugly warning about trailing non-digits 621 [qw(r reverse), \$rev], 622 [qw(t transform), \$transform, 1], 623 [qw(d detransform), \$detransform, 1], 624 ['u', qr/uniq(?:ue)?/, \$uniq]; 625} 626 627 628 629sub c_template { 630 local @ARGV = @_; # for <> 631 my( %macros, $tmp ); 632 my( $pre, $suf, $Pre, $Suf, $afterPre, $afterSuf, $re ) = qw(@ @(?:\\\\\n)? @@ @@ @@); 633 frame { 634 $re = $re ? join( '|', keys %macros ) : qr/\w[-\w.]*/; 635 # Always have a () for multiline, in lst case one that never matches 636 my $pre_re = length( $Pre ) ? (length( $pre ) ? qr/$Pre()|$pre/ : qr/$Pre()/) : qr/$pre|$pre()/; 637 my $suf_re = length( $Suf ) ? (length( $suf ) ? qr/(?(2)(?:$Suf()|$suf)|$suf)/ : qr/$Suf()/) : qr/$suf/; 638 my $handler = sub { 639 if( defined $_[3] ) { # @macro=def@ 640 if( exists $macros{$_[3]} ) { 641 return '' if $_[4]; # @macro?=def@ 642 } else { 643 $re = ($re ? "$re|" : '') . $_[3]; 644 } 645 $macros{$_[3]} = $_[6] ? eval_or_die( "sub $_[6]" ) : $_[5]; 646 # @macro { Perlcode }@ 647 ''; 648 } elsif( defined $_[2] ) { # @{ Perlcode }@ 649 eval_or_die $_[2]; 650 } else { # @macro@ or @macro(arg1,arg2...)@ 651 my $repl = $macros{$_[0]}; 652 if( !defined $repl ) { 653 $repl = ''; 654 } else { 655 my @args = map { s/$pre($re)$suf/$macros{$1}/g; $_ } split ',', $_[1] if $_[1]; 656 if( ref $repl ) { 657 $repl = &$repl( @args ); 658 } elsif( $_[1] ) { # @macro(arg1,arg2...)@ 659 $repl =~ s/\$([1-9])/$1 > @args ? '' : $args[$1-1]/ge; 660 $repl =~ s/\$\{([1-9]\d*)\}/$1 > @args ? '' : $args[$1-1]/ge; 661 } 662 } 663 $repl; 664 } 665 }; 666 while( <> ) { 667 my $line; 668 while( s/(.*?) $pre_re (?:($re)(?:\((.*?)\))? | \{(.*?)\} | (\w[-\w.]*)(?:(\?)?=(.*?) | \s*(\{.*?\}))) $suf_re//x ) { 669 if( defined $line ) { 670 $line .= $1; 671 } else { 672 $line = $1; 673 } 674 # my( $name, $args, $perl, $def, $optdef, $value, $defcode ) 675 @_ = ($3, $4, $5, $6, $7, $8, $9); 676 if( defined $2 && defined $10 ) { # multiline? 677 my $end = $afterSuf ? qr/$_[0]$afterSuf/ : ''; 678 until( s/.*?$afterPre$end// ) { 679 if( eof ) { 680 warn "$ARGV:$.: $Pre$_[0]$Suf unterminated\n"; 681 $_ = ''; 682 last; 683 } 684 $_ = <>; 685 } 686 } 687 $line .= &$handler; 688 } 689 substr $_, 0, 0, $line if defined $line; 690 &print; 691 close ARGV if $synclines && eof; 692 } 693 } \%macros, qw(f i I o O S), 694 [qw(h hashref), \$tmp, 1, sub { $tmp = eval_or_die $tmp; $macros{$_} = $tmp->{$_} for keys %$tmp }], 695 [qw(s simple), \$pre, 1, 696 sub { 697 (undef, $pre, $suf) = split quotemeta( substr $pre, 0, 1 ), $pre; 698 }], 699 [qw(m multiline), \$Pre, 1, 700 sub { 701 (undef, $Pre, $Suf, $afterPre, $afterSuf) = split quotemeta( substr $Pre, 0, 1 ), $Pre; 702 }], 703 [qw(d defined), \$re]; 704} 705 706 707sub c_touch { 708 local @ARGV = @_; 709 frame { 710 my $time = time; 711 for( @ARGV ) { 712 if( -f ) { 713 perform { utime $time, $time, $_ } "update timestamp on `$_'"; 714 } else { 715 perform { open my $fh, '>', $_ } "create `$_'"; 716 } 717 } 718 }; 719} 720 721 722sub c_uninstall { 723 local @ARGV = @_; # for <> 724 frame { 725 @ARGV = $ENV{INSTALL_LOG} || 726 ($CWD_INFO->{ROOT} ? relative_filename( $CWD_INFO->{ROOT} ) : '.') . 727 '/.install_log' 728 unless $inpipe || @ARGV; 729 my %files; 730 /^ .* `(.+)'/ and $files{$1} = 1 while <>; 731 eval { _rm sort keys %files }; 732 } 'i', 'I'; # fails in 5.6: qw(i I); 733} 734 735 736sub c_uniq { 737 local @ARGV = @_; # for <> 738 my $cmp; 739 frame { 740 $cmp = eval_or_die "sub {$cmp\n}" if $cmp; 741 no strict 'refs'; 742 local *a = \${"$Mpp::Subs::rule->{MAKEFILE}{PACKAGE}::a"}; 743 local *b = \${"$Mpp::Subs::rule->{MAKEFILE}{PACKAGE}::b"}; 744 local *_ = \$b; # For print. 745 undef $a; 746 while( $b = <> ) { 747 &print if !defined $a or $cmp ? &$cmp() : $a ne $b; 748 $a = $b; 749 close ARGV if $synclines && eof; 750 } 751 } qw(f i I o O r s S), 752 [qw(c compare), \$cmp, 1]; 753} 754 7551; 756