#! /usr/bin/perl

use v5.8;
use strict;
use warnings;

package make;
use constant VERSION => v0.5;

use Getopt::Long 'GetOptions';
{
    my %opt;

    BEGIN {

	my $Copyright = 'Copyright © 2002, 03, Daniel Pfeiffer <occitan@esperanto.org>

make.pl may be copied only under the terms of either the Artistic License or
the GNU General Public License, which may be found in the Perl 5 source kit.';

	Getopt::Long::config qw(gnu_getopt require_order);

	GetOptions \%opt,
	    qw(B|no-builtin-commands
		d|debug
		f|file|makefile=s
		i|ignore-errors+
		k|keep-going
		n|just-print|dry-run|recon
		r|no-builtin-rules
		R|no-builtin-variables
		s|silent|quiet),

	    'v|version' => sub {
		printf STDERR "This is make.pl version %vd using Perl version %vd\n%s\n",
		    VERSION, $^V, $Copyright;
		exit;
	    },

	    'h|help|?' => sub {
		eval q{
		    use Pod::Usage;
		    pod2usage -output => \*STDERR;
		}
	    };

    }

    use constant {
	DEBUG => $opt{d} ? $opt{d} : 0,
	JUST_PRINT => $opt{n} ?  $opt{n} : 0,
	IGNORE_ERRORS => $opt{i} ? $opt{i} : 0,
	KEEP_GOING => $opt{k} ? $opt{k} : 0,
	MAKEFILE => $opt{f} ? $opt{f} : '',
	NO_BUILTIN_RULES => $opt{r} ? $opt{r} : 0,
	NO_BUILTIN_VARIABLES => $opt{R} ? $opt{R} : 0,
	SILENT => $opt{s} ? $opt{s} : 0
    };

    use constant AUTOLOADS => $opt{B} ? () :
	qw(cat cut chmod chown cp egrep false fsort head install ln mkdir mv paste pod2html
	pod2latex pod2man pod2text pod2usage rev rm sed tail template touch uniq);
}

use constant FUNCTIONS => AUTOLOADS,
    qw(determine extend include io ignore_errors once rule sh shellparse EXECUTABLE MODULE);

our( $INTERMEDIATE, %PHONY, @PATH, %COMMAND, %OPTIONS ) = '';


sub expand(@);
# don't let the Makefile.pl see our other variables
sub include(@) {
    my $file;
    for( &expand ) {
	open FILE, $_ or
	    die "include: could not open $_\n";
	{ local $/ = undef; $file = <FILE> }
	eval 'no strict;
	    no warnings;
	    package main;
	    BEGIN { *$_ = \&{"make::$_"} for make::FUNCTIONS }
	    use subs make::FUNCTIONS;
# line 1 "' . $_ . '"
' . $file;
	die $@ if $@;
    }
    close FILE;
}



our( $extend, $ignore_errors, $silent, $errors, $indent, $target, @rule, %rule, @rerule, %resolve, %timestamp, $stderr )
    = ((0) x 4, '');

select STDERR; $| = 1;
open $stderr, '>&', \*STDERR;
select $stderr; $| = 1;
select STDOUT; $| = 1;
sub echo($$) {
    my @caller = caller 1;
    if( !defined $caller[0] ) {
	@caller = caller;
    } elsif( $caller[1] =~ /^\(/ ) { # eval or unknown
	@caller = caller 2;
    }
    print $stderr (DEBUG ? sprintf '%s(%i): info: ', @caller[1,2] : ''),
	($_[0] ? ((IGNORE_ERRORS or $ignore_errors) ? '- ' : '+ ') : ''), "$_[1]\n"
	if DEBUG or JUST_PRINT or SILENT ? 0 : !$silent;
}



sub error(;$) {
    return if IGNORE_ERRORS > 1 or $ignore_errors > 1;
    my $error = $_[0] || 'ERROR[1]';
    if( $ignore_errors ) {
	warn "make.pl: $error, ignored\n";
    } elsif( IGNORE_ERRORS ) {
	$errors++;
	warn "make.pl: $error, continuing\n";
    } else {
	die "make.pl: $error, bailing out\n";
    }
    undef;
}


# deferred variables
{
    my %ref = ( SCALAR => 0, REF => 0,	ARRAY => 1,	CODE => 2 );
    sub expand(@) {
	local $indent = $indent if DEBUG;
	if( DEBUG and $indent || grep { ref } @_ ) {
	    echo 0, 'expand deferred variables' unless $indent;
	    $indent =~ s/    $/	/ or $indent .= '    ';
	}
	my $ref;
	map {
	    print $stderr "$indent'$_'\n" if DEBUG && $indent;
	    !defined() ?	() :
	    !defined( $ref = $ref{ref()} ) ? $_ :
	    !$ref ? 	expand $$_ :
	    $ref == 1 ?	expand @$_ :
	    defined prototype $_ ? $_ :
	    expand &$_()
	} @_;
    }
}

sub once(&) {
    my $code = $_[0];
    my @var;
    @var = sub { @var = &$code };
    \@var;
}

sub shellparse($) {
    local $/ = '';		# for chomp
    my( $field, @list ) = '';
    my $split = sub {
	my $i = 0;
	for( my $x = $_[0] ) {
	    chomp if @_ == 2;
	    while( /(.*?)\s+/gc ) {  # split drops final whitespace :-(
		if( $i++ ) {
		    push @list, $1;
		} else {
		    push @list, $field . $1 if $field || $1;
		}
	    }
	    /\G(.*)/gcs;
	    $field = $i ? $1 : $field . $1;
	}
    };
    for( @_ ) {
	while( /\G(.*?)(?: (\s+) | \\(.) | '(.*?)' | \$(\{)? (\w+) (?(5)\}) | `(|.*?[^\\])` | " )/gcx ) {
	    $field .= $1;
	    if( defined $2 ) {
		push @list, $field if @list || $field;
		$field = '';
	    } elsif( defined $3 ) {
		$field .= $3;
	    } elsif( defined $4 ) {
		$field .= $4;
	    } elsif( defined $6 ) {
		&$split( $ENV{$6} );
	    } elsif( defined $7 ) {
		(my $str = $7) =~ s!\\`!`!g;
		&$split( `$str`, 1 );
	    } else {
		while( /\G(.*?)(?: \\(["\$\\`]) | \$(\{)? (\w+) (?(3)\}) | `(|.*?[^\\])` | " )/gcx ) {
		    $field .= $1;
		    if( defined $2 )	{ $field .= $2 }
		    elsif( defined $4 ) { $field .= $ENV{$4} }
		    elsif( defined $5 ) { (my $str = $5) =~ s!\\`!`!g; chomp( $field .= `$str` ) }
		    else		{ last }
		}
	    }
	}
	/\G(.*)/gcs;
	push @list, $field . $1 if $field || $1;
    }
    @list;
}

sub determine($@) {
    my $env = shift;
    if( defined $env and defined( $env = $ENV{$env} ) ) {
	once { shellparse $env };
    } else {
	my @candidates = @_;
	once {
	    my( $last, @list ) = pop @candidates;
	    for( @candidates ) {
		next unless @list = expand $_;
		if( 'CODE' eq ref $list[0] ) {
		    return @list;
		} elsif( $list[0] =~ m!/! ) {
		    return @list if -x $list[0];
		} else {
		    for( split ':', $ENV{PATH} ) {
			return @list if -x( $_ ? "$_/$list[0]" : $list[0] );
		    }
		}
	    }
	    $last;
	};
    }
}


# modifier functions

sub extend(&) {
    local $extend = 1;
    &{$_[0]};
}

sub io(&$;$$) {
    my $code = shift;
    my( %closed, @fh );
    my( $_silent, $msg, $stdin, $stdout, $stderr ) = (0, '');
    for( reverse @_ ) {
	$_silent = 1, $msg .= " ''", next if /^$/;
	die "make.pl: io cannot fork '$_'\n" if /^2?\|-$|^-\|$/;
	my @args;
	($_, @args) = @$_ if ref;
	$msg = " $_ @args$msg";
	next if JUST_PRINT;
	my $fh;
	if( /^(2>&-)$|^2\+?[>|]/ ) {
	    open $stderr, '>&', \*STDERR unless $stderr;
	    if( $1 ) { $closed{STDERR} = 1; close STDERR }
	    else { open $fh, substr( $_, 1 ), @args; open STDERR, '>&', $fh }
	} elsif( /^(>&-)$|^\+?[>|]|^\+</ ) {
	    open $stdout, '>&', \*STDOUT unless $stdout;
	    if( $1 ) { $closed{STDOUT} = 1; close STDOUT }
	    else { open $fh, $_, @args; open STDOUT, '>&', $fh }
	} else {
	    open $stdin, '<&', \*STDIN unless $stdin;
	    if( /^<&-$/ ) { $closed{STDIN} = 1; close STDIN }
	    else { open $fh, $_, @args; open STDIN, '<&', $fh }
	}
	unshift @fh, $fh if $fh;
    }
    echo 1, "io$msg"; $msg = '';
    local $silent = $_silent if $_silent;
    local $SIG{PIPE} = sub { $msg = 'error on pipe' }
	if $stdout or $stderr;
    &$code();
    for( [$stdin, 'STDIN', '<&'], [$stdout, 'STDOUT', '>&'], [$stderr, 'STDERR', '>&'] ) {
	next unless $$_[0];
	no strict 'refs';
	close $$_[1] or
	    error "io close of $$_[1] failed" . ($! ? " ($!)" : $? ? " ($?)" : '')
	    unless $closed{$$_[1]};
	open *{$$_[1]}, $$_[2], $$_[0];
    }
    close $_ or
	error "io close failed" . ($! ? " ($!)" : $? ? " ($?)" : '')
	for @fh;
    error $msg if $msg;
}

sub ignore_errors(&;$) {
    local $ignore_errors = defined $_[1] ? $_[1] : 1;
    &{$_[0]};
}



# builtin commands

sub dest(&$;$) {
    my( $code, $name, $differ ) = @_[0..2];
    my $dest = pop @ARGV;
    my( $suffix, %opt, @moreopt );
    if( defined $differ ) {
	@moreopt = 's|symbolic';
    }
    GetOptions \%opt,
	qw(b|backup f|force parents S|suffix=s), @moreopt;
    if( @ARGV > 1 and ! -d $dest ) {
	die "$0: $dest is not a directory\n";
    } else {
	$suffix = $opt{S} || $ENV{SIMPLE_BACKUP_SUFFIX} || '~';
	$code = sub { symlink $_[0], $_[1] } if defined $differ and $opt{'s'};
	for( @ARGV ) {
	    my $dest = $dest;
	    $dest .= '/' . ($opt{parents} ? $_ : (split /.*\//)[-1])
		if -d $dest;
	    if( $opt{b} ) {
		rename $dest, "$dest$suffix" or
		    die "$0: could not backup $dest ($!)\n";
		next;
	    } elsif( $opt{f} && -e $dest && ! -w _ ) {
		unlink $dest or
		    die "$0: could not unlink $dest ($!)\n";
		next;
	    }
	    &$code( $_, $dest ) or
		die "$0: could not $name $_ to $dest ($!)\n";
	}
    }
}

BEGIN {
    my %cache;			# closure for chown

    my $DATApos = 0;
    my $loadcmd = sub($) {
	my $fun = shift;
	$DATApos ||= tell DATA;
	local $/ = "\n}\n\n";
	while( local $_ = <DATA> ) {
	    if( /^__END__/ ) {
		seek DATA, $DATApos, 0;
	    } elsif( /^$fun([\\%&]*) / ) {
		no warnings;
		echo 0, "autoload $fun($1@)" if DEBUG;
		eval 'sub '.$fun.'('.$1.'@) {
		    '.($1 ? 'my $code = shift;' : '').'
		    my $ret = 0;
		    local $0 = "'.$fun.'"; BEGIN { $0 = "'.$fun.'"; }
		    local @ARGV = &expand;
		    echo 1, "&'.$fun.($1 ? ' @{[($code || \'undef\')]}' : '').' @ARGV";
		    if( JUST_PRINT ) {
			"";
		    } elsif( eval '.substr( $_, length( $1 ) + length $fun ).', $@ ) {
			print STDERR $@;
			error;
		    } else {
			$ret;
		    }
		}';
		die $@ if $@;
		last;
	    }
	}
    };

    for my $fun ( AUTOLOADS ) {
	no strict 'refs';
	*$fun = ($fun =~ /cut|egrep|fsort|paste|sed/) ?
	    sub(&@) { &$loadcmd( $fun ); goto &$fun } :
	    ($fun eq 'template') ?
	    sub(\%@) { &$loadcmd( $fun ); goto &$fun } :
	    sub(@) { &$loadcmd( $fun ); goto &$fun };
    }
}

use subs AUTOLOADS;

sub sh(@) {
    local @ARGV = &expand;
    return &{$ARGV[0]}( @ARGV[1..$#ARGV] )
	if 'CODE' eq ref $ARGV[0];
    my %opt;
    GetOptions \%opt, qw(c|command f|first l|last intern);
    $ARGV[0] = "&sh --command" if $opt{c};
    if( $opt{intern} ) {
	echo 1, "@ARGV[0, $ARGV[1]+3..$#ARGV]";
	splice @ARGV, 0, 2;
    } else {
	if( $opt{f} || $opt{l} ) {
	    my( $i, %order ) = 0;
	    for( @ARGV ) {
		$order{$_} = $i++ unless $opt{f} and defined $order{$_};
	    }
	    no warnings;
	    @ARGV = sort { $order{$a} <=> $order{$b} } keys %order if %order < @ARGV;
	}
	echo 1, "@ARGV";
    }
    return 0 if JUST_PRINT;
	my $warned = 0;
	local $SIG{__WARN__} = sub {
	    $warned = 1;
	    $opt{c} = $opt{c} ? '' : ' (did you forget -c?)';
	    print $stderr $? == 127 << 8 ?
		"sh: can't execute '$ARGV[0]': $!$opt{c}\n" :
		@_;
	};
	my $a = $opt{c} ?
	    do { shift @ARGV; local $" = ';'; system "@ARGV"; } :
	    system { $ARGV[0] } @ARGV;
	&{$SIG{__WARN__}} if ($? == -1) ? $? = 127 << 8 : 0 and !$warned;
	error( $? > 255 ?
		'ERROR['.($?>>8).']' :
		'SIGNAL['.($?&127).']' )
	      if $?;
	$?;
}

$INC{'command.pm'} = 'make.pl';
sub command::import($@) {
    my( $dir, $cmd, @cmd ) = @_;
    @cmd = $cmd unless @cmd;
    no strict 'refs';
    *{caller() . "::$cmd"} = ref( $cmd[0] ) ?
	sub(@) {
	    local $SIG{__WARN__} = sub {
		my $msg = $_[0];
		$msg =~ s/.*?make\.pl:/$cmd:/;
		warn $msg;
	    };
	    my( $wa, $ret, @ret ) = wantarray;
	    my @args = &expand;
	    echo 1, "&$cmd @args";
	    if( JUST_PRINT ) {
		0;
	    } else {
		eval {
		    if( $wa ) {
			@ret = &{$cmd[0]}( @args );
		    } else {
			$ret = &{$cmd[0]}( @args );
		    }
		};
		if( $@ ) {
		    print STDERR $@;
		    error;
		} elsif( $wa ) {
		    @ret;
		} elsif( defined $ret ) {
		    $ret;
		}
	    }
	} :
	sub(@) { sh '--intern', $cmd, $#cmd,   @cmd, @_ };
}



# make functionality

sub lookup($) {
    return $_[0] if '/' eq substr $_[0], 0, 1;
    for( @PATH ) {
	if( $_ ) {
	    $_ .= "/$_[0]";
	} else {
	    $_ = $_[0];
	}
	return $_ if -e;
	if( $_ ) {
	    $_ .= "/$INTERMEDIATE$_[0]";
	} else {
	    $_ = "$INTERMEDIATE$_[0]";
	}
	return $_ if -e;
    }
    $_[0];
}

sub timestamp($) {
    my $file = &lookup;
    $file = (stat $file)[9];
    defined( $file ) ? $file : 0;
}

sub resolve(@);
sub resolve(@) {
    for my $target ( @_ ) {
	next if $resolve{$target};
	$resolve{$target} = 1;	# marker to prevent endless recursion
	my $rule = $rule{$target};
	my @prereqs;
	@prereqs = expand @{$rule}[1..$#$rule]
	    if $rule;
	unless( $rule &&= ${$rule}[0] ) {
	    my @exlicit_prereqs = @prereqs;
	  RERULE:
	    for my $re ( @rerule ) {
		my @rest_prereqs = @exlicit_prereqs;
		@prereqs = ();
		next unless $target =~ ${$re}[0];
	      SUBRULE:
		for( @{$re}[reverse 1..$#$re] ) {
		    for( expand @{$_}[1..$#$_] ) {
			my $prereq = ref() ? $_ :
			    do{ (my $res = $target) =~ s{${$re}[0]}{qq{qq{$_}}}ee; $res };
			next SUBRULE unless resolve $prereq;
			if( !@exlicit_prereqs ) {
			    push @prereqs, $prereq;
			} elsif( grep { $prereq eq $_ } @rest_prereqs and resolve $prereq ) {
			    @rest_prereqs = grep { $prereq ne $_ } @rest_prereqs;
			    push @prereqs, $prereq;
			}
		    }
		    $rule = ${$_}[0];
		    last RERULE;
		}
	    }
	}
	print $stderr 'try ', defined( $rule ) ? $rule : 'undef', @prereqs ? " @prereqs" : '', " => $target\n"
	    if DEBUG;
	return 0 if @prereqs and !resolve @prereqs;
	if( @prereqs or $rule ) {
	    no warnings;
	    print $stderr 'resolve ', $rule || 'undef', @prereqs ? " @prereqs" : '', " => $target\n"
		if DEBUG;
	    $resolve{$target} = [$rule, @prereqs];
	} elsif( !$PHONY{$target} and !-e lookup $target ) {
	    print $stderr "can't resolve $target\n"
		if DEBUG;
	    return 0;
	}
    }
    1;
}

sub make(@);
sub make(@) {
    for( @_ ) {
	local $target = $_;
	my $resolve = $resolve{$_};
	delete $resolve{$_};
	next unless ref $resolve;
	my( $code, @prereqs, $timestamp ) = @$resolve;
	make @prereqs;
	if( $PHONY{$_} or
	    !($timestamp = timestamp $_) or
	    grep { $PHONY{$_} or $timestamp < timestamp $_ } @prereqs )
	{
	    no warnings;
	    print $stderr 'perform ', $code || 'undef', @prereqs ? " @prereqs" : '', " => $_\n"
		if DEBUG;
	    next unless $code;
	    if( KEEP_GOING ) {
		eval { &$code( @prereqs, $_ ) };
		print $stderr $@ if $@;
	    } else {
		&$code( @prereqs, $_ );
	    }
	}
    }
}


sub rule(&@$) {
    my $location = sprintf '%s(%i)', (caller)[1,2];
    push @rule, [$location, $extend, @_];
}



# defaults

unless( NO_BUILTIN_VARIABLES ) {
    $INTERMEDIATE = 'intermediate/';
    $PHONY{$_} = 1 for qw(all clean install test distclean);

    @PATH = ('', $INTERMEDIATE);

    %COMMAND = (
	C => determine( CC => qw'gcc icc cc' ),
	'C++' => determine( CXX => qw'g++ gcc icpc CC' ),
	link => determine( LD => qw'ld' ) );

    %OPTIONS = (
	C => determine( 'CFLAGS' ),
	'C++' => determine( 'CXXFLAGS' ),
	link => determine( 'LDFLAGS' ) );
}

unless( NO_BUILTIN_RULES ) {

    use constant EXECUTABLE => qr!^((?:.*/)?[^/.]+)(?:\.exe)?$!s;
    use constant MODULE => qr/\.o$/s;

    rule {
	sh $COMMAND{'C++'}, $OPTIONS{'C++'}, qw'-c -o', $_[1], $_[0];
    } $_ => MODULE for qw'.C .cc .cpp .c++ .cxx';

    rule {
	sh $COMMAND{C}, $OPTIONS{C}, qw'-c -o', $_[1], $_[0];
    } '.c' => MODULE;

    rule {
	sh $COMMAND{link}, $OPTIONS{link}, '-o', $_[1], $_[0];
    } '$1.o' => EXECUTABLE;


    for( '', qw'.pl .al .pm .pod' ) {
	rule {
	    sh \&pod2html, '--infile' => $_[0], '--outfile' => $_[1];
	} $_ => qr/\.html$/s;
    }


    rule {
	sh \&rm, <*.[oa]>, <*.so>, <pod2htm[di].x~~>, <$INTERMEDIATE*.[oa]>, <$INTERMEDIATE*.so>;
    } 'clean';

    rule {
	sh \&rm, <*.[id]>, <*.[im]i>, -d( $INTERMEDIATE ) ? $INTERMEDIATE : <$INTERMEDIATE*>;
    } clean => 'distclean';

}


if( MAKEFILE ) {
    include MAKEFILE;
} elsif( -e 'Makefile.pl' ) {
    include 'Makefile.pl';
}


RULE:
for( @rule ) {
    my( $location, $extend, $code ) = splice @$_, 0, 3;
    my @prereqs = expand @$_;
    my $target = pop @prereqs;
    no warnings;
    print $stderr "$location: info: rule ", $code || 'undef', ($extend ? '++' : ''),
	@prereqs ? " @prereqs " : '', "=> $target\n"
	if DEBUG;
    if( ref $target eq 'Regexp' ) {
	for( @rerule ) {
	    next if ${$_}[0] ne $target;
	    #if( $extend ) {		# FALSCH!
	    push @$_, [$code, @prereqs];
	    #} else {
	    #    @$_[1..$#$_] = [$code, @prereqs];
	    #}
	    next RULE;
	}
	push @rerule, [$target, [$code, @prereqs]];
    } elsif( !${$target = \$rule{$target}} ) {
	$$target = [$code, @prereqs];
    } else {
	push @$$target, @prereqs;
	next unless $code;
	if( !${$target = \${$$target}[0]} ) {
	    $$target = $code;
	} elsif( !$extend ) {
	    warn "$location: warning: overwriting rule\n";
	    $$target = $code;
	} elsif( 'ARRAY' eq ref $$target ) {
	    push @$$target, $code;
	} else {
	    $$target = [$$target, $code];
	}
    }
}

@ARGV = 'all' unless @ARGV;
resolve @ARGV or
    die "make.pl: don't know how to make @ARGV\n";;

make @ARGV;

__DATA__

{
    # Cores of autoloadable function
    # Each separator must be exactly like the following two lines!!!
}

cat {
    use File::Copy;
    no strict 'refs';
    copy $_, \*{select()} for @ARGV;
}

chmod {
    my $mode = shift @ARGV;
    $mode = oct $mode if '0' eq substr $mode, 0, 1;
    CORE::chmod $mode, $_ or
	  die "chmod: could not change mode on $_ ($!)\n"
	      for @ARGV;
}

chown {
    sub get(&$\$) {
	my( $fn, $type, $id ) = @_;
	if( !$$id ) {
	    $$id = -1;
	} elsif( $$id !~ /^\d+$/ ) {
	    if( $cache{$type,$$id} ) {
		$$id = $cache{$type,$$id};
	    } elsif( defined( my $tmp = &$fn( $$id )) ) {
		$$id = $cache{$type,$$id} = $tmp;
	    } else {
		die "chown: $type $$id unknown\n";
	    }
	}
    }
    my( $uid, $gid ) = split ':', shift @ARGV;
    get { getpwnam $_[0] } user => $uid;
    get { getgrnam $_[0] } group => $gid;
    CORE::chown $uid, $gid, $_ or
	  die "chown: could not change $_ ($!)\n"
	      for @ARGV;
}

cp {
    use File::Copy;
    dest \&copy, 'copy';
}

egrep& {
    while( <> ) {
	print if &$code();
	close ARGV if eof;
    }
}

false {
    return error;
}

fsort& {
    my %opt;
    GetOptions \%opt, qw(r|reverse u|uniq|unique);
    my @lines;
    if( $code ) {
	@lines = <>;
	my $package = caller eq 'make' ? caller 1 : caller;
	eval qq{		# get $a and $b right
	    package $package;
	    \@lines = sort \$code \@lines;
	};
    } else {
	@lines = sort <>;
    }
    if( $opt{u} ) {
	my $last = '';
	@lines = grep {
	    $last = $_, 1 if $_ ne $last;
	} @lines;
    }
    print $opt{r} ? reverse @lines : @lines;
}

head {
    my $pos = shift @ARGV;
    if( ref $pos ) {
	while( <> ) {
	    print;
	    close ARGV if /$pos/ or eof;
	}
    } elsif( $pos < 0 ) {
	my @lines;
	while( <> ) {
	    push @lines, $_;
	    if( eof ) {
		close ARGV;
		print @lines[0..@lines+$pos];
		@lines = ();
	    }
	}
    } else {
	while( <> ) {
	    print;
	    close ARGV if $. == $pos or eof;
	}
    }
}

install {
    ;
}

ln {
    dest { link $_[0], $_[1] } 'link', 1;
}

mkdir {
    for( @ARGV ) {
	my $dir = '';
	for( split /(?=\/)/ ) {
	    $dir .= $_;
	    next if -d $dir;
	    CORE::mkdir $dir or
		  die "mkdir: could not create $_ ($!)\n";
	}
    }
}

mv {
    use File::Copy;
    dest \&move, 'move';
}

paste& {
    my $delim = "\t";
    GetOptions 'd|delimiters=s' => \$delim;
    my @FH = map {
	open my $FH, $_ or
	    die "paste: could not open $_ ($!)\n";
	$FH;
    } @ARGV;
    my $open;
    do {
	$open = 0;
	my @line = map {
	    if( $_ ) {
		chomp( my $line = <$_> );
		if( eof $_ ) { close $_; undef $_ }
		else { $open++ }
		$line;
	    }
	} @FH;
	print $code ? &$code( @line ) : join( $delim, @line ), "\n";
    } while $open;
}

pod2html {
    use Pod::Html ();
    Pod::Html::pod2html @ARGV;
}

pod2latex {
}

pod2man {
}

pod2text {
}

pod2usage {
    use Pod::Usage ();
    Pod::Usage::pod2usage -exitval => 'NOEXIT', @ARGV;
}

rev {
    my $lines = 0;
    GetOptions 'l|lines' => \$lines;
    if( $lines ) {
	if( @ARGV > 1 ) {
	    for( reverse @ARGV ) {
		open my $file, $_;
		print reverse <$file>;
	    }
	} else {
	    print reverse <>;
	}
    } else {
	chomp, print scalar reverse(), "\n" while <>;
    }
}

rm {
    sub rd($) {
	opendir DIR, $_[0];
	for( readdir DIR ) {
	    next if /^\.\.?$/;
	    $_ = "$_[0]/$_";
	    -d() ? rd $_ : 1 - unlink or
		die "rm: could not remove $_ ($!)\n";
	}
	rmdir $_[0];
    }
    for( @ARGV ) {
	next unless -e;
	-d() ? !rd $_ : unlink or
	    die "rm: could not remove $_ ($!)\n";
    }
}

sed& {
    while( <> ) {
	&$code();
	print;
	close ARGV if eof;
    }
}

tail {
    my $pos = shift @ARGV;
    if( ref $pos ) {
	while( <> ) {
	    print if /$pos/ .. eof;
	    close ARGV if eof;
	}
    } elsif( $pos < 0 ) {
	my @lines;
	$pos = -$pos;
	while( <> ) {
	    push @lines, $_;
	    shift @lines if @lines > $pos;
	    if( eof ) {
		close ARGV;
		print @lines;
		@lines = ();
	    }
	}
    } else {
	while( <> ) {
	    print if ($. == $pos) .. eof;
	    close ARGV if eof;
	}
    }
}

template\% {
    my %opt = ( p => '@', s => '@' );
    GetOptions \%opt, qw(p|prefix=s s|suffix=s);
    my %hash = %$code;
    my $re = qr/\Q$opt{p}\E(@{[join '|', keys %hash]})\Q$opt{s}/;
    while( <> ) {
	s/$re/join ' ', expand $hash{$1}/eg;
	print;
    }
}

touch {
    my $now = time;
    for( @ARGV ) {
	if( -e ) {
	    utime $now, $now, $_ or
		die "touch: could not set time for $_ ($!)\n";
	} else {
	    open X, '>', $_ or
		die "touch: could not create $_ ($!)\n";
	    close X;
	}
    }
}

uniq {
    my $last = '';
    while( <> ) {
	print if $_ ne $last;
	$last = $_;
    }
}

__END__

=head1 NAME

make.pl -- Make with Perl Syntax and Semantics



=head1 SYNOPSIS

    make.pl[ option ...][ target ...]

F<Makefile.pl> can contain, besides normal Perl code

    rule undef, qw(main.o x.o y.o) => 'prog';

or

    rule {
	my $target = pop;
	sh qw'gcc -o', $target, @_;
    } qw(main.o x.o y.o) => 'prog';



=head2 Options

=over

=item B<-B>, B<--no-builtin-commands>

Eliminate the built-in commands.  You can still define your own.

=item B<-d>, B<--debug>

Output diagnostic messages, useful for tracing which rules are being defined,
tried and applied.  Since they are compiled Perl code, you don't see the
commands, but you can compare the addresses.

=item B<-f> I<FILE>, B<--file>=I<FILE>, B<--makefile>=I<FILE>

Use I<FILE> instead of the default F<Makefile.pl> for giving rules, variables
and anything else.

=item B<-i>, B<--ignore-errors>

Ignore all errors in commands executed to remake files.

=item B<-k>, B<--keep-going>

Continue as much as possible after an error.  While the target that failed,
and those that depend on it, cannot be remade, the other prerequisites of
these targets can be processed all the same.

=item B<-n>, B<--just-print>, B<--dry-run>, B<--recon>

Print the commands that would be executed, but do not execute them.

=item B<-r>, B<--no-builtin-rules>

Eliminate use of the built-in implicit rules.  You can still define your own.

=item B<-R>, B<--no-builtin-variables>

Eliminate use of the built-in rule-specific variables.  You can still define
your own.

=item B<-s>, B<--silent>, B<--quiet>

Silent operation; do not print the commands as they are executed.

=item B<-v>, B<--version>

Show the installed version of make.pl.

=back



=head1 VARIABLES

=head2 Deferred Variables

Unlike Perl variables, which get evaluated at the moment you use them,
traditional make variables get evaluated lazily, at the last possible moment.
Like GNU make, make.pl allows both kinds of variables.

The evaluation of deferred variables is performed through the rule function
only when applying the rule.  It also happens when calling external and
builtin commands.  Deferred variables are effectively references which are
dereferenced when used.  This happens recursively until they no longer contain
references.

=over

=item B<\$I<variable>>

=item B<\@I<variable>>

=item B<[>...B<]>

Unblessed references are the simplest form of deferred variables.

=item B<determine> I<environment-variable>, [I<command>, ..., ]I<default-value>

The first time this is evaluated, the first applicable value is determined.
If C<$ENV{I<environment-variable>}> is defined, its value is parsed by
L<shellparse|/i_shellparse>.  Else the I<command>s are searched for until one
of them exists in C<$ENV{PATH}>.  Each I<command> maybe a command-name, or an
array consisting of the command-name and initial arguments.  If no I<command>
is given or found, I<default-value> is returned.  Later uses will rereturn the
same value, which is automatically cached.

	I<command> ohne once, stattdessen gleich expand ^ umformulieren

=item B<once> { I<Perl code> }

The first time this is evaluated, I<Perl code> will be called in list context.
Later uses will rereturn the same value, which is automatically cached.

=item B<shellparse> I<string>

This does not create a deferred variable!  But it is handy when
L<once|/i_once> or L<sub|/i_sub> deferred variables return a
commandI<>(-fragment) from an external source.  It parses I<string> like the
Bourne Shell would and returns it as a list.  It not only splits on whitespace
but also understands escaped characters (C<\>.), single- (C<'>...C<'>) and
double-quoted (C<">...C<">) strings.  Variables (C<$I<var>> or C<${I<var>}>) are taken
from the environment -- take care that Perl doesn't interpolate its variables
for you!  Command substitutions (`...`) also work.

=item B<sub> { I<Perl code> }

Code references without a prototype will be called in list context without an
argument, and the return value will be further dereferenced.

=back


=head2 Predefined Variables

=over

=item B<%COMMAND>

The keys are the names of languages, like C<C> or C<'C++'>.  Each value is an
array reference (so you can just push anything onto it) containing the command
to compile that language.  Used by the builtin rules and suggested that you
also use this for consistency.

=item B<$INTERMEDIATE>

To be implemented.

=item B<%OPTIONS>

The keys are the names of languages, like C<C> or C<'C++'>.  Each value is an
array reference (so you can just push anything onto it) containing the
compiler options to compile that language.  Used by the builtin rules and
suggested that you also use this for consistency.

=item B<@PATH>

Where makefiles and prerequisites are searched for.  This allows using a
different directory tree as a reference and only remaking those files locally
which are newer (locally).

=item B<%PHONY>

Any key that has a true value is not searched for in the file system.
Anything to be made that depends on a phony rule, and all prerequisites of
those rules will always be made.  This defaults to C<all>, C<clean>, C<install>, C<test>
and C<distclean>.

=back



=head1 RULES

Rules tell make.pl what a I<target> depends on and how to make it once all
I<prerequisites> are there.

The I<prerequisites> and I<target> or I<pattern> may also be variable
references, which get expanded only when applying the rule.  See L</Deferred
Variables>.


=head2 Static Rules

=over

=item B<rule> { I<Perl code> } I<target>;

Such a rule tells make.pl what I<Perl code> is needed to make I<target>.

=item B<rule I<undef>>, I<prerequisite>, ... => I<target>;

Such a rule is the opposite, telling make.pl what I<target> depends on, not
how to make it.  This tries to make every I<prerequisite>, and then implicitly
uses another rule (builtin or supplied by you) to make I<target>.

=item B<rule> { I<Perl code> } I<prerequisite>, ... => I<target>;

This combines the two other kinds, first making every I<prerequisite> and then
performing I<Perl code> to make I<target>.

=back


=head2 Pattern Rules

Pattern rules are tried when no static rule applies, or when the static rule
has no I<Perl code>.

=over

=item B<rule> { I<Perl code> } B<I<qr>>/I<pattern>/;

=item B<rule> { I<Perl code> } I<prerequisite>, ... => B<I<qr>>/I<pattern>/;

These do the same as the corresponding static rules, but the targets are only
matched when applying the rule.  Each prerequisite is taken as a substitution
string and may contain (literally) C<$1> and so forth if the pattern has the
corresponding grouping.  If the prerequisite contains braces, they must be
paired properly or escaped as in C<{}> or C<\{>.

=back


=head2 Rule Utilities

Normally a rule will overwrite an already existing same rule.  Static rules
are the same when they have the same target.  Pattern rules are the same when
they have the same target regexp and the same list of prerequisite patterns.

=over

=item B<extend> { I<Perl code> };

You can place rules into such a block.  This extends rules
for the same target, rather than overwriting the rule.


=item B<include> I<file>, ...;

Read more rules and variables (and generally any Perl code) from each file.

=back



=head1 COMMANDS

Commands are functions with special behaviour.  Some of the builtins take a
code block as their first argument.  Otherwise their arguments may be strings,
literally or in variables.  But they may also be scalar, array or code
references.  See L</Deferred Variables>.

Unless a command is silent (see L</Options> or L<io|/i_io>), it will be echoed
before being performed.

Unless a command is being ignored (see L</Options> or L</Command Modifiers>),
the return value will be analyzed by make.pl and acted on.  When ignoring
failure, commands return undef if and always only if they fail.  Otherwise a
failing command will let the whole make.pl run abort.

Some commands take options which are shown here without quotes, though in real
use they are Perl strings.


=head2 Builtin Commands

These behave similarly to their Unix or GNU counterparts, without some of the
bells and whistles.  But they are more efficient, since they use Perl's
capabilities, rather than forking a process.  Those that talk about operating
on lines of the file contents, actually mean chunks as defined by C<$/>.  When
echoing they show a function prefix C<&>.

=over

=item B<cat>[ I<file>, ...];

Concatenate the contents of all the files.


=item B<chmod> I<mode>, I<file>, ...;

Sets the mode of each I<file> to I<mode>, a number or string (parsed like a
literal number, i.e. in decimal unless there is a leading 0 -- octal, 0x --
hexadecimal or 0b -- binary, unlike normally where '0644' != 0644.)  If you
would like I<mode> not to be echoed as decimal, pass it as an octal string.
I<Use C<CORE::chmod> if you really need the original.>


=item B<chown> I<user>[B<:>I<group>], I<file>, ...;

=item B<chown> B<:>I<group>, I<file>, ...;

Sets I<user> and / or I<group> (given as name or numeric id) for all the
files.  I<Use C<CORE::chown> if you really need the original.>


=item B<cp>[ I<option>, ...,] I<file>, ... I<destination>;

=item B<ln>[ I<option>, ...,] I<file>, ... I<destination>;

=item B<mv>[ I<option>, ...,] I<file>, ... I<destination>;

Copy, link or move (rename) the I<files> to I<destination>.  If more than one
file is given, I<destination> must be a directory.  You can also symlink or move
directories.  Options are:

=for html <dd>

=over

=item B<-b>, B<--backup> move existing destination files to same name with suffix appended

=item B<-f>, B<--force> first remove files that can't be overwritten

=item B<--parents> preserve I<file>'s given parent directories under I<destination> directory

=item B<-S>, B<--suffix>=I<str> use I<str> as backup suffix instead of ~

=item B<-s>, B<--symbolic> create symbolic instead of real link I<E<40>ln only)>

=back

=for html </dd>


=item B<egrep> { I<Perl code> }[ I<file>, ...];

Output those lines from all files, for which I<Perl code> returns true.


=item B<false>;

Simply fail.


=item B<fsort I<undef>>[, -r|--reverse][, -u|--uniq|--unique][, I<file>, ...];

=item B<fsort> { I<Perl code> }[ -r|--reverse,][ -u|--uniq|--unique,][ I<file>, ...];

Sort the lines of all files together.  In the first case, the default sort
order is used.  In the second a programmed order as in the Perl sort
function is used.


=item B<head> I<number>[, I<file>, ...];

=item B<head> B<I<qr>>/I<regexp>/[, I<file>, ...];

=item B<tail> I<number>[, I<file>, ...];

=item B<tail> B<I<qr>>/I<regexp>/[, I<file>, ...];

Output the lines respectively from one to I<number>, or from I<number> to end
of each file.  If number is negative, it is counted from the end of each file.
The I<regexp> variants will instead go up to or from the first matching line.


=item B<mkdir> I<directory>, ...;

Creates each I<directory> and any required parent directories.  (cf. Unix
mkdir -p)  I<Use C<CORE::mkdir> if you really need the original.>


=item B<paste>[ -d|--delimiter=I<delimiter>,] I<file>, ...;

Paste all lines from each file side by side.  They get separated by
I<delimiter>, which defaults to tabulator.


=item B<pod2html>[ I<option>, ...];

=for later item B<pod2latex>[ I<option>, ...];

=for later item B<pod2man>[ I<option>, ...];

=for later item B<pod2text>[ I<option>, ...];

=item B<pod2usage>[ I<option>, ...];

Identical to the respective external Perl programs.


=item B<rev>[ -l|--lines,][ I<file>, ...];

Reverse the characters on each line, or with the options the lines among all
files.


=item B<rm> I<file>|I<directory>, ...;

Removes each I<file> or I<directory> with contents.  Doesn't complain about
missing files.  (cf. Unix rm -fr)


=item B<sed> { I<Perl code> }[ I<file>, ...];

Performs I<Perl code> for each line of each I<file>, and outputs the result.
It should modify C<$_>, like C<s///> or C<tr///>.  (cf. Unix sed or perl -pe)


=item B<template> %{{ I<key> => I<value>, ... }}[, I<option>, ...,][ I<file>, ...];

=item B<template> I<hash>[, I<option>, ...,][ I<file>, ...];

Find all the occurences of the keys from the hash in either form, delimited by
an immediately leading and trailing @.  Replace all these occurences, from all
the files, with the associated value.  Options are:

=for html <dd>

=over

=item B<-p>, B<--prefix>=I<str> use I<str> as key prefix, instead of @

=item B<-s>, B<--suffix>=I<str> use I<str> as key suffix, instead of @

=back

=for html </dd>



=item B<touch> I<file>, ...;

Sets the access and modification time for each I<file> to now, creating those
that don't exist.


=item B<uniq>[ I<file>, ...];

Output those lines from all files which differ from the preceding one.

=back


=head2 External Commands

=over

=item B<sh>[ -f|--first|-l|--last,] I<command>, ...;

This can take one or more arguments, and Perl will execute the list.  To
eliminate repeated arguments, use --first to keep only the first occurence of
each, or --last to keep only the last.

=item B<sh> -c|--command => I<command>, ...;

In the second form the arguments are joined into one string, separated by
semicolons.  This string is passed to a shell for execution.  If it contains
no shell metacharacters, Perl emulates the shell.  Do not call something like

    sh 'ls -l';

when you want one of

    sh qw'ls -l';
    sh -c => 'ls -l';

=back


=head2 Adding Commands

=over

=item B<I<use> command> I<name> => I<functionreference>;

=item B<I<use> command> I<name> => B<I<sub>> { I<Perl code> };

These create a function of name I<name>, which calls I<functionreference> or
I<Perl code> with make.pl command semantics.  The I<functionreference> or
I<Perl code> can C<warn>, C<die> or C<return>.  Dying is turned into a make.pl error.

=item B<I<use> command> I<name>;

=item B<I<use> command> I<name> => B<I<qw>>(I<command arg ...>);

These create a function of name I<name>, which is an alias to an external
command.  In the first form the external command name is identical to the
function name.  In the second case it may be different, and/or may have
additional arguments.

=back


=head2 Command Modifiers

=over

=item B<io> { I<Perl code> } I<mode>, ...;

You can place builtin or external shell commands (e.g. within rules) into such
a block, to redirect their I/O.  The old settings get restored afterwards.
Note that this is technically not a block, but a closure.  This means that the
outer C<@_> is not available, but my-variables are.

The I<mode> arguments are performed back to front, allowing you to do
pipelines.  If I<mode> is the empty string, this prevents the commands from
being echoed, as with the --silent command line option.

As in Shell, a I<mode> of '<&-', '>&-' and '2>&-' will close STDIN, STDOUT and
STDERR respectively.

The other modes are almost as for the open function.  A I<mode> starting with
'>', '+>', '+<' or '|' will apply this to STDOUT.  Using '+<' allows some
inplace editing of files, as they remain readable, see L</EXAMPLES>.  A I<mode>
starting with '2>', '2+>', '2+<' or '2|' will apply this to STDERR.  The '2'
will not be passed to open.  All others are applied to STDIN.

You can also give I<mode> as C<[I<mode>, I<argument> ...]>, to use the
multiple argument form of open.

=item B<ignore_errors> { I<Perl code> }[ I<level>];

You can place builtin or external shell commands (e.g. within rules) into such
a block.  Optional level is either B<0> -- override englobing ignore_errors;
B<1>, the default -- prevents the commands' return value from being acted on;
B<2> -- error return code is not even shown.  I<This is equivalent to
preceding commands with C<-> in make.>

=back



=head1 EXAMPLES

This makes any intermediate .o file when needed, from the corresponding .c
source:

    rule {
	my $source = $_[0];
	my $target = $_[-1];	# may have more than 2 args from static rules
	sh -c => 'gcc -c -o', $target, $source;
    } '.c' => qr/\.o$/;

This makes F<myprog> from all present object files:

    rule undef, <*.o> => 'myprog'; 		# wrong, maybe none are built yet
    rule undef, sub { <*.o> } => 'myprog';			# closer but wrong
    rule undef, sub { grep s/c$/o/, <*.c> } => 'myprog';	# correct for C

This makes F<myprog> from F<a.o>, F<b.o>, F<c.o>, F<d.o>, F<e3.o>, which are
themselves implicitly made from any available sources:

    rule undef, \@more_C_objects, \$eno => 'myprog';

    @more_C_objects = (qw(a.o b.o c.o), \$do);
    $do = 'd.o';
    $eno = sub { "e$n.o" };
    $n = 3;

This defines analogous static rules with a varying component, here in a
maximum of places, the Perl code, several prerequisites and the target:

    rule { print "$_.a\n" } "$_.b", "$_.c", 'config.h' => "$_.z"
	for qw(src1 src2 srcn);

This gives you another builtin command:

    use command nop => sub { print "I do nothing\n" }

This will first print to the file, and then edit the file inplace, without
echoing the sed command:

    io { print 'hallo' } ">$file";
    io { sed { tr/a/e/ } $file } '', ['+<', $file];

Cummulate io redirections from back to front creating a pipeline:

    io { ... } '| 1st-pipe', ['|-', '2nd-pipe'], ..., '> outfile';

This will extract the header and signature of each file in email format:

    egrep { 1../^$/ or /^-- /..eof } file, ...;

=head1 TODO

Precompile files and extract dependency list (cpp-style and open for handling
anything).

Try to look which files from the same directory can be compiled with one call
to the compiler (idea thanks to Nadim Khemir).  I'm not sure how this fits in
with my rules, nor with using an intermediate directory...

Optionally stop after reading all makefiles (and autoloading every command)
waiting for targets from fifo and forking (idea from ant server).

Have more predicates for eliminating compilations and getting away from only
files:

=over

=item * file-signature-based, rather than modification-time based.  In fact
I'm starting to believe, this should be the only criterion for files.

=item * compare arbitrary objects with some method

=back

Handle parallelization (hopefully easy with threads) and subdirectories
(package and threads vs. fork?  chdir probably forces us to fork).

Extend sh() to transparently distribute to various machines.

Have a builtin B<install> command, since that is not standard, and, when
available, named differently of different machines.  Also:

    cut undef|{ split /regexp/ } [-o outfile1,] [-o outfile2,] ..., infile, ...;

    ncp url|file ... url|directory # with LWP::UserAgent

    $COMMAND{yacc} = determine YACC => 'yacc', [$COMMAND{bison}, '-y'];
    $COMMAND{bison} = determine BISON => 'bison';

    # fsort:
    my @data = map  $_->[0],
	       sort { $a->[1] <=> $b->[1] ||    	# second column-numeric
		      $a->[2] <=> $b->[2] ||    	# third column-numeric
		      $a->[3] <=> $b->[3]    	# fourth column-numeric
		    }
	       map  [ $_, (split)[1, 2, 3] ], <DATA>;

Command make for building self-contained subprojects.

Give it all the rules and external variables (CFLAGS, ... -- optionally?) of
GNU make.

Turn it into one or two modules, so that a makefile can itself be a standalone
Perl program.

Somebody should write a simple makedepend-style makefile parser.

Somebody might use Perl's XML-capabilities for writing an ant-makefile parser.

Teach ExtUtils::MakeMaker to generate this.

Maybe support an interpreter linked to gcc, performing almost everything in a
single process.

=head1 AUTHOR

Daniel Pfeiffer <occitan@esperanto.org>

=begin CPAN

=head1 README

Make with Perl as the rule language.  Write a B<plain makefile> in Perl syntax.  Or, write a program that among others does a few B<file-dependency driven> things.
http://dapfy.bei.t-online.de/make.pl/

=pod SCRIPT CATEGORIES

UNIX/System_administration
VersionControl/CVS
Win32/Utilities