Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

(Fake) CVS Import Utility

by vladb (Vicar)
on Dec 18, 2001 at 05:26 UTC ( #132755=sourcecode: print w/ replies, xml ) Need Help??

Category: Utility Scripts
Author/Contact Info Vladimir Bogdanov, b_vlad@telus.net
Description: Does exactly what a 'cvs import' command would do with the only exception that a version of working source files will not be generated inside an active CVS repository. For that matter, it also doesn't require you to execute the 'cvs checkout' command to retreave source code from the repository to start working on. This, in turn, means that you may start archiving versions of your current source files immediately after running this script inside the directory containing those source files.
#!/usr/local/bin/perl -w

use strict;
use Getopt::Std;
use File::Find;

########################
### MAIN
########################

print intro();

my %opts;
getopts("rfnvhd:m:", \%opts);
$opts{$_} = exists($opts{$_}) for qw(r f n v h);

exit if ($opts{h});

my $pwd = `pwd`; chomp($pwd);
exit unless ($opts{f} || user_prompt("Add working directory '$pwd' to 
+existing CVS repository? (y/n): ", "[yY]"));

# set CVSROOT
if (exists $opts{d}) {
    $ENV{CVSROOT} = $opts{d};
    print "CVSROOT set to '$ENV{CVSROOT}'\n";

} elsif (!(exists $ENV{CVSROOT} && length($ENV{CVSROOT}))) {
    $ENV{CVSROOT} = user_ask("\nEnvironment variable CVSROOT is not se
+t! What should I set it to?\n CVSROOT: ");
    check_cvsroot();

} else {
    print "Will use existing CVSROOT '" . $ENV{CVSROOT} ."'\n";
    $ENV{CVSROOT} = user_ask("\nNew CVSROOT: ") unless ($opts{f} || us
+er_prompt("Confirm if you are OK with it? (y/n): ", "[yY]"));
    check_cvsroot();
}

my $cvs_repository = (exists $opts{m}) ? $opts{m} : 
    user_ask("\nRepository module name for the working directory: ");
my $cvs_dir = "$pwd/CVS";

# check top CVS directory to ensure that user doesn't re-initialize
# a working directory that may already belong to a cvs repository.
if (!$opts{f} && -d $cvs_dir) {
    print "\nDirectory '$cvs_dir' already exists!\n"
      ."Which implies that this working directory may already belong t
+o an existing cvs repository.";
    exit unless user_prompt("\nProceed anyway? (will replace the conte
+nts of '$cvs_dir' cvs directory) (y/n): ", "[yY]");    
}

eval {  
    print "Initializing...\n";
    my @modules = qw();

    if ($opts{r}) {
    my %failed_modules;

    # will have to operate on each sub directory 
    # (similar to what a 'cvs import' would do)
    @modules = @{get_child_modules({        
        dir  => $pwd,
        skip => "CVS",
        exceptions => \%failed_modules
    })};
    
    if ($opts{v}) {
        print "SKIPPED DIRECTORIES\n";
        foreach (keys %failed_modules) {
        print "\tDIRECTORY: $_\n"
             ."\tREASON:    ". $failed_modules{$_} ."\n";
        }        
    }
    }

    cvs_init_module({
    cvs_root => $ENV{CVSROOT},
    repository => $cvs_repository,
    working_root => $pwd,
    modules => \@modules,
    safe    => $opts{n},
    verbose => $opts{v}
    });

    print "\nCompleted successfully!\n";    
};
if ($@) {
    print "\nFAILED: $@\n";
    exit(0);
}

exit;

########################
### SUBS
########################

sub check_cvsroot {
    unless (-d $ENV{CVSROOT}) {
    print "Directory " . $ENV{CVSROOT} . " doesn't exist!\n";
    exit;
    }    
}

sub user_ask {
    print $_[0];
    my $answer = <STDIN>; chomp($answer);
    return $answer;
}

sub user_prompt {
    my $answer = user_ask($_[0]);
    return ($answer =~ m/$_[1]/);
}

#---------------------------------------------------------------------
# mkdir_rec($dir, $mode, $safe)
# 
# safe = 1 - return appropriate numerical code instead of a die.
#        0 - die. (default)
#
sub mkdir_rec {
    my ($dir, $mode, $safe) = @_;
    return 0 unless ($dir);               # $dir required.
    return 1 if (-d $dir);                # return if already exists

    my $mode_o = ($mode)?"-m $mode":"";
    
    # execute shell comand: use -p to create directories recursively
    # back tick command should return 0 on failure.
    system("mkdir -p $dir $mode_o") == 0
    or ($safe ? return 0 : die "Failed to create '$dir'.");
    
    return 1;
}

sub touch {
    my $now = time;
    local (*TMP);
    foreach my $file (@_) {
    utime ($now, $now, $file)
        || open (TMP, ">>$file")
        || die ("Couldn't touch file: $!\n");
    }
}

sub wanted {    
#    print "DIR: $_\n"; 
#    if (-d $_) { print "true\n"; }
    print "here\n";
}

sub get_child_modules {
    my ($startdir, $skip_match, $exceptions) = @{$_[0]}{qw(dir skip ex
+ceptions)};
    my $startdir_len = length($startdir);    
    my (@dirs);
    
    # I rewrite sigwarn to 'log' every directory/file that 
    # causes find() to flag a warning.
    if (ref $exceptions eq "HASH") {
    $SIG{__WARN__} = sub { 
        $$exceptions{substr($File::Find::name, $startdir_len)} = $_[0]
+; 
        splice(@dirs, -1);
    };

    } else {
    # still avoid dumping warnings even 
    # if this sub is not asked to return exceptions.
    $SIG{__WARN__} = sub {};
    }
    
    find(sub { !/$skip_match/ && -d && push @dirs, substr($File::Find:
+:name, $startdir_len); }, $startdir);

    return \@dirs;
}

sub cvs_init_module {
    my $hargs = $_[0];
    return unless (exists $$hargs{cvs_root} &&
           exists $$hargs{working_root});

    my $verbose = $$hargs{verbose} || 0;
    my @modules = @{$$hargs{modules}};
    my ($cvs_root, $working_root, $repository, $safe) = 
    @{$hargs}{qw(cvs_root working_root repository safe)};

    my ($cvs_module, $cvs_dir);
    
    print "IMPORTING\n"
     ."\tREPOSITORY -> WORKING DIRECTORY\n" if ($verbose);

    for (@modules) {
    my $cvs_module = "$cvs_root/$repository/$_";    
    clean_path($cvs_module);        
    
    my $cvs_dir = "$working_root/$_/CVS";
    clean_path($cvs_dir);

    print "\t$cvs_module -> $cvs_dir\n" if ($verbose);

    unless ($safe) {
        mkdir_rec($cvs_module);
        mkdir_rec($cvs_dir);
    
        open(FOUT, ">$cvs_dir/Repository") or die "can't open '$cvs_di
+r/Repository'";
        print FOUT "$repository";
        close(FOUT);        
    
        open(FOUT, ">$cvs_dir/Root") or die "can't open '$cvs_dir/Root
+'";
        print FOUT $ENV{CVSROOT};
        close(FOUT);   
        
        touch("$cvs_dir/Entries");    
    }    
    }
}

# clean a directory path of extraneous '/'
sub clean_path {
    for (my $i = 0; $i <= $#_; $i++) {
    # match two or more '/' between a pair of
    # other non '/' chars and replace the
    # multiple occurance of '/' with a single '/'.
    $_[$i] =~ s|([^/])[/]{2,}([^/])|$1/$2|g;
    # remove trailing garbage such as '/'...
    $_[$i] =~ s|[/\n\t\s]+$||
    }
}

sub intro {
    return <DATA>;
}

__DATA__

#---------------------------------------------------------------------
+---------
# CVSINIT Utility
# 
# Associates your current directory with an existing CVS 
# repository.  
#
# USAGE: cvsinit [-rfmv] [-d [cvs root]]
#                        [-m [new cvs module name for current working 
+directory]]
#    
#
# OPTIONS: 
#    -r  =  initialize recursively
#           (will create a CVS directory in each of the given
#            working directory's sub directories)
#
#    -f  =  don't prompt excessively
#
#    -n  =  do not execute anything that will change the disk.
#
#    -v  =  verbose
#
# comments?
# contact: Vladimir Bogdanov (b_vlad@telus.net, Perl Monk ID: vladb)
#---------------------------------------------------------------------
+---------

Comment on (Fake) CVS Import Utility
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://132755]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (6)
As of 2014-08-23 05:45 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (172 votes), past polls