File Coverage

blib/lib/ChainMake.pm

Criterion	Covered	Total	%
statement	200	257	77.8
branch	87	132	65.9
condition	38	60	63.3
subroutine	20	23	86.9
pod	9	9	100.0
total	354	481	73.6

package ChainMake;

use strict;
use warnings;
use Data::Dumper;
use Clone qw(clone);
use Fcntl (qw/:flock O_RDONLY O_CREAT/); # import LOCK_* constants
use Tie::File;

our $VERSION = '0.9.0';

our %DEFAULTS = (
    verbose         => 1,
    silent          => 0,
    timestamps_file => '.chainstamps',
    symbols         => [qr/\$t_name/,qr/\$t_base/,qr/\$t_ext/],
);

our %TARGETTYPE_PARAMS=(
    requirements => sub { (ref shift eq 'ARRAY') },
    insistent    => sub {
        my $p=shift;
        return (($p == 0) || ($p == 1));
    },
    handler      => sub { (ref shift eq 'CODE') },
    timestamps   => sub {
        my $p=shift;
        return ( (ref $p eq 'ARRAY') || ($p eq 'once') );
    },
);

sub new {
    my $proto=shift;
    my %args=@_;
    my $self = bless {
        targettypes => [],
    }, ref($proto) || $proto;
    $self->configure(%args);
    return $self;
}

sub configure {
    my ($self,%args)=@_;
    $self->{$_}=
        defined($args{$_})   ? $args{$_}   :
        defined($self->{$_}) ? $self->{$_} :
        $DEFAULTS{$_}
    foreach (keys %DEFAULTS);
    return 1;
}

sub targets {
    # add one target_type
    my ($self,$targets,%target_t)=@_;
    $targets=[$targets] unless (ref $targets eq 'ARRAY');

    # check if some parameters are given at all
    unless ((@{$targets} > 0) && (keys %target_t)) {
        $self->_diag(0,"at least one targetname and some parameters please\n");
        return 0 ;
    }
    # only params from %TARGETTYPE_PARAMS allowed
    for (keys %target_t) {
        unless (defined $TARGETTYPE_PARAMS{$_}) {
            $self->_diag(0,"unknown parameter $_\n");
            return 0;
        }
        # perform pseudo type check
        unless ( &{$TARGETTYPE_PARAMS{$_}}($target_t{$_}) ) {
            $self->_diag(0,"illegal value in parameter $_\n");
            return 0;
        }
    }
    # extra necessities
    unless (defined($target_t{requirements}) || defined($target_t{handler})) {
        $self->_diag(0,"at least requirements or handler must be supplied\n");
        return 0;
    }
    if (defined($target_t{timestamps}) && !defined($target_t{handler})) {
        $self->_diag(0,"timestamps cannot be supplied without handler\n");
        return 0;
    }

    $target_t{targets}=$targets;
    push (@{$self->{targettypes}},\%target_t);
}

sub chainmake {
    # returns 0 oder youngest
    # 0 means failure
    my ($self,$t_name)=@_;
    unless ($t_name) {
        $self->_diag(0,"Usage: $0 Target\nType '$0 help' for more info\n\n");
        return 0;
    }

    # Target "instanziieren", d.h. Targetnamen ($t_name etc.) anwenden
    my $target=clone($self->_match_target($t_name));
    unless($target) {
        if ($t_name eq 'help') {
            print "Available targets\n-----------------\n".$self->available_targets();
        }
        else {
            $self->_diag(0,"Don't know how to make $t_name. Maybe a typo?\n");
        }
        return 0;
    }
    # split target name into base and extension, handmade
    my $t_base=$t_name;
    my $t_ext='';
    if ($t_name =~ /^(.+)\.([^\.]+)$/) {
        $t_base = $1;
        $t_ext = $2;
    }
    # apply symbols in timestamps and requirements
    for (
        (ref $target->{timestamps} eq 'ARRAY') ? @{$target->{timestamps}} : (),
        (ref $target->{requirements} eq 'ARRAY') ? @{$target->{requirements}} : (),
    ){
        s/$self->{symbols}->[0]/$t_name/g;
        s/$self->{symbols}->[1]/$t_base/g;
        s/$self->{symbols}->[2]/$t_ext/g;
    }

    # muss Handler ausführen / kann Handler wegen fehlender Req nicht ausführen
    my ($must_make,$cannot_make);

    # Rausfinden, wie alt das älteste File von timestamps ist (=> $oldest)
    # und ob vielleicht sogar eines fehlt (=> $must_make=1)
    # Generelles Designproblem ist Auflösung des Timestamps=1s (Fat32: 2s)
    my $oldest;
    if ((defined $target->{timestamps}) &&
        (ref $target->{timestamps} eq 'ARRAY') &&
        (@{$target->{timestamps}} > 0)
    ) {
        (my $yy,$oldest,my $missing)=$self->_check_file_timestamps($target->{timestamps});
        if ($missing) {
            $must_make=1;
            undef $oldest;
        }
    }
    elsif ((defined $target->{timestamps}) &&
           ($target->{timestamps} eq 'once')) {
        my $ts=$self->_get_timestamp($t_name);
        if ($ts) {
            $oldest=$ts;
        }
        else {
            $must_make=1;
        }
    }
    # timestamps gibts nicht / unverständlich
    else {
        $must_make=1;
    }

    # Alle Requirements daraufhin prüfen (d.h. chainmake() darauf ausführen),
    # ob eines der Requirements jünger als unser ältestes timestamps-File ($oldest) ist
    my $youngest_req;
    if (ref $target->{requirements} eq 'ARRAY') {
        $youngest_req=$self->_check_requirements($target->{requirements},$target->{insistent},$target->{parallel});
        if ($youngest_req) {
            #print "$t_name - y: $youngest_req, o: $oldest ".(($youngest_req > $oldest) ? "younger (must make)\n": "older\n");
            $must_make=1 if ($oldest && ($youngest_req > $oldest));
        }
        else {
            $cannot_make=1;
        }
    }

    # From here on we potentially return from the method
    # to avoid too deeply nested if if ifs.

    # Irgendwas nicht erfolgreich?
    if ($cannot_make) {
        $self->_diag(2,"Cannot make '$t_name' due to missing requirements\n");
        return 0;
    }

    # Muss nix machen
    unless ($must_make) {
        $self->_diag(2,"Nothing to do for target '$t_name'.\n");
        if ((ref $target->{timestamps} eq 'ARRAY') && (@{$target->{timestamps}} > 0)) {
            (my $youngest,my $ol,my $missing)=$self->_check_file_timestamps($target->{timestamps});
            if ($missing) {
                $self->_diag(0,"This should not happen. Timestamps file '$missing' is still missing\n");
                return 0;
            }
            return $youngest;
        }
        # auto timestamps
        elsif ($target->{timestamps} eq 'once') {
            return $oldest; # hat sich nicht geändert
        }
        # timestamps gibts nicht / unverständlich
        else {
            return 1;
        }
    }

    # Kein Handler?
    unless (ref $target->{handler} eq 'CODE') {
        $self->_diag(2,"Nothing else to do for target '$t_name'\n");
        return 1;
    }

    # Handler ausführen
    # und dann rausfinden,
    # wie jung das jüngste File von timestamps jetzt ist
    $self->_diag(2,"\nMaking target $t_name\n");
    my $success=&{$target->{handler}}($t_name, $t_base, $t_ext, $youngest_req || undef, $oldest || undef);

    my $youngest;
    if ($success) {
        my $make_time=time;
        no warnings;
        if ((ref $target->{timestamps} eq 'ARRAY') && (@{$target->{timestamps}} > 0)) {
            ($youngest,my $ol,my $missing)=$self->_check_file_timestamps($target->{timestamps});
            if ($missing) {
                $self->_diag(0,"Timestamps file '$missing' is still missing. Looks like an error in your target handler\n");
                $youngest=0;
            }
        }
        elsif ($target->{timestamps} eq 'once') {
            $self->_write_timestamp($t_name => $make_time);
            $youngest=$make_time;
        }
        else {
            # timestamps gibts nicht / unverständlich
            $youngest=$make_time;
        }
        use warnings;
    }
    else {
        # make nicht erfolgreich
        $self->_diag(2,"Making $t_name was not successfull\n");
        # evtl. vorhandene timestamps files löschen
        if ((ref $target->{timestamps} eq 'ARRAY') && (@{$target->{timestamps}} > 0)) {
            for my $timestamps (@{$target->{timestamps}}) {
                if (-e $timestamps) {
                    $self->_diag(2,"Removing timestamps file $timestamps\n");
                    unlink $timestamps or $self->_diag(0,"Removing timestamps file $timestamps was not successfull\n");
                }
            }
        }
    }

    return $youngest || 0;
}

sub execute_system {
    my ($self,%cmd)=@_;
    my $cmd;
    if ($^O =~ /MSWin32/) {
       $cmd=$cmd{Windows} || $cmd{All};
    }
    else {
        $cmd=$cmd{Linux} || $cmd{All};
    }# there are no other OS in the world so far

    $self->_diag(1,"> $cmd\n");
    system($cmd);
    if ($? == -1) {
    	$self->_diag(0,"failed to execute: $!\n");
    }
    elsif ($? & 127) {
	    $self->_diag(0,sprintf "child died with signal %d, %s coredump\n",
            ($? & 127),  ($? & 128) ? 'with' : 'without');
    }
    else {
	    my $value=$? >> 8;
        return ($value == 0);
    }
    return undef;
}

sub execute_perl {
    my ($self,$cmd)=@_;
    print "> $cmd\n";
    system("$^X $cmd");
    if ($? == -1) {
    	$self->_diag(0,"failed to execute: $!\n");
    }
    elsif ($? & 127) {
	    $self->_diag(0,sprintf "child died with signal %d, %s coredump\n",
            ($? & 127),  ($? & 128) ? 'with' : 'without');
    }
    else {
	    my $value=$? >> 8;
        return ($value == 0);
    }
    return undef;
}

sub available_targets {
    my $self=shift;
    my $list;
    for (@{$self->{targettypes}}) {
        my @targets=@{$_->{targets}};
        my $col=0;
        while (@targets) {
            $list.=sprintf "%-30.30s", shift @targets;
            $list.="\n" if $col++==3;
            $col%=3;
        }
        $list.="\n";
    }
    return $list;
}

sub _check_requirements {
    # Alle Requirements checken (d.h. make darauf ausführen),
    # und Timestamp des jüngsten zurückgeben.
    # serieller Modus
    my ($self,$req,$insistent,$parallel)=@_;
    my ($cannot_make,$cannot_make_name)=(0,'');
    my $youngest;
    REQUIREMENTS:
    for my $dep (@$req) {
        my $age;
        # ist es der Name eines Targets?
        if ($self->_match_target($dep)) {
            $age=$self->chainmake($dep);
            unless ($age) {
                $self->_diag(1,"Requirement '$dep' failed.\n");
                $cannot_make=1;
                $cannot_make_name=$dep;
                last REQUIREMENTS unless ($insistent);
            }
        }
        # oder der Name einer Datei?
        elsif (-e $dep) {
            $age=(stat($dep))[9];
        }
        # Requirement nicht auffindbar
        else {
            $self->_diag(1,"Missing requirement '$dep'.\n");
            $cannot_make=1;
            $cannot_make_name=$dep;
            last REQUIREMENTS unless ($insistent);
        }

        # ist dieses Requirement jünger als das bisher Jüngste?
        if (!($youngest) || (($age) && ($age > $youngest))) {
            $youngest=$age;
        }
    }
    return ($cannot_make ? 0 : $youngest);# $cannot_make_name kann er auch noch returnen
}

sub _match_target {
    my ($self,$t_name)=@_;
    for my $t (@{$self->{targettypes}}) {
        for my $name (@{$t->{targets}}) {
            my $match;
            if (ref($name) eq 'Regexp') {
                $match=$t_name =~ $name;
            }
            else {
                $match=$t_name eq $name;
            }
            if ($match) {
                return $t;
            }
        }
    }
    return undef;
}

sub _check_file_timestamps {
    my ($self,$ver)=@_;
    my ($oldest,$youngest,$missing);
    for my $timestamps (@{$ver}) {
        if (-e $timestamps) {
            my $mtime = (stat($timestamps))[9];
            $youngest=$mtime unless (($youngest) && ($youngest >= $mtime));
            $oldest=$mtime unless (($oldest) && ($oldest <= $mtime));
        }
        else {
            $missing=$timestamps;
        }
    }
    return ($oldest,$youngest,$missing);
}

sub _get_timestamp {
    my ($self,$target)=@_;
    my $ts;
    my $tie=tie(my @array, 'Tie::File', $self->{timestamps_file}, memory => 0, mode => O_RDONLY | O_CREAT ) or die "Kann Datei $$self{timestamps_file} nicht zum Lesen verbinden";
    $tie->flock(LOCK_SH);
    for (@array) {
        my ($t,$v)=split "\t";
        if ($t eq $target) {
            $ts=$v;
            last;
        }
    }
    undef $tie;
    untie @array;

    return $ts;
}

sub _write_timestamp {
    my ($self,$target,$val) = @_;

    my $tie=tie(my @array, 'Tie::File', $self->{timestamps_file}, memory => 0 ) or die "Kann Datei $$self{timestamps_file} nicht zum Lesen verbinden";
    $tie->flock(LOCK_EX);

    for my $n (0 .. $#array) {
        my ($t,$v) = split "\t", $array[$n];
        next unless $t eq $target;
        splice @array, $n, 1;
        last;
    }
    push(@array,"$target\t$val");
    undef $tie;
    untie @array;
}

sub delete_timestamp {
    my ($self,$target) = @_;
    my $ret=0;

    my $tie=tie(my @array, 'Tie::File', $self->{timestamps_file}, memory => 0 ) or die "Kann Datei $$self{timestamps_file} nicht zum Lesen verbinden";
    $tie->flock(LOCK_EX);

    for my $n (0 .. $#array) {
        my ($t,$v) = split "\t", $array[$n];
        if ($t eq $target) {
            splice(@array, $n, 1);
            $ret=1;
            last;
        }
    }

    undef $tie;
    untie @array;
    return $ret;
}

sub unlink_timestamps {
    my $self=shift;
    unlink $self->{timestamps_file};
    return 1;
}

sub _diag {
    my ($self,$type,$msg)=@_;
    if    ($type == 0) { # error
        print $msg unless ($self->{silent})}
    elsif ($type == 1) { # progress
        print $msg unless ($self->{silent});
    }
    elsif ($type == 2) { # verbose
        print $msg if ($self->{verbose} && !($self->{silent}));
    }
}

1;

__END__