office-gobmx/solenv/bin/modules/Cvs.pm

#*************************************************************************
#
#   OpenOffice.org - a multi-platform office productivity suite
#
#   $RCSfile: Cvs.pm,v $
#
#   $Revision: 1.24 $
#
#   last change: $Author: obo $ $Date: 2006-01-16 12:32:19 $
#
#   The Contents of this file are made available subject to
#   the terms of GNU Lesser General Public License Version 2.1.
#
#
#     GNU Lesser General Public License Version 2.1
#     =============================================
#     Copyright 2005 by Sun Microsystems, Inc.
#     901 San Antonio Road, Palo Alto, CA 94303, USA
#
#     This library is free software; you can redistribute it and/or
#     modify it under the terms of the GNU Lesser General Public
#     License version 2.1, as published by the Free Software Foundation.
#
#     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 GNU
#     Lesser General Public License for more details.
#
#     You should have received a copy of the GNU Lesser General Public
#     License along with this library; if not, write to the Free Software
#     Foundation, Inc., 59 Temple Place, Suite 330, Boston,
#     MA  02111-1307  USA
#
#*************************************************************************

#
# Cvs.pm - package for manipulating CVS archives
#

package Cvs;
use strict;

use Carp;
use CwsConfig;

##### constructor ####

sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    $self->{NAME} = undef;
    $self->{HEAD} = undef;
    $self->{FLAGS} = undef;
    my $conf = CwsConfig::get_config();
    if ( $conf->cvs_binary() ) {
        $self->{CVS_BINARY} = $conf->cvs_binary();
    }
    else {
        if ($^O eq "MSWin32" ) {
            $self->{CVS_BINARY} = "cvsclt2.exe";
        }
        else {
            $self->{CVS_BINARY} = "cvs.clt2";
        }
    }
    $self->{ARCHIVE_PATH} = undef;
    $self->{REPOSITORY_REV} = undef;
    $self->{REV_DATA} = {};
    $self->{REV_SORTED} = [];
    $self->{REV_TAGS} = {};
    $self->{TAGS} = {};
    $self->{"_PARSED"} = undef;
    $self->{"_SORTED"} = undef;
    $self->{"_TAGGED"} = undef;
    bless ($self, $class);
    return $self;
}

#### methods to access per object data ####

sub name
{
    my $self = shift;
    if ( @_ ) {
        $self->{NAME} = shift;
    }
    return $self->{NAME};
}

sub cvs_binary
{
    my $self = shift;
    if ( @_ ) {
        $self->{CVS_BINARY} = shift;
    }
    return $self->{CVS_BINARY};
}

sub get_data_by_rev
{
    my $self = shift;
    $self->parse_log();

    return $self->{REV_DATA};
}

sub get_sorted_revs
{
    my $self = shift;

    if ( $self->{"_SORTED"} ) {
        return $self->{REV_SORTED};
    }

    $self->parse_log();

    sub by_rev {
        # comparison function for sorting
        my (@field_a, @field_b, $min_field, $i);

        @field_a = split /\./, $a;
        @field_b = split /\./, $b;
        $min_field = ($#field_a > $#field_b) ? $#field_b : $#field_a;

        for ($i = 0; $i <= $min_field; $i++) {
            if ( ($field_a[$i] < $field_b[$i]) ) {
                return -1;
            }
            if ( ($field_a[$i] > $field_b[$i]) ) {
                return 1;
            }
        }

        if ( $#field_a == $#field_b ) {
            return 0;
        }
        # eg. 1.70 sorts before 1.70.1.0
        ($#field_a < $#field_b) ? return -1 : return 1;
    }

    @{$self->{REV_SORTED}} = sort by_rev (keys %{$self->{REV_DATA}});
    $self->{"_SORTED"} = 1;
    return $self->{REV_SORTED};
}

sub get_tags_by_rev
{
    my $self = shift;
    my ($tag, $rev);

    if ( $self->{"_TAGGED"} ) {
        return $self->{REV_TAGS};
    }

    $self->parse_log();
    foreach $tag (keys %{$self->{TAGS}}) {
        $rev = $self->{TAGS}->{$tag};
        push (@{$self->{REV_TAGS}->{$rev}}, $tag);
    }

    $self->{"_TAGGED"} = 1;
    return $self->{REV_TAGS};
}

sub get_flags
{
    my $self = shift;
    $self->parse_log();

    return $self->{FLAGS};
}

sub get_tags
{
    my $self = shift;

    $self->parse_log();
    return $self->{TAGS};
}

sub get_head
{
    my $self = shift;

    $self->parse_log();
    return $self->{HEAD};
}

sub get_repository_rev
{
    my $self = shift;

    if( !$self->{REPOSITORY_REV} ) {
        # ignore return values
        $self->status();
    }
    return $self->{REPOSITORY_REV};
}

sub get_archive_path
{
    my $self = shift;

    if( !$self->{ARCHIVE_PATH} ) {
        # ignore return values
        $self->status();
    }
    return $self->{ARCHIVE_PATH};
}

sub is_tag
{
    my $self = shift;
    my $tag  = shift;

    my $tags_ref = $self->get_tags();
    return (defined $$tags_ref{$tag}) ? 1 : 0;
}

# Check if $label is branch label and returns revision.
sub get_branch_rev
{
    my $self  = shift;
    my $label = shift;

    return 0 if $label eq '';
    my $tags_ref = $self->get_tags();
    my $rev = $$tags_ref{$label};
    return 0 if !defined($rev);
    my @field = split('\.', $rev);
    # $label is a branch label if rev is of form (...)x.y.0.z
    return 0 if $field[-2] != 0;
    $field[-2] = $field[-1];
    # remove last
    pop @field;
    return join('.', @field);
}

sub get_latest_rev_on_branch
{
    my $self  = shift;
    my $label = shift;

    my $branch_rev = $self->get_branch_rev($label);
    return 0 if !$branch_rev;

    my $latest_rev_on_branch = 0;

    foreach ( @{$self->get_sorted_revs()} ) {
        if ( $_ =~ /^$branch_rev\.(\d+)$/ ) {
            $latest_rev_on_branch = $_;
        }
    }

    # No revision has ever been commited on this branch,
    # return branch root.
    if ( !$latest_rev_on_branch ) {
        $branch_rev =~ /^(.*)\.(\d+)$/;
        $latest_rev_on_branch = $1;
    }
    return $latest_rev_on_branch;
}


#### methods to manipulate archive ####

# Delete a revision. Use with care.
sub delete_rev
{
    my $self = shift;
    my $rev = shift;
    my $file = $self->name();

    my $response_ref = $self->execute("admin -o$rev $file");
    foreach ( @{$response_ref} ) {
        /deleting revision $rev/ && return 1;
    }
    return 0;
}

# Update archive with options $options. Returns 'success' and new revision
# on success or reason of failure. If no update happens because file was
# up-to-date consider operation a success.
sub update
{
    my $self = shift;
    my $options = shift;

    my $file = $self->name();
    my $response_ref = $self->execute("update $options $file");
    my $conflict          = 0;
    my $notknown          = 0;
    my $connectionfailure = 0;
    foreach ( @{$response_ref} ) {
        /conflicts during merge/ && ++$conflict;
        /nothing known about/ && ++$notknown;
        /\[update aborted\]: connect to/ && ++$connectionfailure;
    }
    if ( $conflict || $notknown || $connectionfailure) {
        my $failure = 'unknownfailure';
        $failure = 'conflict' if $conflict;
        $failure = 'notknown' if $notknown;
        $failure = 'connectionfailure' if $connectionfailure;
        return $failure;
    }
    return 'success';
}

# Commit $file with option $option; return 'success' or reason for failure.
# If 'success' return the new revision as second element.
sub commit
{
    my $self = shift;
    my $options = shift;

    my $file = $self->name();
    my $response_ref = $self->execute("commit $options $file");

    # already commited ?
    return 'nothingcommitted' if !@{$response_ref};

    my $conflict           = 0;
    my $uptodate           = 0;
    my $notknown           = 0;
    my $success            = 0;
    my $connectionfailure = 0;
    my $new_revision = undef;
    foreach ( @{$response_ref} ) {
        /Up-to-date check failed/ && ++$uptodate;
        /nothing known about/ && ++$notknown;
        /had a conflict and has not been modified/ && ++$conflict;
        /new revision: (delete);/ && (++$success, $new_revision = $1);
        /new revision: ([\d\.]+);/ && (++$success, $new_revision = $1);
        /\[commit aborted\]: connect to/ && ++$connectionfailure;
    }
    if ( !$success ) {
        my $failure = 'unknownfailure';
        $failure = 'conflict'          if $conflict;
        $failure = 'notuptodate'       if $uptodate;
        $failure = 'notknown'          if $notknown;
        $failure = 'connectionfailure' if $connectionfailure;
        return $failure;
    }
    return wantarray ? ('success', $new_revision) : 'success';
}

# Tag file with specified tag. Options my be specified,
# '-b' for a branch tag and -F for forced tag are valid options.
# Retagging without moving the tag is considered a succesful
# operation.
sub tag
{
    my $self    = shift;
    my $tag     = shift;
    my $options = shift;

    return 'invalidtag' if !$tag;
    # check for valid options
    if ( $options ) {
        my @elem = split(' ', $options);
        foreach (@elem) {
            unless ( /^-F/ || /-b/ ) {
                return 'invalidoption';
            }
            $options = join(' ', @elem);
        }
    }
    else {
        $options = '';
    }

    my $file = $self->name();
    my $response_ref = $self->execute("tag $options $tag $file");

    unless ( $options =~ /-F/ && $options =~ /-b/ ) {
        # No message from CVS means that tag already exists
        # and has not been moved.
        # If both -F and -b is given, CVS will always return
        # message.
        return 'success' if !@{$response_ref};
    }

    my $tagged             = 0;
    my $cant_move          = 0;
    my $connectionfailure  = 0;
    my $invalidfile        = 0;
    foreach ( @{$response_ref} ) {
        /^T \Q$file\E/ && ++$tagged;
        /NOT MOVING tag/ && ++$cant_move;
        /nothing known about/ && ++$invalidfile;
        /\[tag aborted\]: connect to/ && ++$connectionfailure;
    }
    return 'success'           if $tagged;
    return 'cantmove'          if $cant_move;
    return 'connectionfailure' if $connectionfailure;
    return 'invalidfile'       if $invalidfile;
    # should never happen
    return 'unknownfailure';
}

#### misc operations ####

# Return status information. Note that this is somewhat redundant with
# the information which can be retrieved from the log, but in some cases
# we can avoid the more expansive parsing of the log by calling this method.
# We don't save the status information between calls.
sub status
{
    my $self       = shift;

    my $file = $self->name();
    my ($nofile, $unknownfailure, $connectionfailure);
    my ($status, $working_rev);
    my ($sticky_tag, $branch, $sticky_date, $sticky_options);

    my $response_ref = $self->execute("status $file");
    foreach ( @{$response_ref} ) {
        chomp();
        /File: no file/ && ++$nofile;
        /Status:\s+([\w\-\s]+)$/ && ($status = $1);
        /Working revision:\s+((\d|\.)+)/ && ($working_rev = $1);
        /Repository revision:\s+((\d|\.)+)\s+(\S+)/ && ($self->{REPOSITORY_REV} = $1) && ($self->{ARCHIVE_PATH} = $3);
        /Sticky Tag:\s+(.+)/ && ($sticky_tag = $1);
        /Sticky Date:\s+(.+)/ && ($sticky_date = $1);
        /Sticky Options:\s+(.+)/ && ($sticky_options = $1);
        /\[status aborted\]: connect to/ && ++$connectionfailure;
    }

    return 'connectionfailure' if $connectionfailure;
    # all variables except $status will contain garbage if 'Locally Added'
    # or 'Unknown'
    return $status if ($status eq 'Locally Added' || $status eq 'Unknown');
    # same if $nofile is set
    return $status if $nofile;

    if ( $sticky_tag =~ /([\w\-]+) \(branch: ([\d\.]+)\)$/ ) {
        $sticky_tag = $1;
        $branch = $2;
    }

    $sticky_date = '' if $sticky_date eq '(none)';
    $sticky_options = '' if $sticky_options eq '(none)';

    if ( $sticky_options =~ /\-(\w+)/ ) {
        $sticky_options = $1;
    }

    $unknownfailure++ if !$status;

    return 'unknownerror' if $unknownfailure;
    return ($status, $working_rev, $self->{REPOSITORY_REV}, $sticky_tag, $branch,
            $sticky_date, $sticky_options);
}

# Return a diff between two revision of an archive.
sub diff
{
    my $self       = shift;
    my $rev1       = shift;
    my $rev2       = shift;
    my $options    = shift || '';

    my $file = $self->name();
    my ($nofile, $unknowntagfailure, $unknownrevfailure, $connectionfailure);

    my $response_ref = $self->execute("diff $options -r$rev1 -r$rev2 $file");

    foreach ( @{$response_ref} ){
        /\[diff aborted\]: connect to/ && ++$connectionfailure;
        /cvs \[server aborted\]: no such tag \w+/ && ++$unknowntagfailure;
        /cvs server: tag [\d\.]+ is not in file $file/ && ++$unknownrevfailure;
    }

    return 'connectionfailure' if $connectionfailure;
    return 'unknowntagfailure' if $unknowntagfailure;
    return 'unknownrevfailure' if $unknownrevfailure;
    return wantarray ? @{$response_ref} : $response_ref;
}
#### private methods ####

sub execute
{
    my $self    = shift;
    my $command = shift;
    my $authtimeout = 0;
    my @response;
    while () {
        if ( $authtimeout >= 5 ) {
            # fail after 5 tries
            die("FATAL: OOo CVS server authorization time out, can't continue!\nPlease notify Release Engineering.")
        }
        if ( $authtimeout > 0 ) {
            # sleep 5 seconds after a authorization timeout
            carp("WARNING: OOo CVS server authorization time out, count: $authtimeout, sleeping for 5 seconds ...");
            sleep(5);
        }
        # cvs option "-f" for disabling the reading of $HOME/.cvsrc, if any
        open(CVS, "$self->{CVS_BINARY} -f $command 2>&1 |");
        @response = <CVS>;
        close(CVS);

        foreach ( @response ) {
            if ( /unrecognized auth response/ ) {
                # don't get fooled by comment of rev. 1.14
                /#i25646#: catch 'unrecognized auth response' from OOo CVS server/ && next;
                # ok, seems to be a real timeout
                ++$authtimeout;
            }
        }
        last if !$authtimeout;
    }
    return wantarray ? @response : \@response;
}

sub parse_log
{
    my $self = shift;
    if ( $self->{"_PARSED"} ) {
        return;
    }
    my $file = $self->name();
    my $in_revisions = 0;
    my $in_tags = 0;
    my $rev_data = {};
    my ($rev, $date, $author, $state, $comment, @branches);

    my $response_ref = $self->execute("log $file");

    foreach ( @{$response_ref} ) {
        chomp;

        if ( $in_revisions ) {
            /revision\s((\d|\.)+)$/o && do { $rev = $1; next; };
            /^date:\s(\S+\s\S+);\s+author:\s(\S+);\s+state:\s(\S+);/
                && do { $date = $1; $author = $2; $state = $3; next; };
            /^branches:((\s+(\d|\.)+;)+)$/o && do {
                my $line;
                $line = $1;
                $line =~ s/\s//go;
                @branches = split(/;/, $line);
                next;
            };

            (/^----------------------------$/o || /^=============================================================================$/o) && do
            {
                $rev_data = {DATE => $date,
                             AUTHOR => $author,
                             STATE => $state,
                             COMMENT => $comment,
                             BRANCHES => [ @branches ]};
                $self->{REV_DATA}->{$rev} = $rev_data;
                $comment = undef;
                @branches = ();
                next;
            };

            $comment .= $_ . "\n" ;
        }
        elsif ( $in_tags ) {
            /^keyword\ssubstitution:\s/o && do { $self->{FLAGS} = $'; $in_tags--; next; };
            # tags may contain a hyphen
            /^\t([\w|\-]+):\s((\d|\.)+)$/o && do { $self->{TAGS}->{$1} = $2; next; };
        }
        else {
            /^----------------------------$/o && do { $in_revisions++; next; };
            /^symbolic\snames:$/o && do { $in_tags++; next; };
            /^head:\s((\d|\.)+)$/o && do { $self->{HEAD} = $1; next; };
            /^RCS file:\s((\d|\.)+)$/o && do { $self->{ARCHIVE_PATH} = $1; next; };
        }
    }

    $self->{"_PARSED"} = 1;
}

####

1; # needed by "use" or "require"