view Lib/Deployment/Batch.pm @ 7:94d47b388442

Улучшены тесты Исправлены ошибки Улучшена документация Работа над схемой DOM
author Sergey
date Mon, 24 Aug 2009 01:05:34 +0400
parents 03e58a454b20
children 16ada169ca75
line wrap: on
line source

use strict;

package Deployment::Batch;

require URI::file;

my %Provider;
our $AUTOLOAD;

our %Dirs;
our %Context;

$Context{DieOnError} = 1; # dies by default if the action fails to run

our @history;

# make all inc absolute;
@INC = map { URI::file->new_abs($_)->dir } @INC;

sub AUTOLOAD {
    my $method = $AUTOLOAD;

    shift if $_[0] eq __PACKAGE__;

    my $class = "$method";
    
    if (not $Provider{$method}) {
        (my $file = "$class.pm") =~ s/::/\//g;
        require $file;
        $Provider{$method} = 1;
    }

    my $action = $class->new(@_);
    
    push @history,$action;
    if ($Context{Immediate}) {
        $action->_Run or ($Context{DieOnError} ? die $_->LastError : return 0);
    }

    return 1;
}

sub SetDir {
    shift if $_[0] eq __PACKAGE__;
    my ($name,$dir) = @_;

    $Dirs{$name} = URI::file->new_abs($dir);
}

sub Rollback {
    return 1 if not @history;

    $_->_Rollback or $_->Log('Rollback: ',$_->LastError) foreach reverse grep { $_->isProcessed } @history;
    undef @history;
    return 1;
}

sub Commit {
    return 1 if not @history;

    # during commit we are in the immediate mode
    local $Context{Immediate} = 1;

    $_->_Run or $_->Log('Run: ',$_->LastError) and Rollback() and last foreach grep { not $_->isProcessed } @history;
    return 0 if not @history;
    undef @history;
    return 1;
}

sub DoPackage {
    shift if $_[0] eq __PACKAGE__;
    my ($package,$inline) = @_;

    Log( "The package is required" ) and return 0 if not $package;
    Log( "Processing $package" );
    my $t0 = [Time::HiRes::gettimeofday];

    if ($inline and $inline eq 'inline') {
        $inline = 1;
    } else {
        $inline = 0;
    }
    
    if (not $inline) {
        my %copy = %Context;
        local %Context = %copy;
        local @history = ();
        $Context{Package} = $Context{PackageDir} ? URI::file->new($package)->abs($Context{PackageDir}) : URI::file->new_abs($package);
        $Context{PackageDir} = URI::file->new('./')->abs($Context{Package});

        undef $@;
        do $package or Log("$package: ". ($@ || $!)) and Rollback() and Log("Rollback completed in ",Time::HiRes::tv_interval($t0)," s") and return 0;

        Log("Commiting");
        Commit or Log("Commit failed in ",Time::HiRes::tv_interval($t0)) and return 0;
        Log("Commit successful in ",Time::HiRes::tv_interval($t0),' s');
        return 1;
    } else {
        local $Context{Package} = $Context{PackageDir} ? URI::file->new($package)->abs($Context{PackageDir}) : URI::file->new_abs($package);
        local $Context{PackageDir} = URI::file->new('./')->abs($Context{Package});

        do $package or Log("$package: ". ($@ || $!)) and Rollback() and Log("Rollback completed in ",Time::HiRes::tv_interval($t0),' s') and return 0;

        return 1;
    }
}

sub Dir {
    shift if $_[0] eq __PACKAGE__;
    my $uriDir = $Dirs{$_[0]} or die "No such directory entry $_[0]";
    shift;
    return $uriDir->dir.join('/',@_);
}

sub PackageDir {
    shift if $_[0] eq __PACKAGE__;
    return $Context{PackageDir}->dir.join('/',@_);
}

sub Log {
    shift if $_[0] eq __PACKAGE__;

    if (my $hout = $Context{LogOutput}) {
        print $hout 'DoPackage: ',@_,"\n";
    }
    1;
}

1;