1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
#! /usr/bin/perl -w
# This script binds the working directory to the given CVS root by
# storing the new value is the CVS/Root files
# If CVS/Repository contains the full path, it is adjusted to match
# the new root
# The environment variable CVSROOT overrides the contents of CVS/Root
require 5.004;
use strict;
sub Main ()
{
if (!$ARGV[0] || ($ARGV[0] eq '--help') || ($#ARGV > 0))
{
usage ();
}
my $root = $ARGV[0];
my $cvspath = split_root($root, "New CVS Root");
my $old_root = $ENV{"CVSROOT"};
my $fixed_root = defined ($old_root);
open(CVSADM, "cvsu --ignore --find --types C |") ||
error ("Cannot read output of cvsu");
while (<CVSADM>) {
chomp;
my $dir = $_;
unless ( $dir =~ m{/$} ) {
$dir .= "/";
}
if ($dir =~ "^\./(.*)") {
$dir = $1;
}
unless ($fixed_root) {
$old_root = get_line($dir . "Root");
}
my $old_cvspath = split_root($old_root, "Old CVS Root");
my $repo = get_line($dir . "Repository");
# if $repo is relative path, leave it as is
if ( $repo =~ m{^/} ) {
unless ( $repo =~ s{^$old_cvspath}{$cvspath} ) {
error ("${dir}Repository doesn't match ${dir}Root");
}
put_line ($dir . "Repository", $repo);
}
put_line ($dir . "Root", $root);
}
}
# Print message and exit (like "die", but without raising an exception).
# Newline is added at the end.
sub error ($)
{
print STDERR "cvschroot: ERROR: " . shift(@_) . "\n";
exit 1;
}
# print usage information and exit
sub usage ()
{
print "Usage: cvschroot ROOT\n" .
"ROOT is the CVS Root to be written to CVS/Root\n" .
"CVS/Repository is also modified if necessary\n";
exit 1;
}
# Split CVSROOT into path and everything before it.
sub split_root ($)
{
my $res;
if ( shift(@_) =~ m{^([^ ]+:([0-9]+)?)?(/[^:@ ]+)$} ) {
$res = $3;
} else {
error shift(@_) . " not recognized";
}
return $res;
}
# Read one line from file.
sub get_line ($)
{
my $file = shift(@_);
open (FILE, "< $file")
|| error ("Couldn't open $file for reading: $!");
if ($_ = <FILE>) {
chomp;
} else {
error ("Couldn't read $file");
}
close (FILE);
return $_;
}
# Write one line to file.
sub put_line ($)
{
my $file = shift(@_);
open (FILE, "> $file")
|| error ("Couldn't open $file for writing: $!");
print FILE shift(@_) . "\n";
close (FILE);
}
Main();
|
