line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package VSS;
|
2
|
|
|
|
|
|
|
$VERSION = '1.0.2';
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
# --------------------------------------------------------------
|
5
|
|
|
|
|
|
|
# This is my first module ever, so if it
|
6
|
|
|
|
|
|
|
# sucks then blame that.
|
7
|
|
|
|
|
|
|
#
|
8
|
|
|
|
|
|
|
# This module is free software; you can redistribute it and/or
|
9
|
|
|
|
|
|
|
# modify it under the same terms as Perl itself.
|
10
|
|
|
|
|
|
|
# --------------------------------------------------------------
|
11
|
|
|
|
|
|
|
|
12
|
1
|
|
|
1
|
|
66536
|
use strict;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2327
|
|
13
|
|
|
|
|
|
|
require Exporter;
|
14
|
|
|
|
|
|
|
require Win32::OLE;
|
15
|
|
|
|
|
|
|
require Carp;
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our @ISA = qw(Exporter);
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub new {
|
20
|
0
|
|
|
0
|
|
|
my $invocant = shift();
|
21
|
0
|
|
0
|
|
|
|
my $class = ref($invocant) || $invocant;
|
22
|
0
|
|
|
|
|
|
$class = bless {
|
23
|
|
|
|
|
|
|
db_path => undef,
|
24
|
|
|
|
|
|
|
username => "",
|
25
|
|
|
|
|
|
|
password => "",
|
26
|
|
|
|
|
|
|
vss_base => undef,
|
27
|
|
|
|
|
|
|
debug => 0,
|
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
_vssdb => undef
|
30
|
|
|
|
|
|
|
}, $class;
|
31
|
0
|
|
|
|
|
|
$class->init(@_);
|
32
|
0
|
|
|
|
|
|
return $class;
|
33
|
|
|
|
|
|
|
}
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub init {
|
36
|
0
|
|
|
0
|
|
|
my $self = shift();
|
37
|
0
|
|
|
|
|
|
my %args = @_;
|
38
|
|
|
|
|
|
|
|
39
|
0
|
|
|
|
|
|
foreach (keys %args) {
|
40
|
0
|
0
|
|
|
|
|
if (exists $self->{$_}) {
|
41
|
0
|
|
|
|
|
|
$self->{$_} = $args{$_};
|
42
|
|
|
|
|
|
|
}
|
43
|
|
|
|
|
|
|
else {
|
44
|
0
|
|
|
|
|
|
Carp::croak ("unrecognized vss option $_");
|
45
|
|
|
|
|
|
|
}
|
46
|
|
|
|
|
|
|
}
|
47
|
|
|
|
|
|
|
|
48
|
0
|
0
|
|
|
|
|
if (!defined($self->{db_path}))
|
49
|
|
|
|
|
|
|
{
|
50
|
0
|
|
|
|
|
|
my $Registry;
|
51
|
0
|
|
|
|
|
|
require Win32::TieRegistry;
|
52
|
0
|
|
|
|
|
|
import Win32::TieRegistry ( Delimiter => "/", TiedRef => \$Registry );
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# Work out the DB path from the registry
|
55
|
0
|
|
|
|
|
|
$self->{'db_path'} = $Registry->{"CUser/Software/Microsoft/SourceSafe/Current Database"};
|
56
|
0
|
0
|
|
|
|
|
Carp::croak ("No VSS DB path provided and none found in registry. If you have the VSS Shell installed, use the " .
|
57
|
|
|
|
|
|
|
"'File->Open SourceSafe Database' menu option with the " .
|
58
|
|
|
|
|
|
|
"'Open this database next time...' option to set a default")
|
59
|
|
|
|
|
|
|
if (!defined($self->{'db_path'}));
|
60
|
0
|
|
|
|
|
|
$self->{'db_path'} .= "\\srcsafe.ini";
|
61
|
|
|
|
|
|
|
}
|
62
|
|
|
|
|
|
|
|
63
|
0
|
|
|
|
|
|
$self->{'_vssdb'} = Win32::OLE->new('SourceSafe');
|
64
|
0
|
|
|
|
|
|
$self->oleerr();
|
65
|
|
|
|
|
|
|
|
66
|
0
|
|
|
|
|
|
$self->{'_vssdb'}->Open($self->{'db_path'}, $self->{'username'}, $self->{'password'});
|
67
|
0
|
|
|
|
|
|
$self->oleerr();
|
68
|
|
|
|
|
|
|
}
|
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
sub _itemize {
|
71
|
0
|
|
|
0
|
|
|
my ($self, $item) = @_;
|
72
|
|
|
|
|
|
|
|
73
|
0
|
0
|
|
|
|
|
if (!(UNIVERSAL::isa($item, 'Win32::OLE'))) {
|
74
|
0
|
0
|
|
|
|
|
if ($item !~ m/^\$/) {
|
75
|
0
|
|
|
|
|
|
$item = $self->{'vss_base'}.$item;
|
76
|
|
|
|
|
|
|
}
|
77
|
|
|
|
|
|
|
|
78
|
0
|
|
|
|
|
|
$item = $self->{'_vssdb'}->VSSItem($item);
|
79
|
0
|
|
|
|
|
|
$self->oleerr();
|
80
|
0
|
|
|
|
|
|
return ($item);
|
81
|
|
|
|
|
|
|
}
|
82
|
|
|
|
|
|
|
|
83
|
0
|
0
|
|
|
|
|
if (!(UNIVERSAL::isa($item, 'Win32::OLE'))) {
|
84
|
0
|
|
|
|
|
|
return undef;
|
85
|
|
|
|
|
|
|
}
|
86
|
|
|
|
|
|
|
|
87
|
0
|
|
|
|
|
|
return ($item);
|
88
|
|
|
|
|
|
|
}
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub _itemize_name {
|
91
|
0
|
|
|
0
|
|
|
my ($self, $item) = @_;
|
92
|
|
|
|
|
|
|
|
93
|
0
|
0
|
|
|
|
|
if (UNIVERSAL::isa($item, 'Win32::OLE')) {
|
94
|
0
|
|
|
|
|
|
return ($item->Spec());
|
95
|
|
|
|
|
|
|
}
|
96
|
|
|
|
|
|
|
|
97
|
0
|
0
|
|
|
|
|
if ($item !~ m/^\$/) {
|
98
|
0
|
|
|
|
|
|
$item = $self->{'vss_base'}.$item;
|
99
|
|
|
|
|
|
|
}
|
100
|
|
|
|
|
|
|
|
101
|
0
|
|
|
|
|
|
return ($item);
|
102
|
|
|
|
|
|
|
}
|
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub _debug {
|
105
|
0
|
|
|
0
|
|
|
my ($self, $val, $name) = @_;
|
106
|
0
|
0
|
|
|
|
|
return if (!$self->{'debug'});
|
107
|
0
|
0
|
|
|
|
|
if (UNIVERSAL::isa($val, 'Win32::OLE')) {
|
108
|
0
|
|
|
|
|
|
print "debug $name is a VSS::Item or similar\n";
|
109
|
|
|
|
|
|
|
}
|
110
|
|
|
|
|
|
|
else {
|
111
|
0
|
|
|
|
|
|
print "debug: $name is $val\n";
|
112
|
|
|
|
|
|
|
}
|
113
|
|
|
|
|
|
|
}
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub item_exists {
|
116
|
0
|
|
|
0
|
|
|
my ($self, $named_item) = @_;
|
117
|
0
|
|
|
|
|
|
$named_item = $self->_itemize_name($named_item);
|
118
|
0
|
|
|
|
|
|
my $err;
|
119
|
|
|
|
|
|
|
|
120
|
0
|
|
|
|
|
|
$named_item = $self->{'_vssdb'}->VSSItem($named_item);
|
121
|
0
|
|
|
|
|
|
$err = Win32::OLE->LastError();
|
122
|
0
|
0
|
|
|
|
|
if ($err) {
|
123
|
0
|
0
|
0
|
|
|
|
if ($err =~ m/0x8004d68f/ && $err =~ m/File or project not found/) {
|
124
|
0
|
|
|
|
|
|
return 0;
|
125
|
|
|
|
|
|
|
}
|
126
|
0
|
|
|
|
|
|
$self->oleerr();
|
127
|
|
|
|
|
|
|
}
|
128
|
|
|
|
|
|
|
|
129
|
0
|
|
|
|
|
|
return $named_item;
|
130
|
|
|
|
|
|
|
}
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub checkin {
|
133
|
0
|
|
|
0
|
|
|
my ($self, $vss_item, $comment) = @_;
|
134
|
0
|
|
|
|
|
|
$vss_item = $self->_itemize($vss_item);
|
135
|
|
|
|
|
|
|
|
136
|
0
|
0
|
|
|
|
|
if (!$vss_item) { Carp::croak ("{VSS::checkin} don't know what $vss_item is"); }
|
|
0
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
|
138
|
0
|
|
|
|
|
|
$vss_item->Checkin($comment);
|
139
|
0
|
|
|
|
|
|
$self->oleerr();
|
140
|
0
|
|
|
|
|
|
return ($vss_item);
|
141
|
|
|
|
|
|
|
}
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub checkout {
|
144
|
0
|
|
|
0
|
|
|
my ($self, $vss_item, $comment) = @_;
|
145
|
0
|
|
|
|
|
|
$vss_item = $self->_itemize($vss_item);
|
146
|
|
|
|
|
|
|
|
147
|
0
|
0
|
|
|
|
|
if (!$vss_item) { Carp::croak ("{VSS::checkout} don't know what $vss_item is"); }
|
|
0
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
|
149
|
0
|
0
|
|
|
|
|
if ($vss_item->IsCheckedOut()) { return undef; }
|
|
0
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
|
$vss_item->Checkout($comment);
|
152
|
0
|
|
|
|
|
|
$self->oleerr();
|
153
|
0
|
|
|
|
|
|
return ($vss_item);
|
154
|
|
|
|
|
|
|
}
|
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
# does this work?
|
157
|
|
|
|
|
|
|
sub local_file {
|
158
|
0
|
|
|
0
|
|
|
my ($self, $vss_item) = @_;
|
159
|
0
|
|
|
|
|
|
my $local_spec;
|
160
|
0
|
|
|
|
|
|
$vss_item = $self->_itemize($vss_item);
|
161
|
|
|
|
|
|
|
|
162
|
0
|
0
|
|
|
|
|
if (!$vss_item) { Carp::croak ("{VSS::local_file} don't know what $vss_item is"); }
|
|
0
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
|
164
|
0
|
|
|
|
|
|
$local_spec = $vss_item->LocalSpec();
|
165
|
0
|
|
|
|
|
|
$self->oleerr();
|
166
|
|
|
|
|
|
|
|
167
|
0
|
|
|
|
|
|
return ($local_spec);
|
168
|
|
|
|
|
|
|
}
|
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# no news is good news
|
171
|
|
|
|
|
|
|
sub share_and_branch {
|
172
|
0
|
|
|
0
|
|
|
my ($self, $from, $to, $autocheckin) = @_;
|
173
|
0
|
|
|
|
|
|
my $from = $self->_itemize($from);
|
174
|
0
|
|
|
|
|
|
my $to = $self->_itemize($to);
|
175
|
|
|
|
|
|
|
|
176
|
0
|
0
|
|
|
|
|
if (!$from) { Carp::croak ("{VSS::share_and_branch} don't know what $from is"); }
|
|
0
|
|
|
|
|
|
|
177
|
0
|
0
|
|
|
|
|
if (!$to) { Carp::croak ("{VSS::share_and_branch} don't know what $to is"); }
|
|
0
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
|
179
|
0
|
0
|
|
|
|
|
if ($from->IsCheckedOut()) {
|
180
|
0
|
0
|
|
|
|
|
if ($autocheckin) {
|
181
|
0
|
|
|
|
|
|
$self->checkin($from);
|
182
|
|
|
|
|
|
|
}
|
183
|
|
|
|
|
|
|
else {
|
184
|
0
|
|
|
|
|
|
return($self->_itemize_name($from).' is checked out');
|
185
|
|
|
|
|
|
|
}
|
186
|
|
|
|
|
|
|
}
|
187
|
|
|
|
|
|
|
|
188
|
0
|
|
|
|
|
|
$self->share($from, $to, 1); # delete if exists
|
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# refresh $to item
|
191
|
0
|
|
|
|
|
|
$self->branch($self->_itemize($self->_itemize_name($to)));
|
192
|
|
|
|
|
|
|
|
193
|
0
|
|
|
|
|
|
return 0;
|
194
|
|
|
|
|
|
|
}
|
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub branch {
|
197
|
0
|
|
|
0
|
|
|
my ($self, $file_item) = @_;
|
198
|
0
|
|
|
|
|
|
$file_item = $self->_itemize($file_item);
|
199
|
0
|
0
|
|
|
|
|
if (!$file_item->isa('Win32::OLE')) {
|
200
|
0
|
|
|
|
|
|
Carp::croak("{VSS::branch} $file_item is not a valid VSSItem!!");
|
201
|
|
|
|
|
|
|
}
|
202
|
|
|
|
|
|
|
|
203
|
0
|
|
|
|
|
|
$file_item->Branch(); $self->oleerr();
|
|
0
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
}
|
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub share {
|
207
|
0
|
|
|
0
|
|
|
my ($self, $from, $to, $delete_if_exists) = @_;
|
208
|
0
|
|
|
|
|
|
$from = $self->_itemize($from);
|
209
|
0
|
|
|
|
|
|
$to = $self->_itemize_name($to);
|
210
|
|
|
|
|
|
|
|
211
|
0
|
0
|
|
|
|
|
if (!$from->isa('Win32::OLE')) {
|
212
|
0
|
|
|
|
|
|
Carp::croak("{VSS::share} $from is not a valid VSSItem!!");
|
213
|
|
|
|
|
|
|
}
|
214
|
|
|
|
|
|
|
|
215
|
0
|
0
|
|
|
|
|
if ($self->item_exists($to)) {
|
216
|
0
|
0
|
|
|
|
|
if ($delete_if_exists) {
|
217
|
0
|
|
|
|
|
|
$self->destroy($to);
|
218
|
|
|
|
|
|
|
}
|
219
|
|
|
|
|
|
|
else {
|
220
|
0
|
|
|
|
|
|
return "$to exists";
|
221
|
|
|
|
|
|
|
}
|
222
|
|
|
|
|
|
|
}
|
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# get the parent directory name
|
225
|
0
|
|
|
|
|
|
$to =~ s|^(.+)/(?:.*?)?$|$1/|;
|
226
|
|
|
|
|
|
|
|
227
|
0
|
|
|
|
|
|
$to = $self->_itemize($to);
|
228
|
|
|
|
|
|
|
|
229
|
0
|
0
|
|
|
|
|
if (!$to->isa('Win32::OLE')) {
|
230
|
0
|
|
|
|
|
|
Carp::croak("{VSS::share} $to is not a valid VSSItem!!");
|
231
|
|
|
|
|
|
|
}
|
232
|
|
|
|
|
|
|
|
233
|
0
|
|
|
|
|
|
$to->Share($from); $self->oleerr();
|
|
0
|
|
|
|
|
|
|
234
|
0
|
|
|
|
|
|
return 0;
|
235
|
|
|
|
|
|
|
}
|
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub destroy {
|
238
|
0
|
|
|
0
|
|
|
my ($self, $item) = @_;
|
239
|
0
|
|
|
|
|
|
$item = $self->_itemize($item);
|
240
|
|
|
|
|
|
|
|
241
|
0
|
0
|
|
|
|
|
if (!$item->isa('Win32::OLE')) { Carp::croak ("Cannot destory $item!"); }
|
|
0
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
|
243
|
0
|
|
|
|
|
|
$item->Destroy();
|
244
|
0
|
|
|
|
|
|
$self->oleerr();
|
245
|
|
|
|
|
|
|
}
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub add {
|
248
|
0
|
|
|
0
|
|
|
my ($self, $vss_dir, $local_file) = @_;
|
249
|
0
|
|
|
|
|
|
$vss_dir = $self->_itemize_name($vss_dir);
|
250
|
|
|
|
|
|
|
|
251
|
0
|
0
|
|
|
|
|
if (!-e $local_file) {
|
252
|
0
|
|
|
|
|
|
Carp::croak("{VSS::add} $local_file does not exist!");
|
253
|
|
|
|
|
|
|
}
|
254
|
|
|
|
|
|
|
|
255
|
0
|
|
|
|
|
|
$vss_dir = $self->add_directories($vss_dir)->Add($local_file);
|
256
|
0
|
|
|
|
|
|
$self->oleerr();
|
257
|
0
|
|
|
|
|
|
return ($vss_dir); #it's actually an item.
|
258
|
|
|
|
|
|
|
}
|
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub add_directories { # ... unless they exist
|
261
|
0
|
|
|
0
|
|
|
my ($self, $dir_path) = @_;
|
262
|
0
|
|
|
|
|
|
$dir_path = $self->_itemize_name($dir_path);
|
263
|
0
|
|
|
|
|
|
my @all_dirs = split('/', $dir_path);
|
264
|
0
|
|
|
|
|
|
my $dir_base = splice (@all_dirs, 0, 1).'/'; # should be $/
|
265
|
0
|
|
|
|
|
|
my $tmp_dir = $dir_base;
|
266
|
0
|
|
|
|
|
|
foreach my $dir (@all_dirs) {
|
267
|
0
|
|
|
|
|
|
$tmp_dir .= "$dir/";
|
268
|
0
|
0
|
|
|
|
|
if (!$self->item_exists($tmp_dir)) {
|
269
|
0
|
|
|
|
|
|
$self->_debug($dir_base, 'dir_base');
|
270
|
0
|
|
|
|
|
|
$self->_itemize($dir_base)->NewSubProject($tmp_dir);
|
271
|
0
|
|
|
|
|
|
$self->oleerr();
|
272
|
|
|
|
|
|
|
}
|
273
|
0
|
|
|
|
|
|
$dir_base = $tmp_dir;
|
274
|
|
|
|
|
|
|
}
|
275
|
|
|
|
|
|
|
|
276
|
0
|
|
|
|
|
|
return ($self->_itemize($dir_base));
|
277
|
|
|
|
|
|
|
}
|
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub update {
|
280
|
0
|
|
|
0
|
|
|
my ($self, $vss_dir, $local_file_name, $local_file_path) = @_;
|
281
|
0
|
|
|
|
|
|
($vss_dir = $self->_itemize_name($vss_dir)) =~ s|([^/])$|$1/|;
|
282
|
0
|
|
|
|
|
|
my $vss_name = $vss_dir.$local_file_name;
|
283
|
|
|
|
|
|
|
|
284
|
0
|
0
|
|
|
|
|
if (!-e $local_file_path) { Carp::croak ("{VSS::update} $local_file_path does not exist"); }
|
|
0
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
|
286
|
0
|
0
|
|
|
|
|
if ($local_file_path !~ m/${local_file_name}$/i) {
|
287
|
0
|
|
|
|
|
|
Carp::croak ("{VSS::update} $local_file_path does not end with $local_file_name");
|
288
|
|
|
|
|
|
|
}
|
289
|
|
|
|
|
|
|
|
290
|
0
|
0
|
|
|
|
|
if ($self->item_exists($vss_name)) {
|
291
|
0
|
|
0
|
|
|
|
my $item = $self->checkout($vss_name) || $self->_itemize($vss_name);
|
292
|
0
|
0
|
|
|
|
|
if (!$item) {
|
293
|
0
|
|
|
|
|
|
Carp::croak ("{VSS::update} can't use item $item");
|
294
|
|
|
|
|
|
|
}
|
295
|
|
|
|
|
|
|
|
296
|
0
|
|
|
|
|
|
my $localspec = $self->local_file($item);
|
297
|
0
|
0
|
|
|
|
|
if (!$localspec) {
|
298
|
0
|
|
|
|
|
|
Carp::croak ("{VSS::update} can't get LocalSpec. All I got was $localspec!");
|
299
|
|
|
|
|
|
|
}
|
300
|
|
|
|
|
|
|
|
301
|
0
|
|
|
|
|
|
require File::Copy;
|
302
|
0
|
0
|
|
|
|
|
File::Copy::copy($local_file_path, $localspec) or
|
303
|
|
|
|
|
|
|
Carp::croak ("{VSS::update} can't copy $local_file_path to $localspec. $!");
|
304
|
|
|
|
|
|
|
|
305
|
0
|
|
|
|
|
|
$self->checkin($item);
|
306
|
0
|
|
|
|
|
|
return 1;
|
307
|
|
|
|
|
|
|
}
|
308
|
|
|
|
|
|
|
|
309
|
0
|
|
|
|
|
|
return ($self->add($vss_dir, $local_file_path));
|
310
|
|
|
|
|
|
|
}
|
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub oleerr {
|
313
|
0
|
|
|
0
|
|
|
my $cache;
|
314
|
0
|
0
|
|
|
|
|
if ($cache = Win32::OLE->LastError()) { Carp::confess("$cache\n"); }
|
|
0
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
}
|
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
1;
|
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
__END__
|