-
Notifications
You must be signed in to change notification settings - Fork 1
/
Bazaar.pm
269 lines (183 loc) · 6.17 KB
/
Bazaar.pm
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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
package VCS::Which::Plugin::Bazaar;
# Created on: 2009-05-16 16:58:36
# Create by: ivan
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$
use Moo;
use strict;
use warnings;
use version;
use Carp;
use Data::Dumper qw/Dumper/;
use English qw/ -no_match_vars /;
use Path::Tiny;
use File::chdir;
use Contextual::Return;
extends 'VCS::Which::Plugin';
our $VERSION = version->new('0.6.8');
our $name = 'Bazaar';
our $exe = 'bzr';
our $meta = '.bzr';
sub installed {
my ($self) = @_;
return $self->_installed if defined $self->_installed;
for my $path (split /[:;]/, $ENV{PATH}) {
next if !-x "$path/$exe";
return $self->_installed( 1 );
}
return $self->_installed( 0 );
}
sub used {
my ( $self, $dir ) = @_;
if (-f $dir) {
$dir = path($dir)->parent;
}
croak "$dir is not a directory!" if !-d $dir;
my $current_dir = path($dir)->absolute;
my $level = 1;
while ($current_dir) {
if ( -d "$current_dir/$meta" ) {
$self->_base( $current_dir );
return $level;
}
$level++;
# check that we still have a parent directory
last if $current_dir eq $current_dir->parent;
$current_dir = $current_dir->parent;
}
return 0;
}
sub uptodate {
my ( $self, $dir ) = @_;
$dir ||= $self->_base;
croak "'$dir' is not a directory!" if !-e $dir;
local $CWD = $dir;
my $ans = `$exe status`;
return $ans ? 0 : 1;
}
sub pull {
my ( $self, $dir ) = @_;
$dir ||= $self->_base;
croak "'$dir' is not a directory!" if !-e $dir;
local $CWD = $dir;
return !system "$exe pull > /dev/null 2> /dev/null";
}
sub cat {
my ($self, $file, $revision) = @_;
if ( $revision && $revision =~ /^-\d+$/xms ) {
my @versions = reverse `$exe log -q $file` =~ /^ revno: \s+ (\d+)/gxms;
$revision = $versions[$revision];
}
elsif ( !defined $revision ) {
$revision = '';
}
$revision &&= "-r$revision";
return `$exe cat $revision $file`;
}
sub log {
my ($self, @args) = @_;
my $args = join ' ', map {"'$_'"} @args;
return
SCALAR { scalar `$exe log $args` }
ARRAYREF {
my @raw_log = `$exe log $args`;
my @log;
my $line = '';
for my $raw (@raw_log) {
if ( $raw eq ( '-' x 60 ) . "\n" && $line ) {
CORE::push @log, $line;
$line = '';
}
elsif ( $raw ne ( '-' x 60 ) . "\n" ) {
$line .= $raw;
}
}
return \@log;
}
HASHREF {
my $logs = `$exe log $args`;
my @logs = split /^-+\n/xms, $logs;
shift @logs;
my $num = @logs;
my %log;
for my $log (@logs) {
next if $log =~ /--include-merges/;
my ($details, $description) = $log =~ /^(.*)\nmessage:\s*(.*)$/xms;
$description =~ s/\s+\Z//xms;
if (!defined $details) {
warn "Error in reading line:\n$log\n";
next;
}
my %details = map {split /:\s+/, $_, 2} split /\n/, $details, 5;
$log{$num--} = {
rev => $details{revno},
Author => $details{committer},
Date => $details{timestamp},
description => $description,
},
}
return \%log;
}
}
1;
__END__
=head1 NAME
VCS::Which::Plugin::Bazaar - The Bazaar plugin for VCS::Which
=head1 VERSION
This documentation refers to VCS::Which::Plugin::Bazaar version 0.6.8.
=head1 SYNOPSIS
use VCS::Which::Plugin::Bazaar;
# Brief but working code example(s) here showing the most common usage(s)
# This section will be as far as many users bother reading, so make it as
# educational and exemplary as possible.
=head1 DESCRIPTION
This is the plugin for the Bazaar version control system.
=head1 SUBROUTINES/METHODS
=head2 C<name ()>
Return: string - The pretty name for the System
Description: Returns the pretty name for the Bazaar
=head2 C<installed ()>
Return: bool - True if the Bazaar is installed
Description: Determines if Bazaar is actually installed and usable
=head2 C<used ($dir)>
Param: C<$dir> - string - Directory to check
Return: bool - True if the directory is versioned by this Bazaar
Description: Determines if the directory is under version control of this Bazaar
=head2 C<uptodate ($dir)>
Param: C<$dir> - string - Directory to check
Return: bool - True if the directory has no uncommitted changes
Description: Determines if the directory has no uncommitted changes
=head3 C<cat ( $file[, $revision] )>
Param: C<$file> - string - The name of the file to cat
Param: C<$revision> - string - The revision to get. If the revision is negative
it refers to the number of revisions old is desired. Any other value is
assumed to be a version control specific revision. If no revision is specified
the most recent revision is returned.
Return: The file contents of the desired revision
Description: Gets the contents of a specific revision of a file.
=head3 C<log ( @args )>
TO DO: Body
=head3 C<versions ( [$file], [@args] )>
Description: Gets all the versions of $file
=head3 C<pull ( [$dir] )>
Description: Pulls or updates the directory $dir to the newest version
=head1 DIAGNOSTICS
=head1 CONFIGURATION AND ENVIRONMENT
=head1 DEPENDENCIES
=head1 INCOMPATIBILITIES
=head1 BUGS AND LIMITATIONS
There are no known bugs in this module.
Please report problems to Ivan Wills (ivan.wills@gmail.com).
Patches are welcome.
=head1 AUTHOR
Ivan Wills - (ivan.wills@gmail.com)
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2009 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW, Australia 2077).
All rights reserved.
This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>. This program 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.
=cut