VCS::SaVeS::SVS - Support module for Standalone Versioning System(tm)

VCS-SaVeS documentation Contained in the VCS-SaVeS distribution.

Index

Code Index:

NAME

Top

VCS::SaVeS::SVS - Support module for Standalone Versioning System(tm)

SYNOPSIS

Top

This is just the support Perl Module for the SaVeS command line tools: svs and saves.

See the following manpages for more information:

    perldoc svs
    perldoc saves
    svs help

DESCRIPTION

Top

SaVeS(tm) (the Standalone Versioning System) is a very easy to use file versioning system. It gives you many of the powers of CVS, with few of the headaches.

The interface consists of two commands:

* svs

This is the main SaVeS command. It is used to control all SaVeS operations. For more information use the following command:

    svs help
* saves

This is the SaVeS shortcut that simply backs up everything under the current directory. It is identical to:

    svs import -m'saves' .

or:

    svs save -m'saves' .

AUTHOR

Top

Brian Ingerson <ingy@cpan.org>

COPYRIGHT

Top

Copyright (c) 2002 Brian Ingerson. All rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

VCS-SaVeS documentation Contained in the VCS-SaVeS distribution. 
package VCS::SaVeS::SVS;
$VERSION = '0.10';
use 5.005;
use strict;
#use VCS::SaVeS::Config;
#my $config = VCS::SaVeS::Config->new();

###############################################################################
# debugging support
###############################################################################
sub DUMP {
    require YAML;
    print STDERR YAML::Dump(@_);
}
sub PRINT {
    print STDERR @_, "\n";
}
sub DIE {
    die @_, "\n";
}

###############################################################################
# command support routines
###############################################################################
sub add {
    my ($self, $switches, $files) = @_;
    assert_repository();
    validate_files($files);
    my $file_list = files_not_in_manifest($files);
    write_manifest([read_manifest(), $file_list]);
    initialize_repository();
    my $count = update_repository($file_list, 
                                  get_message($switches));
    printf STDOUT "%d files added to MANIFEST\n", $count;
}

sub break {
    my ($self, $switches, $files) = @_;
    validate_no_files($files);
    assert_no_repository();
    make_repository();
    write_manifest([]);
    print STDOUT ".saves breakpoint created\n";
}

sub delete {
    my ($self, $switches, $files) = @_;
    assert_repository();
    validate_files($files);
    my %manifest = map {($_, 1)} @{read_manifest()};
    my $file_list = files_in_manifest($files);
    DIE "None of these files are in the manifest"
      unless @$file_list;
    if (not defined $switches->{f}) {
        printf "Are you sure you want to delete %d files from the repository? ",
               0+@$file_list;
        my $answer = <STDIN>;
        unless ($answer =~ /^(y|yes)$/i) {
            print STDOUT "svs delete aborted\n";
            return;
        }
    }
    for (@$file_list) {
        delete $manifest{$_};
        system("rm -f .saves/SAVES/$_,v") == 0
          or DIE "Can't delete .saves/SAVES/$_,v";
    }
    write_manifest([keys %manifest]);
    printf STDOUT "%d files deleted from .saves repository\n", 0+@$file_list;
}

sub diff {
    my ($self, $switches, $files) = @_;
    assert_repository();
    push @$files, '.' unless @$files;
    validate_files($files);
    show_diff($files, $switches);
}

sub find {
    my ($self, $switches, $files) = @_;
    assert_repository();
    my $pattern = $files->[0] || '';
    my $regexp = qr{$pattern};
    print "$_\n" for grep {$_ =~ $regexp}
      @{read_manifest()};
}

sub help {
    my ($self, $switches, $sections) = @_;
    my $section;
    DIE "'svs help' only takes one argument at a time"
      if @$sections > 1;
    require VCS::SaVeS::Help;
    $section = @$sections
               ? $sections->[0]
               : 'general';
    print STDOUT VCS::SaVeS::Help->$section;
}
    
sub history {
    my ($self, $switches, $files) = @_;
    assert_repository();
    assert_file_in_repository($files);
    my $file = $files->[0];
    dump_history($file);
}

sub import_ {
    my ($self, $switches, $files) = @_;
    assert_no_repository();
    push @$files, '.' unless @$files;
    validate_files($files);
    make_repository();
    write_manifest($files);
    initialize_repository();
    my $count = update_repository(read_manifest(), 
                                  get_message($switches));
    printf STDOUT "%d files imported\n", $count;
}

sub manifest {
    my ($self, $switches, $files) = @_;
    assert_repository();
    if (@$files) {
        write_manifest($files);
        print("MANIFEST updated\n");
    }
    else {
        display_manifest();
    }
}

sub remove {
    my ($self, $switches, $files) = @_;
    assert_repository();
    validate_files($files);
    my %manifest = map {($_, 1)} @{read_manifest()};
    my $file_list = files_in_manifest($files);
    delete $manifest{$_} for @$file_list;
    write_manifest([keys %manifest]);
    printf STDOUT "%d files removed from MANIFEST\n", 0+@$file_list;
}

sub restore {
    my ($self, $switches, $files) = @_;
    assert_repository();
    assert_file_in_repository($files);
    my $file = $files->[0];
    my $revision = $switches->{r} || @{parse_rlog($file)};
    if ($revision =~ /^\d+$/ and $revision > 0) {
        restore_by_number($file, $revision);
    }
    else{
        DIE "-n must be positive integer";
    }
}

sub save {
    my ($self, $switches, $files) = @_;
    assert_repository();
    push @$files, '.' unless @$files;
    validate_files($files);
    my $count = update_repository(files_in_manifest($files),
                                  get_message($switches));
    printf STDOUT "%d files saved\n", $count;
}

sub status {
    my ($self, $switches, $files) = @_;
    assert_repository();
    push @$files, '.' unless @$files;
    validate_files($files);
    show_status(files_in_manifest($files));
}

sub version {
    print STDOUT <<VERSION;

You are using version $VCS::SaVeS::SVS::VERSION of SaVeS (Standalone Versioning System)

VERSION
}

###############################################################################
# support routines
###############################################################################
sub get_message {
    my ($switches) = @_;
    my $default = '...';
    return $default if defined $switches->{M};

    if (defined $switches->{m}) {
        return $switches->{m} || $default;
    }
    $| = 1;
    my $msg = '';
    print "Enter a message, terminated with single '.' or end of file:\n";
    print ">> ";
    my $line = <STDIN>;
    while (defined $line and $line !~ /^\.$/) {
        $msg .= $line;
        print ">> ";
        $line = <STDIN>;
    }
    unless ($msg =~ /\n./s) {
        chomp $msg;
    }
    return $msg || $default;
}

sub make_repository {
    use File::Path;
    mkpath('.saves/SAVES');
}

sub write_manifest {
    my ($file_list) = @_;
    my $files = find_all_files_in_list($file_list);

    chmod 0644, '.saves/MANIFEST';
    open MANIFEST, "> .saves/MANIFEST" 
        or DIE $!;
    print MANIFEST <<END;
#==============================================================================
#
# This file was generated by the SaVeS system. It contains a manifest of
# all the files that are currently active. Note that this file contains
# no directory names. SaVeS only affects files, not directories.
#
# Please don't edit this file by hand. The following commands should be
# used to change the manifest:
#   
#   svs import - create a new manifest and set its initial contents
#   svs manifest - list or set the manifest contents
#   svs add - add a list of files to the manifest 
#   svs remove - remove a list of files from the manifest
#
#==============================================================================
END

    if (@$files) {
        print MANIFEST "$_\n" for @$files;
    }
    else {
        print MANIFEST <<END;
# NOTE: This manifest is EMPTY! If there were files in the manifest,
#       they would be listed right here.
END
    }
    
    close MANIFEST;
    chmod 0444, '.saves/MANIFEST';
}

sub initialize_repository {
    my $files = read_manifest();
    make_SAVES_paths($files);
    my $shell_commands = '';
    for my $file (@$files) {
        unless (-f ".saves/SAVES/$file,v") {
            $shell_commands .= 
              qq{rcs -q -i .saves/SAVES/$file,v < /dev/null\n};
        }
    }
    open SH, "| sh" or DIE $!;
    print SH $shell_commands;
    close SH;
}

sub update_repository {
    my ($files, $msg) = @_;
    my $shell_commands = '';
    my %stamp;
    for my $file (@$files) {
        $shell_commands .= qq{ci -q -l -m"$msg" $file .saves/SAVES/$file,v\n};
        $stamp{$file} = -M ".saves/SAVES/$file,v";
    }
    open SH, "| sh" or DIE $!;
    print SH $shell_commands;
    close SH;
    my $count = 0;
    for my $file (@$files) {
        $count++, next if $stamp{$file} < .000001;
        next unless -e ".saves/SAVES/$file,v";
        if ((-M $file) < (-M ".saves/SAVES/$file,v")) {
            system "touch .saves/SAVES/$file,v";
        }
        $count++ if (-M ".saves/SAVES/$file,v") < $stamp{$file};
    }
    return $count;
}

sub read_manifest {
    my $files = [];
    open MANIFEST, '< .saves/MANIFEST'
      or DIE "Can't open .saves/MANIFEST for input";
    @$files = map {chomp; $_} grep {not /^\s*\#/} <MANIFEST>;
    close MANIFEST;
    return $files;
}

sub display_manifest {
    my $files = read_manifest();
    print STDOUT "$_\n" for @$files;
}

sub make_SAVES_paths {
    my ($files) = @_;
    my %paths;
    use File::Path();
    for my $file (@$files) {
        (my $path = $file) =~ s/(.*)\/.*/$1/ or next;
        $paths{$path} = 1;
    }
    for (keys %paths) {
        my $path = ".saves/SAVES/$_";
        File::Path::mkpath($path) unless -e $path;
    }
}

sub find_all_files_in_list {
    my ($file_list) = @_;
    my %files = ();
    for (map {ref($_) ? @$_ : $_} @$file_list) {
        s/^\.\///, $files{$_} = 1 for find_files($_, '');
    }
    my $files = [(map {$_} sort keys %files)];
    return $files;
}

sub find_files {
    my ($file, $path) = @_;
    $file = "$path/$file" if length($path);
    return () if $file =~ /(?:^|\/)\.saves(?:\/|$)/;
    if (not -e $file) {
        warn "$file is not a valid file. Ignoring\n";
        return ();
    }
    if (-f $file) {
        return () if -B $file; # Don't allow binary files for now.
        return ($file);
    }
    if (-d $file) {
        return () if -e "$file/.saves" and $file !~ /^\.\/?$/;
        my @files = ();
        local *DIR;
        opendir(DIR, $file) or DIE "Can't opendir $file";
        while (my $new_file = readdir(DIR)) {
            next if $new_file =~ /^(\.|\.\.|(\.\/)\.saves)$/;
            push @files, find_files($new_file, $file);
        }
        return @files;
    }
    DIE "Don't know how to handle $file";
}

sub files_in_manifest {
    my ($files) = @_;
    my %manifest = map {($_, 1)} @{read_manifest()};
    return [ grep {$manifest{$_}} 
             @{find_all_files_in_list($files)}
           ];
}

sub files_not_in_manifest {
    my ($files) = @_;
    my %manifest = map {($_, 1)} @{read_manifest()};
    return [ grep {not $manifest{$_}} 
             @{find_all_files_in_list($files)} 
           ];
}

sub show_status {
    my ($file_list) = @_;
    mkdir(".saves/tmp", 0777) unless -d ".saves/tmp";
    open STATUSLIST, "> .saves/tmp/statuslist"
      or DIE $!;
    print STATUSLIST ".saves/SAVES/$_,v\n" for @$file_list;
    close STATUSLIST;
    open STATUSTEXT, "cat .saves/tmp/statuslist | xargs rlog -zLT |"
      or DIE $!;
    local $/;
    my $statustext = <STATUSTEXT>;
    close STATUSTEXT;
    my @sections = split /^=+$/m, $statustext;
    pop @sections;
    for my $section (@sections) {
        $section =~ 
          /^RCS file: (.*?)\n.*?^locks:.*?:\s+(.*?)\n/sm
            or DIE "Can't grok rlog output:\n$section";
        my ($version, $file) = ($2, $1);
        $section =~ 
          /^revision\s+\Q$version\E.*?\n.*?date:\s+(.*?);/sm
            or DIE "Can't grok rlog output:\n$section";
        my $date = $1;
        $file =~ s{^\.saves/SAVES/(.*),v$}{$1};
        my $modified = ((-M $file) < (-M ".saves/SAVES/$file,v"))
                       ? '*'
                       : ' ';
        $version =~ s/^\d+\.//;
        print STDOUT "$date ($version)$modified$file\n";
    }
}

sub dump_history {
    my ($file) = @_;
    my $rlog = parse_rlog($file);
    my $i = 1;
    for (@{$rlog}) {
        my $message = $_->{message};
        $message =~ s/(.*?)\n\s*\n.*/$1/;
        $message =~ s/\n/ /g;
        $message = substr($message, 0, 40);
        
        chomp $_->{message};
        printf STDOUT 
          "%d) %s (%6s) %s\n",
          $i++, 
          $_->{date},
          $_->{delta},
          $message;
    }
    if ((-M $file) < (-M ".saves/SAVES/$file,v")) {
        print STDOUT "*) Working file has been modified since last save\n";
    }
}

sub parse_rlog {
    my ($file) = @_;
    open RLOG, "rlog -zLT .saves/SAVES/$file |"
      or DIE $!;
    local $/;
    my $input = <RLOG>;
    close RLOG;
    (my $rlog = $input) =~ s/\n=+$.*\Z//ms;
    my @rlog = split /^-+\n/m, $rlog;
    shift(@rlog);
    my $parse;
    for (reverse @rlog) {
        /^revision\s+(\S+).*?
                  ^date:\s+(.+?);.*?
                  (?:lines:\s+(.+?))?\n
                  (?:branches:.*?\n)?
                  (.*)
                /xms or DIE "Couldn't parse rlog for '$file':\n$rlog";
        push @$parse,
          {
            revision => $1,
            date => $2,
            delta => $3 || 'Origin',
            message => $4,
          };
    }
    return $parse;
}

sub restore_by_revision {
    my ($file, $revision) = @_;
    my @revisions = @{parse_rlog($file)};
    my %revisions = map {($_->{revision}, 1)} @revisions;
    my $latest = $revisions[-1]{revision};
    DIE "Revision number is invalid"
      unless defined $revisions{$revision};
    my $command = join ' && ',
      qq{rcs -q -u $file .saves/SAVES/$file,v},
      qq{co -q -f$revision $file .saves/SAVES/$file,v},
      qq{rcs -q -l$latest $file .saves/SAVES/$file,v},
      qq{chmod +w $file},
      qq{sleep 1},
      qq{touch $file};
    system($command) == 0
      or DIE "Couldn't restore file '$file', revision '$revision'";
}

sub restore_by_number {
    my ($file, $number) = @_;
    my $rlog = parse_rlog($file);
    DIE "Revision number is invalid"
      if $number-- > @$rlog;
    my $revision = $rlog->[$number]{revision};
    restore_by_revision($file, $revision);
}

sub show_diff {
    my ($files, $switches) = @_;
    my @files = @{files_in_manifest($files)};
    my $options = '';
    if (defined $switches->{r}) {
        DIE "'diff -r' can only be used on a single file"
          unless (@files == 1);
        DIE "Invalid value for -r"
          unless $switches->{r} =~ /^(\d+)(?:-(\d+))?$/;
        my ($r1, $r2) = ($1, $2);
        my $rlog;
        for ($r1, $r2) {
            next unless defined;
            unless (/\./) {
                $_ = $_ - 1;
                $rlog ||= parse_rlog($files[0]);
                DIE "Revision number is invalid"
                  if $_ >= @$rlog;
                $_ = $rlog->[$_]{revision};
            }
        }
        $options = "-r$r1";
        $options .= " -r$r2" if defined($r2);
    }
    mkdir(".saves/tmp", 0777) unless -d ".saves/tmp";
    if (-e '.saves/tmp/diff') {
        unlink('.saves/tmp/diff')
          or DIE "Can't unlink .saves/tmp/diff";
    }
    my $shell_commands;
    for my $file (@files) {
        $shell_commands .= 
          qq{rcsdiff -q -zLT -u $options $file .saves/SAVES/$file,v} .
          qq{ >> .saves/tmp/diff\n};
    }
    open SH, "| sh" or DIE $!;
    print SH $shell_commands;
    close SH;
    open DIFF, '.saves/tmp/diff' or DIE $!;
    local $/;
    print STDOUT <DIFF>;
    close DIFF;
} 

###############################################################################
# assertions and validations
###############################################################################
sub assert_repository {
    (my $command = (caller(1))[3]) =~ s/.*::(\w+?)_?$/$1/;
    DIE "Can't do 'svs $command'; no repository in this directory.\n",
        "You can use 'svs import' to create a repository.\n"
          unless -d ".saves";
}

sub assert_no_repository {
    if (-d '.saves') {
        (my $command = (caller(1))[3]) =~ s/.*::(\w+?)_?$/$1/;
        DIE <<END;
Can't do 'svs $command'; a '.saves' repository already exists.
If you really want to $command, you must first remove the repository.
END
    }
}

sub validate_no_files {
    my ($files) = @_;
    DIE "You can't specify files for this command\n"
      if @$files;
}

sub validate_files {
    my ($files) = @_;
    my %paths;
    (my $command = (caller(1))[3]) =~ s/.*::(\w+?)_?$/$1/;
    DIE "No files specified for 'svs $command'\n"
      unless @$files;
    for (@$files) {
        my $file = $_;
        DIE "Absolute pathnames may not be used\n"
          if $file =~ /^[\/\\]/;
        DIE "Paths containing '../' not allowed\n"
          if $file =~ /\.\.\//;
        DIE "$file does not exist\n"
          unless -e $file;
        if ($file =~ m|/| or -d $file) {
            my @dirs = split '/', $file;
            pop @dirs if -f $file;
            my $path = shift(@dirs);
            $paths{$path} = 1;
            for my $dir (@dirs) {
                $path .= "/$dir";
                $paths{$path} = 1;
            }
        }
    }
    delete $paths{'.'};
    for my $path (sort keys %paths) {
        DIE <<END if -d "$path/.saves";
Can't use files in '$path'. 
It contains its own '.saves' directory.
Use 'svs merge $path',
if you want these files under the current repository.
END
    }
}

sub assert_file_in_repository {
    my ($files) = @_;
    (my $command = (caller(1))[3]) =~ s/.*::(\w+?)_?$/$1/;
    DIE "'svs $command' requires one filename\n"
      unless @$files == 1;
    $files->[0] =~ s|^\./||;
    my $file = $files->[0];
    DIE "'$file' is not a regular file\n"
      unless -f $file;
    my %manifest = map {($_, 1)} @{read_manifest()};
    DIE "'$file' is not in the manifest\n"
      unless $manifest{$file};
}

###############################################################################
# miscellaney
###############################################################################
sub AUTOLOAD {
    (my $cmd = $VCS::SaVeS::SVS::AUTOLOAD) =~ s/.*:://;
    print "The svs '$cmd' command is not yet implemented\n\n";
}

1;

__END__