P4::Server - Perl wrapper for control of a Perforce server

    use Error qw( :try );
    use P4::Server;

    my $server = P4::Server->new( {
            port    => $port,
    ) };
    $server->create_temp_root();
    $server->set_cleanup( 1 );
    $server->start_p4d();

    try {
        $server->load_journal_file( $journalfile );
    }
    catch P4::Server::Exception with {
        # Handle the error
    };

    # Do some operations against the server
    # Automatically stops the server and cleans up based on the cleanup flag

    perldoc P4::Server

# Copyright (C) 2007-8 Stephen Vance
# 
# This library is free software; you can redistribute it and/or
# modify it under the terms of the Perl Artistic License.
# 
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Perl
# Artistic License for more details.
# 
# You should have received a copy of the Perl Artistic License along
# with this library; if not, see:
#
#       http://www.perl.com/language/misc/Artistic.html
# 
# Designed and written by Stephen Vance (steve@vance.com) on behalf
# of The MathWorks, Inc.

package P4::Server;

use strict;
use warnings;

use Archive::Extract;
use Error qw( :warndie :try );
use Error::Exception;
use File::Path;
use File::Temp qw( tempdir );;
use IO::File;
use IO::Select;
use IO::Socket::INET;
use IPC::Open3;
use IPC::Cmd qw( can_run );
use P4;
use Symbol;

use Exception::Class (
    'P4::Server::Exception' => {
        isa         =>  'Error::Exception',
        description =>  'Base class for P4::Server-related exceptions',
    },

    'P4::Server::Exception::NoJournalFile' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'filename' ],
        description => 'Supplied journal file does not exist',
    },

    'P4::Server::Exception::FailedExec' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'command', 'reason' ],
        description => 'Process exec failed',
    },

    'P4::Server::Exception::FailedToStart' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'command', 'timeout' ],
        description => 'P4d did not respond to requests before the timeout',
    },

    'P4::Server::Exception::FailedSystem' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'command', 'retval' ],
        description => 'Process system call failed',
    },

    'P4::Server::Exception::P4DQuit' => {
        isa         => 'P4::Server::Exception',
        description => 'P4d process quit unexpectedly after starting',
    },

    'P4::Server::Exception::ServerRunning' => {
        isa         => 'P4::Server::Exception',
        description => 'Operation not allowed while server is running',
    },

    'P4::Server::Exception::ServerListening' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'port' ],
        description => 'Another server is listening on the port',
    },

    'P4::Server::Exception::NoArchiveFile' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'filename' ],
        description => 'Supplied archive file does not exist',
    },

    'P4::Server::Exception::ArchiveError' => {
        isa         => 'P4::Server::Exception',
        description => 'Error using Archive::Extract',
    },

    'P4::Server::Exception::UndefinedRoot' => {
        isa         => 'P4::Server::Exception',
        description => 'The server root is not defined when needed',
    },

    'P4::Server::Exception::BadRoot' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'dir' ],
        description => 'The server root directory does not exist',
    },

    'P4::Server::Exception::InvalidExe' => {
        isa         => 'P4::Server::Exception',
        fields      => [ 'role', 'exe' ],
        description => 'The executable for the role does not work as '
                        . 'expected',
    },
);

our $VERSION = '0.11';

use Class::Std;
{

    my %p4d_exe_of  : ATTR( get => 'p4d_exe' );
    my %p4d_timeout_of : ATTR( name => 'p4d_timeout' default => 2 );
    my %root_of     : ATTR( get => 'root' );
    my %port_of     : ATTR( get => 'port'       set => 'port' );
    my %log_of      : ATTR( get => 'log'        set => 'log' );
    my %journal_of  : ATTR( get => 'journal'    set => 'journal' );
    my %pid_of      : ATTR( get => 'pid' );
    my %cleanup_of  : ATTR( get => 'cleanup'    set => 'cleanup' );
    my $io_writer;
    my $io_reader;
    my $io_err = Symbol::gensym();

    my $dirtemplate = File::Spec->catfile(
        File::Spec->tmpdir(),
        'p4server-root-XXXXXX',
    );
    my $journaltemplate = File::Spec->catfile(
        File::Spec->tmpdir(),
        'p4server-journal-XXXXXX',
    );

sub BUILD {
    my ($self, $ident, $arg_ref) = @_;

    $pid_of{$ident} = 0;
    $self->set_p4d_exe( $arg_ref->{p4d_exe} );
    $port_of{$ident} = $arg_ref->{port} ? $arg_ref->{port} : '1666';
    $self->set_root( $arg_ref->{root} );
    $log_of{$ident} = $arg_ref->{log} ? $arg_ref->{log} : 'log';
    $journal_of{$ident} = $arg_ref->{journal} ? $arg_ref->{journal} : 'journal';

    $cleanup_of{$ident} = 1;

    return;
}

sub DEMOLISH {
    my ($self) = @_;
    my $ident = ident $self;

    # Shut down the server if necessary
    $self->stop_p4d();

    # Clean up the directory if necessary
    $self->clean_up_root();

    return;
}

sub set_root {
    my ($self, $root) = @_;
    my $ident = ident $self;

    if( $pid_of{$ident} != 0 ) {
        P4::Server::Exception::ServerRunning->throw();
    }

    $self->clean_up_root();
    $root_of{$ident} = $root;

    return;
}

sub start_p4d {
    my ($self) = @_;
    my $ident = ident $self;

    if( $pid_of{$ident} != 0 ) {
        P4::Server::Exception::ServerRunning->throw();
    }

    $self->create_temp_root();

    my $dynamic_port = defined( $port_of{$ident} ) ? 0 : 1;

    my $try_again = 1;
    while( $try_again ) {
        if( $dynamic_port ) {
            $self->_allocate_port();
        }

        try {
            $self->_launch_p4d();
            $try_again = 0;
        }
        catch P4::Server::Exception::ServerListening with {
            my $e = shift;
            # We want to retry for dynamic ports. Otherwise, rethrow.
            if( ! $dynamic_port ) {
                $e->throw();
            }
        };
        # TODO: Should we catch P4DQuit here?
        # otherwise let exceptions pass
    }

    return;
}

sub stop_p4d {
    my ($self) = @_;
    my $ident = ident $self;
    my $pid = $pid_of{$ident};

    if( $pid ) {
        kill( 15, $pid );
        waitpid( $pid, 0 );

        $self->_drain_output( $io_reader, $io_err );
    }

    $pid_of{$ident} = 0;

    return;
}

sub load_journal_file {
    my ($self, $journal) = @_;

    -f $journal
        or P4::Server::Exception::NoJournalFile->throw(
            filename => $journal
        );

    my $ident = ident $self;
    my @args = (
        $p4d_exe_of{$ident},
        '-r', $root_of{$ident},
        '-jr', $journal,
    );

    my $journal_writer;
    my $journal_reader;
    my $journal_err = Symbol::gensym();
    my $pid = open3( $journal_writer, $journal_reader, $journal_err, @args );
    waitpid( $pid, 0 );

    $self->_drain_output( $journal_reader, $journal_err );

    return;
}

sub load_journal_string {
    my ($self, $contents) = @_;

    my $fh = File::Temp->new( TEMPLATE => $journaltemplate );;
    my $journal = $fh->filename;

    print $fh $contents;
    close $fh;

    $self->load_journal_file( $journal );

    return;
}

sub create_temp_root {
    my ($self) = @_;
    my $ident = ident $self;

    return if( defined( $root_of{$ident} ) );

    my $name = tempdir( $dirtemplate, CLEANUP => $cleanup_of{$ident} );

    $root_of{ident $self} = $name;

    return;
}

sub clean_up_root {
    my ($self) = @_;
    my $ident = ident $self;
    my $root = $root_of{$ident};

    if( $pid_of{$ident} != 0 ) {
        P4::Server::Exception::ServerRunning->throw();
    }

    # Clean up the directory if necessary
    if( $cleanup_of{$ident}
            && defined( $root )
            && -d $root ) {
        rmtree( $root );
    }
}

sub set_p4d_exe {
    my ($self, $exe) = @_;

    if( ! defined( $exe ) ) {
        $exe = 'p4d';
    }

    if( ! $self->_is_exe_valid( $exe ) ) {
        P4::Server::Exception::InvalidExe->throw(
            role        => 'p4d',
            exe         => $exe,
        );
    }

    $p4d_exe_of{ident $self} = $exe;

    return;
}

sub unpack_archive_to_root_dir {
    my ($self, $archive) = @_;

    if( ! -f $archive || ! -r $archive ) {
        P4::Server::Exception::NoArchiveFile->throw( filename => $archive );
    }

    my $root = $self->get_root();
    if( ! defined( $root ) ) {
        P4::Server::Exception::UndefinedRoot->throw();
    }

    if( ! -d $root ) {
        P4::Server::Exception::BadRoot->throw( dir => $root );
    }

    my ($result, $error, $files) = $self->_extract_archive( $archive, $root );
    # TODO: This is untestable as I have not figured out how to make gunzip or
    # tar generate an error return.
    if( ! $result ) {
        P4::Server::Exception::ArchiveError->throw(
            error => $error,
        );
    }

    return $files;
}

# PRIVATE METHODS

# To be overridden for test failure injection

sub _system {
    my ($self, @args) = @_;

    return system( @args );
}

sub _is_exe_valid : RESTRICTED {
    my ($self, $exe) = @_;

    return defined( can_run( $exe ) ) ? 1 : 0;
}

sub _extract_archive : RESTRICTED {
    my ($self, $archive, $outdir) = @_;

    local $Archive::Extract::WARN = 0;
    my $extractor = Archive::Extract->new( archive => $archive );
    my $result = $extractor->extract( to => $outdir );

    return ($result, $extractor->error(), $extractor->files() );
}

sub _is_p4d_listening_on : PRIVATE {
    my ($self, $port) = @_;
    my $ident = ident $self;

    my $p4 = P4->new();
    $p4->ParseForms();
    $p4->Tagged();
    $p4->SetPort( $port );

    # Nothing's listening if we can't connect
    if( ! $p4->Connect() ) {
        return 0;
    }

    my @results = $p4->Info();
    return ! $p4->ErrorCount();
}

sub _spawn_p4d : PROTECTED {
    my ($self, @args ) = @_;

    return open3( $io_writer, $io_reader, $io_err, @args );
}

sub _drain_output : PRIVATE {
    my ($self, @handles) = @_;

    my $sel = IO::Select->new( @handles );
    my @ready;
    while( @ready = $sel->can_read( 30 ) ) {
        for my $fh ( @ready ) {
            my $buffer;

            # Read length is a magic number but is well more than any 'p4
            # info' returns.
            my $bytes_read = read( $fh, $buffer, 2048 );

            if( $bytes_read == 0 ) {
                $sel->remove( $fh );
                close( $fh );
            }
        }
    }

    close( $io_writer );
    close( $io_reader );
    close( $io_err );
}

sub _launch_p4d : PRIVATE {
    my ($self) = @_;
    my $ident = ident $self;

    my $port = $port_of{$ident};

    if( $self->_is_p4d_listening_on( $port ) ) {
        P4::Server::Exception::ServerListening->throw(
            port        => $port,
        );
    }

    # TODO: Do we check here for the validity of the args?
    # TODO: Do we check here for the existence of the root?
    my @args = (
        $p4d_exe_of{$ident},
        '-q',
        '-r', $root_of{$ident},
        '-p', $port,
        '-L', $log_of{$ident},
        '-J', $journal_of{$ident},
    );

    my $pid;
    my $process_quit = 0;
    local $SIG{CHLD} = sub { $process_quit = 1; return; };
    try {
        $pid = $self->_spawn_p4d( @args );
    }
    otherwise {
        my $e = shift;
        P4::Server::Exception::FailedExec->throw(
            command => join( ' ', @args ),
            reason  => $e,
        );
    };

    $pid_of{$ident} = $pid;

    my $timeout = $self->get_p4d_timeout();
    my $start_time = time();
    while( ! $process_quit ) {
        if( $self->_is_p4d_listening_on( $port ) ) {
            last;
        }

        if( time() - $start_time > $timeout ) {
            P4::Server::Exception::FailedToStart->throw(
                command => join( ' ', @args ),
                timeout => $timeout,
            );
        }
    }

    if( $process_quit ) {
        P4::Server::Exception::P4DQuit->throw();
    }

    return;
}

# This is restricted so it can be overridden for test failure injection.
sub _allocate_port : RESTRICTED {
    my ($self) = @_;

    # TODO: Is there a failure to test here?
    my $socket = IO::Socket::INET->new(
        Proto       => 'tcp',
        ReuseAddr   => 1,
        Listen      => 5, # Number doesn't matter, but presence does
        LocalAddr   => 'localhost',
    );

    $port_of{ident $self} = $socket->sockport();

    close( $socket );

    return;
}

}

1;
__END__