line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package App::bif; |
2
|
55
|
|
|
55
|
|
1533120
|
use strict; |
|
55
|
|
|
|
|
114
|
|
|
55
|
|
|
|
|
1848
|
|
3
|
55
|
|
|
55
|
|
258
|
use warnings; |
|
55
|
|
|
|
|
91
|
|
|
55
|
|
|
|
|
2239
|
|
4
|
55
|
|
|
55
|
|
263
|
use feature 'state'; |
|
55
|
|
|
|
|
90
|
|
|
55
|
|
|
|
|
12877
|
|
5
|
55
|
|
|
55
|
|
36857
|
use utf8; # for render_table |
|
55
|
|
|
|
|
561
|
|
|
55
|
|
|
|
|
281
|
|
6
|
55
|
|
|
55
|
|
20962
|
use Bif::Mo; |
|
55
|
|
|
|
|
128
|
|
|
55
|
|
|
|
|
271
|
|
7
|
55
|
|
|
55
|
|
315
|
use Carp (); |
|
55
|
|
|
|
|
84
|
|
|
55
|
|
|
|
|
957
|
|
8
|
55
|
|
|
55
|
|
33235
|
use Config::Tiny; |
|
55
|
|
|
|
|
54329
|
|
|
55
|
|
|
|
|
3344
|
|
9
|
55
|
|
|
55
|
|
226956
|
use File::HomeDir; |
|
55
|
|
|
|
|
570263
|
|
|
55
|
|
|
|
|
4155
|
|
10
|
55
|
|
|
55
|
|
2285
|
use Log::Any qw/$log/; |
|
55
|
|
|
|
|
52973
|
|
|
55
|
|
|
|
|
484
|
|
11
|
55
|
|
|
55
|
|
838919
|
use Path::Tiny qw/path rootdir cwd/; |
|
55
|
|
|
|
|
18747
|
|
|
55
|
|
|
|
|
101269
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = '0.1.5_5'; |
14
|
|
|
|
|
|
|
our $pager; |
15
|
|
|
|
|
|
|
|
16
|
562
|
|
|
562
|
0
|
4748297
|
sub DBVERSION { 1 } |
17
|
1
|
|
|
1
|
0
|
9
|
sub MSWin32 { $^O eq 'MSWin32' } |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
has debug => ( is => 'rw', ); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
has db => ( |
22
|
|
|
|
|
|
|
is => 'ro', |
23
|
|
|
|
|
|
|
default => \&_build_db, |
24
|
|
|
|
|
|
|
); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
has dbw => ( |
27
|
|
|
|
|
|
|
is => 'rw', # for bif-new-repo? |
28
|
|
|
|
|
|
|
default => \&_build_dbw, |
29
|
|
|
|
|
|
|
); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
has _colours => ( |
32
|
|
|
|
|
|
|
is => 'ro', |
33
|
|
|
|
|
|
|
default => {}, |
34
|
|
|
|
|
|
|
); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
has config => ( |
37
|
|
|
|
|
|
|
is => 'ro', |
38
|
|
|
|
|
|
|
default => {}, |
39
|
|
|
|
|
|
|
); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
has no_pager => ( |
42
|
|
|
|
|
|
|
is => 'rw', |
43
|
|
|
|
|
|
|
default => sub { |
44
|
|
|
|
|
|
|
my $self = shift; |
45
|
|
|
|
|
|
|
return ( !-t STDOUT ) || $self->opts->{no_pager}; |
46
|
|
|
|
|
|
|
}, |
47
|
|
|
|
|
|
|
); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
has now => ( |
50
|
|
|
|
|
|
|
is => 'ro', |
51
|
|
|
|
|
|
|
default => sub { time }, |
52
|
|
|
|
|
|
|
); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
has opts => ( |
55
|
|
|
|
|
|
|
is => 'ro', |
56
|
|
|
|
|
|
|
required => 1, |
57
|
|
|
|
|
|
|
); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
has repo => ( |
60
|
|
|
|
|
|
|
is => 'rw', # needed by init |
61
|
|
|
|
|
|
|
default => \&_build_repo, |
62
|
|
|
|
|
|
|
); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
has term_width => ( |
65
|
|
|
|
|
|
|
is => 'ro', |
66
|
|
|
|
|
|
|
default => sub { |
67
|
|
|
|
|
|
|
my $width; |
68
|
|
|
|
|
|
|
if (MSWin32) { |
69
|
|
|
|
|
|
|
require Term::Size::Win32; |
70
|
|
|
|
|
|
|
$width = ( Term::Size::Win32::chars(*STDOUT) )[0] || 80; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
else { |
73
|
|
|
|
|
|
|
require Term::Size::Perl; |
74
|
|
|
|
|
|
|
$width = ( Term::Size::Perl::chars(*STDOUT) )[0] || 80; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
$log->debugf( 'bif: terminal width %d', $width ); |
77
|
|
|
|
|
|
|
return $width; |
78
|
|
|
|
|
|
|
}, |
79
|
|
|
|
|
|
|
); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
has term_height => ( |
82
|
|
|
|
|
|
|
is => 'ro', |
83
|
|
|
|
|
|
|
default => sub { |
84
|
|
|
|
|
|
|
my $height; |
85
|
|
|
|
|
|
|
if (MSWin32) { |
86
|
|
|
|
|
|
|
require Term::Size::Win32; |
87
|
|
|
|
|
|
|
$height = ( Term::Size::Win32::chars(*STDOUT) )[1] || 40; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
else { |
90
|
|
|
|
|
|
|
require Term::Size::Perl; |
91
|
|
|
|
|
|
|
$height = ( Term::Size::Perl::chars(*STDOUT) )[1] || 40; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
$log->debugf( 'bif: terminal height %d', $height ); |
94
|
|
|
|
|
|
|
return $height; |
95
|
|
|
|
|
|
|
}, |
96
|
|
|
|
|
|
|
); |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
has user_repo => ( |
99
|
|
|
|
|
|
|
is => 'ro', |
100
|
|
|
|
|
|
|
default => \&_build_user_repo, |
101
|
|
|
|
|
|
|
); |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
has user_db => ( |
104
|
|
|
|
|
|
|
is => 'ro', |
105
|
|
|
|
|
|
|
default => \&_build_user_db, |
106
|
|
|
|
|
|
|
); |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
has user_dbw => ( |
109
|
|
|
|
|
|
|
is => 'ro', |
110
|
|
|
|
|
|
|
default => \&_build_user_dbw, |
111
|
|
|
|
|
|
|
); |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
has work_buffer => ( is => 'rw', ); |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub BUILD { |
116
|
240
|
|
|
240
|
0
|
518
|
my $self = shift; |
117
|
240
|
|
|
|
|
1461
|
my $opts = $self->opts; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# For Term::ANSIColor |
120
|
240
|
|
33
|
|
|
2204
|
$ENV{ANSI_COLORS_DISABLED} //= $opts->{no_color} || !-t STDOUT; |
|
|
|
66
|
|
|
|
|
121
|
|
|
|
|
|
|
|
122
|
52
|
|
|
52
|
|
548
|
binmode STDIN, ':encoding(utf8)'; |
|
52
|
|
|
|
|
77
|
|
|
52
|
|
|
|
|
410
|
|
|
240
|
|
|
|
|
4524
|
|
123
|
240
|
|
|
|
|
81134
|
binmode STDOUT, ':encoding(utf8)'; |
124
|
|
|
|
|
|
|
|
125
|
240
|
100
|
33
|
|
|
6011
|
if ( $self->debug( $self->debug // $opts->{debug} ) ) { |
126
|
1
|
|
|
|
|
7
|
require Log::Any::Adapter; |
127
|
1
|
50
|
|
|
|
4
|
if ( exists $INC{'Test/More.pm'} ) { |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# Log::Any::Adapter::Diag can be found in t/lib/ |
130
|
1
|
|
|
|
|
11
|
Log::Any::Adapter->set('Diag'); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
else { |
133
|
0
|
|
|
|
|
0
|
Log::Any::Adapter->set('+App::bif::LAA'); |
134
|
|
|
|
|
|
|
} |
135
|
1
|
|
|
|
|
290
|
$self->start_pager(); |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
240
|
|
|
|
|
1781
|
$log->infof( 'bif: %s %s', ref $self, $opts ); |
139
|
|
|
|
|
|
|
|
140
|
240
|
|
|
|
|
6450
|
return; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub _build_user_repo { |
144
|
92
|
|
|
92
|
|
199
|
my $self = shift; |
145
|
92
|
|
|
|
|
917
|
my $repo = path( File::HomeDir->my_home, '.bifu' )->absolute; |
146
|
|
|
|
|
|
|
|
147
|
92
|
100
|
|
|
|
13729
|
$self->err( 'UserRepoNotFound', |
148
|
|
|
|
|
|
|
'user repository not found (try "bif init -u -i")' ) |
149
|
|
|
|
|
|
|
unless -d $repo; |
150
|
|
|
|
|
|
|
|
151
|
53
|
|
|
|
|
1218
|
$log->debug( 'bif: user_repo: ' . $repo ); |
152
|
|
|
|
|
|
|
|
153
|
53
|
|
|
|
|
1321
|
my $file = $repo->child('config'); |
154
|
53
|
100
|
|
|
|
1607
|
return $repo unless $file->exists; |
155
|
|
|
|
|
|
|
|
156
|
48
|
|
|
|
|
1456
|
my $config = $self->config; |
157
|
48
|
|
50
|
|
|
549
|
my $conf = Config::Tiny->read( $file, 'utf8' ) |
158
|
|
|
|
|
|
|
|| return $self->err( 'ConfigNotFound', |
159
|
|
|
|
|
|
|
$file . ' ' . Config::Tiny->errstr ); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# Merge in the repo config with the current context (user) config |
162
|
48
|
|
|
|
|
11457
|
while ( my ( $k1, $v1 ) = each %$conf ) { |
163
|
48
|
50
|
|
|
|
352
|
if ( ref $v1 eq 'HASH' ) { |
164
|
48
|
|
|
|
|
275
|
while ( my ( $k2, $v2 ) = each %$v1 ) { |
165
|
192
|
50
|
|
|
|
338
|
if ( $k1 eq '_' ) { |
166
|
0
|
|
|
|
|
0
|
$config->{$k2} = $v2; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
else { |
169
|
192
|
|
|
|
|
734
|
$config->{$k1}->{$k2} = $v2; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
else { |
174
|
0
|
|
|
|
|
0
|
$config->{$k1} = $v1; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
48
|
|
|
|
|
708
|
return $repo; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub _build_repo { |
182
|
39
|
|
|
39
|
|
72
|
my $self = shift; |
183
|
39
|
|
|
|
|
241
|
$self->user_repo; # build user repo first |
184
|
|
|
|
|
|
|
|
185
|
4
|
|
66
|
|
|
109
|
my $repo = $self->find_repo('.bif') |
186
|
|
|
|
|
|
|
|| $self->err( 'RepoNotFound', 'directory not found: .bif' ); |
187
|
|
|
|
|
|
|
|
188
|
3
|
|
|
|
|
11
|
$log->debug( 'bif: repo: ' . $repo ); |
189
|
|
|
|
|
|
|
|
190
|
3
|
|
|
|
|
49
|
my $file = $repo->child('config'); |
191
|
3
|
50
|
|
|
|
66
|
return $repo unless $file->exists; |
192
|
|
|
|
|
|
|
|
193
|
0
|
|
|
|
|
0
|
$log->debug( 'bif: repo_conf: ' . $file ); |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# Trigger user config |
196
|
0
|
|
|
|
|
0
|
$self->user_repo; |
197
|
|
|
|
|
|
|
|
198
|
0
|
|
|
|
|
0
|
my $config = $self->config; |
199
|
0
|
|
0
|
|
|
0
|
my $conf = Config::Tiny->read( $file, 'utf8' ) |
200
|
|
|
|
|
|
|
|| return $self->err( 'ConfigNotFound', |
201
|
|
|
|
|
|
|
$file . ' ' . Config::Tiny->errstr ); |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# Merge in the repo config with the current context (user) config |
204
|
0
|
|
|
|
|
0
|
while ( my ( $k1, $v1 ) = each %$conf ) { |
205
|
0
|
0
|
|
|
|
0
|
if ( ref $v1 eq 'HASH' ) { |
206
|
0
|
|
|
|
|
0
|
while ( my ( $k2, $v2 ) = each %$v1 ) { |
207
|
0
|
0
|
|
|
|
0
|
if ( $k1 eq '_' ) { |
208
|
0
|
|
|
|
|
0
|
$config->{$k2} = $v2; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
else { |
211
|
0
|
|
|
|
|
0
|
$config->{$k1}->{$k2} = $v2; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
else { |
216
|
0
|
|
|
|
|
0
|
$config->{$k1} = $v1; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
0
|
|
|
|
|
0
|
return $repo; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
sub dbfile { |
224
|
260
|
|
|
260
|
0
|
414
|
my $self = shift; |
225
|
260
|
|
|
|
|
348
|
my $version = shift; |
226
|
260
|
|
|
|
|
1867
|
return sprintf( 'db-v%d.sqlite3', $version ); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
sub _build_user_db { |
230
|
1
|
|
|
1
|
|
3
|
my $self = shift; |
231
|
1
|
|
|
|
|
4
|
my $file = $self->user_repo->child( $self->dbfile( $self->DBVERSION ) ); |
232
|
|
|
|
|
|
|
|
233
|
0
|
0
|
|
|
|
0
|
return $self->err( 'DBNotFound', 'database not found: %s', $file ) |
234
|
|
|
|
|
|
|
unless -f $file; |
235
|
|
|
|
|
|
|
|
236
|
0
|
|
|
|
|
0
|
my $dsn = 'dbi:SQLite:dbname=' . $file; |
237
|
|
|
|
|
|
|
|
238
|
0
|
|
|
|
|
0
|
require Bif::DB; |
239
|
0
|
|
|
|
|
0
|
my $db = Bif::DB->connect( $dsn, undef, undef, undef, $self->debug ); |
240
|
|
|
|
|
|
|
|
241
|
0
|
|
|
|
|
0
|
$log->debug( 'bif: user_db: ' . $dsn ); |
242
|
0
|
|
|
|
|
0
|
$log->debug( 'bif: SQLite version: ' . $db->{sqlite_version} ); |
243
|
|
|
|
|
|
|
|
244
|
0
|
|
|
|
|
0
|
return $db; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub _build_user_dbw { |
248
|
1
|
|
|
1
|
|
4
|
my $self = shift; |
249
|
1
|
|
|
|
|
5
|
my $file = $self->user_repo->child( $self->dbfile( $self->DBVERSION ) ); |
250
|
|
|
|
|
|
|
|
251
|
0
|
0
|
|
|
|
0
|
return $self->err( 'DBNotFound', 'database not found: %s', $file ) |
252
|
|
|
|
|
|
|
unless -f $file; |
253
|
|
|
|
|
|
|
|
254
|
0
|
|
|
|
|
0
|
my $dsn = 'dbi:SQLite:dbname=' . $file; |
255
|
|
|
|
|
|
|
|
256
|
0
|
|
|
|
|
0
|
require Bif::DBW; |
257
|
0
|
|
|
|
|
0
|
my $dbw = Bif::DBW->connect( $dsn, undef, undef, undef, $self->debug ); |
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
|
|
0
|
$log->debug( 'bif: user_dbw: ' . $dsn ); |
260
|
0
|
|
|
|
|
0
|
$log->debug( 'bif: SQLite version: ' . $dbw->{sqlite_version} ); |
261
|
|
|
|
|
|
|
|
262
|
0
|
|
|
|
|
0
|
return $dbw; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub _build_db { |
266
|
19
|
|
|
19
|
|
39
|
my $self = shift; |
267
|
19
|
|
|
|
|
121
|
my $file = $self->repo->child( $self->dbfile( $self->DBVERSION ) ); |
268
|
|
|
|
|
|
|
|
269
|
0
|
0
|
|
|
|
0
|
return $self->err( 'DBNotFound', 'database not found: %s', $file ) |
270
|
|
|
|
|
|
|
unless -f $file; |
271
|
|
|
|
|
|
|
|
272
|
0
|
|
|
|
|
0
|
my $dsn = 'dbi:SQLite:dbname=' . $file; |
273
|
|
|
|
|
|
|
|
274
|
0
|
|
|
|
|
0
|
require Bif::DB; |
275
|
0
|
|
|
|
|
0
|
my $db = Bif::DB->connect( $dsn, undef, undef, undef, $self->debug ); |
276
|
|
|
|
|
|
|
|
277
|
0
|
|
|
|
|
0
|
$log->debug( 'bif: db: ' . $dsn ); |
278
|
0
|
|
|
|
|
0
|
$log->debug( 'bif: SQLite version: ' . $db->{sqlite_version} ); |
279
|
|
|
|
|
|
|
|
280
|
0
|
|
|
|
|
0
|
return $db; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
sub _build_dbw { |
284
|
173
|
|
|
173
|
|
399
|
my $self = shift; |
285
|
173
|
|
|
|
|
651
|
my $file = $self->repo->child( $self->dbfile( $self->DBVERSION ) ); |
286
|
|
|
|
|
|
|
|
287
|
158
|
50
|
|
|
|
5509
|
return $self->err( 'DBNotFound', 'database not found: %s', $file ) |
288
|
|
|
|
|
|
|
unless -f $file; |
289
|
|
|
|
|
|
|
|
290
|
158
|
|
|
|
|
3658
|
my $dsn = 'dbi:SQLite:dbname=' . $file; |
291
|
|
|
|
|
|
|
|
292
|
158
|
|
|
|
|
1644
|
require Bif::DBW; |
293
|
158
|
|
|
|
|
900
|
my $dbw = Bif::DBW->connect( $dsn, undef, undef, undef, $self->debug ); |
294
|
|
|
|
|
|
|
|
295
|
158
|
|
|
|
|
5209
|
$log->debug( 'bif: dbw: ' . $dsn ); |
296
|
158
|
|
|
|
|
5083
|
$log->debug( 'bif: SQLite version: ' . $dbw->{sqlite_version} ); |
297
|
|
|
|
|
|
|
|
298
|
158
|
|
|
|
|
3254
|
return $dbw; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
### class methods ### |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
sub new_cmd { |
304
|
194
|
|
|
194
|
1
|
446
|
my $self = shift; |
305
|
194
|
|
|
|
|
359
|
my $class = shift; |
306
|
|
|
|
|
|
|
|
307
|
194
|
100
|
|
|
|
19308
|
Carp::croak($@) unless eval "require $class;"; |
308
|
|
|
|
|
|
|
|
309
|
145
|
|
|
|
|
2016
|
return $class->new( %$self, @_ ); |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub dispatch { |
313
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
314
|
0
|
|
|
|
|
0
|
my $class = shift; |
315
|
0
|
|
0
|
|
|
0
|
my $ref = shift || {}; |
316
|
|
|
|
|
|
|
|
317
|
0
|
0
|
|
|
|
0
|
Carp::croak($@) unless eval "require $class;"; |
318
|
|
|
|
|
|
|
|
319
|
0
|
|
|
|
|
0
|
return $class->new( %$self, %$ref )->run; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# Run user defined aliases |
323
|
|
|
|
|
|
|
sub run { |
324
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
325
|
0
|
|
|
|
|
0
|
my $opts = $self->opts; |
326
|
0
|
|
|
|
|
0
|
my @cmd = @{ $opts->{alias} }; |
|
0
|
|
|
|
|
0
|
|
327
|
0
|
|
|
|
|
0
|
my $alias = shift @cmd; |
328
|
|
|
|
|
|
|
|
329
|
55
|
|
|
55
|
|
388
|
use File::HomeDir; |
|
55
|
|
|
|
|
119
|
|
|
55
|
|
|
|
|
3071
|
|
330
|
55
|
|
|
55
|
|
283
|
use Path::Tiny; |
|
55
|
|
|
|
|
107
|
|
|
55
|
|
|
|
|
11357
|
|
331
|
|
|
|
|
|
|
|
332
|
0
|
|
|
|
|
0
|
my $repo = path( File::HomeDir->my_home, '.bifu' ); |
333
|
0
|
0
|
|
|
|
0
|
die usage(qq{unknown COMMAND or ALIAS "$alias"}) unless -d $repo; |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
# Trigger user config |
336
|
0
|
|
|
|
|
0
|
$self->user_repo; |
337
|
0
|
0
|
|
|
|
0
|
my $str = $self->config->{'user.alias'}->{$alias} |
338
|
|
|
|
|
|
|
or die usage(qq{unknown COMMAND or ALIAS "$alias"}); |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# Make sure these options are correctly passed through (or not) |
341
|
0
|
|
|
|
|
0
|
delete $opts->{alias}; |
342
|
0
|
0
|
|
|
|
0
|
$opts->{debug} = undef if exists $opts->{debug}; |
343
|
0
|
0
|
|
|
|
0
|
$opts->{no_pager} = undef if exists $opts->{no_pager}; |
344
|
0
|
0
|
|
|
|
0
|
$opts->{no_color} = undef if exists $opts->{no_color}; |
345
|
0
|
0
|
|
|
|
0
|
$opts->{user_repo} = undef if exists $opts->{user_repo}; |
346
|
|
|
|
|
|
|
|
347
|
0
|
|
|
|
|
0
|
unshift( @cmd, split( ' ', $str ) ); |
348
|
|
|
|
|
|
|
|
349
|
55
|
|
|
55
|
|
2752
|
use OptArgs qw/class_optargs/; |
|
55
|
|
|
|
|
80168
|
|
|
55
|
|
|
|
|
516
|
|
350
|
0
|
|
|
|
|
0
|
my ( $class, $newopts ) = OptArgs::class_optargs( 'App::bif', $opts, @cmd ); |
351
|
|
|
|
|
|
|
|
352
|
0
|
|
|
|
|
0
|
return $class->new( |
353
|
|
|
|
|
|
|
opts => $newopts, |
354
|
|
|
|
|
|
|
user_repo => $self->user_repo, |
355
|
|
|
|
|
|
|
)->run; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub find_repo { |
359
|
4
|
|
|
4
|
0
|
6
|
my $self = shift; |
360
|
4
|
|
|
|
|
6
|
my $name = shift; |
361
|
|
|
|
|
|
|
|
362
|
4
|
100
|
|
|
|
13
|
return $self->user_repo if $self->opts->{user_repo}; |
363
|
|
|
|
|
|
|
|
364
|
1
|
|
|
|
|
4
|
my $try = cwd; |
365
|
|
|
|
|
|
|
|
366
|
1
|
|
|
|
|
19
|
while (1) { |
367
|
3
|
50
|
|
|
|
63
|
if ( -d ( my $repo = $try->child($name) ) ) { |
|
|
50
|
|
|
|
|
|
368
|
0
|
|
|
|
|
0
|
return $repo; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
elsif ( -f $repo ) { # inside a repo directory |
371
|
0
|
|
|
|
|
0
|
return $try; |
372
|
|
|
|
|
|
|
} |
373
|
3
|
100
|
|
|
|
976287
|
last if $try->is_rootdir; |
374
|
2
|
|
|
|
|
41
|
$try = $try->parent; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
1
|
|
|
|
|
82
|
return; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
sub colours { |
381
|
96
|
|
|
96
|
1
|
223
|
my $self = shift; |
382
|
96
|
|
|
|
|
37341
|
state $have_term_ansicolor = require Term::ANSIColor; |
383
|
|
|
|
|
|
|
|
384
|
96
|
100
|
|
|
|
323359
|
return map { '' } @_ if $self->opts->{no_color}; |
|
16
|
|
|
|
|
39
|
|
385
|
|
|
|
|
|
|
|
386
|
88
|
|
|
|
|
779
|
my $ref = $self->_colours; |
387
|
88
|
|
66
|
|
|
254
|
map { $ref->{$_} //= Term::ANSIColor::color($_) } @_; |
|
177
|
|
|
|
|
2282
|
|
388
|
88
|
50
|
|
|
|
918
|
return map { $ref->{$_} } @_ if wantarray; |
|
177
|
|
|
|
|
420
|
|
389
|
0
|
|
|
|
|
0
|
return $ref->{ $_[0] }; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
sub header { |
393
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
394
|
0
|
|
|
|
|
0
|
state $reset = $self->colours(qw/reset/); |
395
|
0
|
|
|
|
|
0
|
state $dark = $self->colours(qw/dark/); |
396
|
|
|
|
|
|
|
|
397
|
0
|
|
|
|
|
0
|
my ( $key, $val, $val2 ) = @_; |
398
|
|
|
|
|
|
|
return [ |
399
|
0
|
0
|
|
|
|
0
|
( $key ? $key . ':' : '' ) . $reset, |
|
|
0
|
|
|
|
|
|
400
|
|
|
|
|
|
|
$val . ( defined $val2 ? $dark . ' <' . $val2 . '>' : '' ) . $reset |
401
|
|
|
|
|
|
|
]; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
sub s2hms { |
405
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
406
|
0
|
|
|
|
|
0
|
my $s = shift; |
407
|
|
|
|
|
|
|
|
408
|
0
|
|
|
|
|
0
|
return sprintf( |
409
|
|
|
|
|
|
|
'%+0.2d:%0.2d:%0.2d', |
410
|
|
|
|
|
|
|
int( $s / 3600 ), |
411
|
|
|
|
|
|
|
int( ( $s - 3600 * int( $s / 3600 ) ) / 60 ), |
412
|
|
|
|
|
|
|
$s % 60 |
413
|
|
|
|
|
|
|
); |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
sub s2hm { |
417
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
418
|
0
|
|
|
|
|
0
|
my $s = shift; |
419
|
|
|
|
|
|
|
|
420
|
0
|
|
|
|
|
0
|
return sprintf( '%+0.2d:%0.2d', |
421
|
|
|
|
|
|
|
int( $s / 3600 ), |
422
|
|
|
|
|
|
|
int( $s - 3600 * int( $s / 3600 ) ) / 60 ); |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
sub datetime2s { |
426
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
427
|
0
|
|
|
|
|
0
|
my $dt = shift; |
428
|
0
|
|
|
|
|
0
|
my $new_dt = $dt; |
429
|
|
|
|
|
|
|
|
430
|
0
|
0
|
|
|
|
0
|
if ( $dt =~ m/^(\d?\d):(\d{2})$/ ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
431
|
0
|
|
|
|
|
0
|
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = |
432
|
|
|
|
|
|
|
localtime(time); |
433
|
|
|
|
|
|
|
|
434
|
0
|
|
|
|
|
0
|
$new_dt = sprintf( |
435
|
|
|
|
|
|
|
'%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d', |
436
|
|
|
|
|
|
|
$year + 1900, |
437
|
|
|
|
|
|
|
$mon + 1, $mday, $1, $2, 0 |
438
|
|
|
|
|
|
|
); |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
elsif ( $dt =~ m/^(\d{2}):(\d{2}):(\d{2})$/ ) { |
441
|
0
|
|
|
|
|
0
|
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = |
442
|
|
|
|
|
|
|
localtime(time); |
443
|
|
|
|
|
|
|
|
444
|
0
|
|
|
|
|
0
|
$new_dt = sprintf( |
445
|
|
|
|
|
|
|
'%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d', |
446
|
|
|
|
|
|
|
$year + 1900, |
447
|
|
|
|
|
|
|
$mon + 1, $mday, $1, $2, $3 |
448
|
|
|
|
|
|
|
); |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
elsif ( $dt =~ m/^yesterday (\d?\d):(\d{2})$/ ) { |
451
|
0
|
|
|
|
|
0
|
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = |
452
|
|
|
|
|
|
|
localtime( time - 24 * 60 * 60 ); |
453
|
|
|
|
|
|
|
|
454
|
0
|
|
|
|
|
0
|
$new_dt = sprintf( |
455
|
|
|
|
|
|
|
'%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d', |
456
|
|
|
|
|
|
|
$year + 1900, |
457
|
|
|
|
|
|
|
$mon + 1, $mday, $1, $2, 0 |
458
|
|
|
|
|
|
|
); |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
elsif ( $dt =~ m/^yesterday (\d?\d):(\d{2}):(\d{2})$/ ) { |
461
|
0
|
|
|
|
|
0
|
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = |
462
|
|
|
|
|
|
|
localtime( time - 24 * 60 * 60 ); |
463
|
|
|
|
|
|
|
|
464
|
0
|
|
|
|
|
0
|
$new_dt = sprintf( |
465
|
|
|
|
|
|
|
'%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d', |
466
|
|
|
|
|
|
|
$year + 1900, |
467
|
|
|
|
|
|
|
$mon + 1, $mday, $1, $2, $3 |
468
|
|
|
|
|
|
|
); |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
elsif ( $dt =~ m/^(\d{4})-(\d{2})-(\d{2})$/ ) { |
471
|
0
|
|
|
|
|
0
|
$new_dt .= $dt . ' 00:00:00'; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
elsif ( $dt =~ m/^(\d{4})-(\d{2})-(\d{2}) (\d?\d):(\d{2})$/ ) { |
474
|
0
|
|
|
|
|
0
|
$new_dt = $dt . ':00'; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
0
|
|
|
|
|
0
|
$log->debugf( 'datetime2s "%s" -> "%s"', $dt, $new_dt ); |
478
|
0
|
0
|
|
|
|
0
|
if ( $new_dt =~ m/^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2})$/ ) { |
479
|
0
|
|
|
|
|
0
|
require Time::Local; |
480
|
0
|
|
|
|
|
0
|
return Time::Local::timelocal( $6, $5, $4, $3, $2 - 1, $1 - 1900 ); |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
|
483
|
0
|
|
|
|
|
0
|
return $self->err( 'InvalidDateTime', 'invalid date/time string: %s', $dt ); |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
sub ctime_ago { |
487
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
488
|
0
|
|
|
|
|
0
|
my $row = shift; |
489
|
|
|
|
|
|
|
|
490
|
0
|
|
|
|
|
0
|
state $have_time_piece = require Time::Piece; |
491
|
0
|
|
|
|
|
0
|
state $have_time_duration = require Time::Duration; |
492
|
|
|
|
|
|
|
|
493
|
55
|
|
|
55
|
|
95308
|
use locale; |
|
55
|
|
|
|
|
27904
|
|
|
55
|
|
|
|
|
304
|
|
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
return ( |
496
|
|
|
|
|
|
|
Time::Duration::ago( $row->{ctime_age}, 1 ), |
497
|
|
|
|
|
|
|
Time::Piece->strptime( $row->{ctime} + $row->{ctimetz}, '%s' ) |
498
|
|
|
|
|
|
|
->strftime('%a %Y-%m-%d %H:%M ') . $row->{ctimetzhm} |
499
|
0
|
|
|
|
|
0
|
); |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
sub mtime_ago { |
503
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
504
|
0
|
|
|
|
|
0
|
my $row = shift; |
505
|
|
|
|
|
|
|
|
506
|
0
|
|
|
|
|
0
|
state $have_time_piece = require Time::Piece; |
507
|
0
|
|
|
|
|
0
|
state $have_time_duration = require Time::Duration; |
508
|
|
|
|
|
|
|
|
509
|
55
|
|
|
55
|
|
7421
|
use locale; |
|
55
|
|
|
|
|
92
|
|
|
55
|
|
|
|
|
198
|
|
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
return ( |
512
|
|
|
|
|
|
|
Time::Duration::ago( $row->{mtime_age}, 1 ), |
513
|
|
|
|
|
|
|
Time::Piece->strptime( $row->{mtime} + $row->{mtimetz}, '%s' ) |
514
|
|
|
|
|
|
|
->strftime('%a %Y-%m-%d %H:%M ') . $row->{mtimetzhm} |
515
|
0
|
|
|
|
|
0
|
); |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
sub err { |
519
|
44
|
|
|
44
|
1
|
943987
|
my $self = shift; |
520
|
44
|
50
|
|
|
|
184
|
Carp::croak('err($type, $msg, [$arg])') unless @_ >= 2; |
521
|
44
|
|
|
|
|
87
|
my $err = shift; |
522
|
44
|
|
|
|
|
96
|
my $msg = shift; |
523
|
|
|
|
|
|
|
|
524
|
44
|
50
|
|
|
|
84
|
die $msg if eval { $msg->isa('Bif::Error') }; |
|
44
|
|
|
|
|
632
|
|
525
|
44
|
|
|
|
|
286
|
my ( $red, $reset ) = $self->colours(qw/red reset/); |
526
|
|
|
|
|
|
|
|
527
|
44
|
|
|
|
|
191
|
$msg = $red . 'error:' . $reset . ' ' . $msg . "\n"; |
528
|
|
|
|
|
|
|
|
529
|
44
|
|
|
|
|
159
|
die Bif::Error->new( $self->opts, $err, $msg, @_ ); |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
sub ok { |
533
|
108
|
|
|
108
|
1
|
2667
|
my $self = shift; |
534
|
108
|
50
|
|
|
|
459
|
Carp::croak('ok($type, [$arg])') unless @_; |
535
|
108
|
|
|
|
|
219
|
my $ok = shift; |
536
|
108
|
|
|
|
|
545
|
return Bif::OK->new( $self->opts, $ok, @_ ); |
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
sub start_pager { |
540
|
1
|
|
|
1
|
1
|
3
|
my $self = shift; |
541
|
1
|
|
|
|
|
2
|
my $lines = shift; |
542
|
|
|
|
|
|
|
|
543
|
1
|
50
|
33
|
|
|
114
|
return if $pager or $self->no_pager; |
544
|
|
|
|
|
|
|
|
545
|
0
|
0
|
|
|
|
0
|
if ($lines) { |
546
|
0
|
|
|
|
|
0
|
my $term_height = $self->term_height; |
547
|
0
|
0
|
|
|
|
0
|
if ( $lines <= $term_height ) { |
548
|
0
|
|
|
|
|
0
|
$log->debug("bif: no start_pager ($lines <= $term_height)"); |
549
|
0
|
|
|
|
|
0
|
return; |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
0
|
|
|
|
|
0
|
local $ENV{'LESS'} = '-FXeR'; |
554
|
0
|
0
|
|
|
|
0
|
local $ENV{'MORE'} = '-FXer' unless MSWin32; |
555
|
|
|
|
|
|
|
|
556
|
0
|
|
|
|
|
0
|
require App::bif::Pager; |
557
|
0
|
|
|
|
|
0
|
$pager = App::bif::Pager->new; |
558
|
|
|
|
|
|
|
|
559
|
0
|
|
|
|
|
0
|
$log->debugf( 'bif: start_pager (fileno: %d)', fileno( $pager->fh ) ); |
560
|
|
|
|
|
|
|
|
561
|
0
|
|
|
|
|
0
|
return $pager; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
sub end_pager { |
565
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
566
|
0
|
0
|
|
|
|
0
|
return unless $pager; |
567
|
|
|
|
|
|
|
|
568
|
0
|
|
|
|
|
0
|
$log->debug('bif: end_pager'); |
569
|
0
|
|
|
|
|
0
|
$pager = undef; |
570
|
0
|
|
|
|
|
0
|
return; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
sub user_id { |
574
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
575
|
0
|
|
|
|
|
0
|
my $id = $self->db->xval( |
576
|
|
|
|
|
|
|
select => 'bif.identity_id', |
577
|
|
|
|
|
|
|
from => 'bifkv bif', |
578
|
|
|
|
|
|
|
where => { 'bif.key' => 'self' }, |
579
|
|
|
|
|
|
|
); |
580
|
0
|
|
|
|
|
0
|
return $id; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
sub uuid2id { |
584
|
2
|
|
|
2
|
1
|
5
|
my $self = shift; |
585
|
2
|
|
33
|
|
|
10
|
my $try = shift // Carp::confess 'uuid2id needs defined'; |
586
|
2
|
|
|
|
|
8
|
my $opts = $self->opts; |
587
|
2
|
50
|
|
|
|
7
|
Carp::croak 'usage' if @_; |
588
|
|
|
|
|
|
|
|
589
|
2
|
50
|
33
|
|
|
32
|
return $try unless exists $opts->{uuid} && $opts->{uuid}; |
590
|
0
|
|
|
|
|
0
|
my @list = $self->db->uuid2id($try); |
591
|
|
|
|
|
|
|
|
592
|
0
|
0
|
|
|
|
0
|
return $self->err( 'UuidNotFound', "uuid not found: $try" ) |
593
|
|
|
|
|
|
|
unless @list; |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
return $self->err( 'UuidAmbiguous', |
596
|
|
|
|
|
|
|
"ambiguious uuid: $try\n " |
597
|
0
|
0
|
|
|
|
0
|
. join( "\n ", map { "$_->[1] -> ID:$_->[0]" } @list ) ) |
|
0
|
|
|
|
|
0
|
|
598
|
|
|
|
|
|
|
if @list > 1; |
599
|
|
|
|
|
|
|
|
600
|
0
|
|
|
|
|
0
|
return $list[0]->[0]; |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
sub get_project { |
604
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
605
|
0
|
|
0
|
|
|
0
|
my $path = shift // Carp::confess 'path must be defined'; |
606
|
0
|
|
|
|
|
0
|
my $db = $self->db; |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
0
|
my @matches = $db->get_projects($path); |
609
|
|
|
|
|
|
|
|
610
|
0
|
0
|
|
|
|
0
|
return $self->err( 'ProjectNotFound', "project not found: $path" ) |
611
|
|
|
|
|
|
|
unless @matches; |
612
|
|
|
|
|
|
|
|
613
|
0
|
0
|
|
|
|
0
|
return $matches[0] if 1 == @matches; |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
return $self->err( 'AmbiguousPath', |
616
|
|
|
|
|
|
|
"ambiguous path \"$path\" matches the following:\n" . ' ' |
617
|
0
|
|
|
|
|
0
|
. join( "\n ", map { "$_->{path}" } @matches ) ); |
|
0
|
|
|
|
|
0
|
|
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
sub get_hub { |
621
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
622
|
0
|
|
|
|
|
0
|
my $name = shift; # || Carp::confess 'get_hub($name)'; |
623
|
0
|
|
|
|
|
0
|
my $hub = $self->db->get_hub($name); |
624
|
|
|
|
|
|
|
|
625
|
0
|
0
|
|
|
|
0
|
return $self->err( 'HubNotFound', "hub not found: $name" ) |
626
|
|
|
|
|
|
|
unless $hub; |
627
|
|
|
|
|
|
|
|
628
|
0
|
|
|
|
|
0
|
return $hub; |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
sub render_table { |
632
|
1
|
|
|
1
|
1
|
3
|
my $self = shift; |
633
|
1
|
|
|
|
|
3
|
my $format = shift; |
634
|
1
|
|
|
|
|
2
|
my $header = shift; |
635
|
1
|
|
|
|
|
3
|
my $data = shift; |
636
|
1
|
|
50
|
|
|
9
|
my $indent = shift || 0; |
637
|
|
|
|
|
|
|
|
638
|
1
|
|
|
|
|
5
|
my ( $white, $dark, $reset ) = $self->colours(qw/yellow dark reset/); |
639
|
1
|
|
|
|
|
928
|
require Text::FormatTable; |
640
|
|
|
|
|
|
|
|
641
|
1
|
|
|
|
|
4154
|
my $table = Text::FormatTable->new($format); |
642
|
|
|
|
|
|
|
|
643
|
1
|
50
|
|
|
|
121
|
if ($header) { |
644
|
0
|
|
|
|
|
0
|
$header->[0] = $white . $header->[0]; |
645
|
0
|
|
|
|
|
0
|
push( @$header, ( pop @$header ) . $reset ); |
646
|
0
|
|
|
|
|
0
|
$table->head(@$header); |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
|
649
|
1
|
|
|
|
|
6
|
foreach my $row (@$data) { |
650
|
13
|
|
|
|
|
293
|
$table->row(@$row); |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
1
|
|
|
|
|
39
|
my $term_width = $self->term_width; |
654
|
1
|
50
|
|
|
|
11
|
return $table->render($term_width) unless $indent; |
655
|
|
|
|
|
|
|
|
656
|
0
|
|
|
|
|
0
|
my $str = $table->render( $term_width - $indent ); |
657
|
|
|
|
|
|
|
|
658
|
0
|
|
|
|
|
0
|
my $prefix = ' ' x $indent; |
659
|
0
|
|
|
|
|
0
|
$str =~ s/^/$prefix/gm; |
660
|
0
|
|
|
|
|
0
|
return $str; |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
sub prompt_edit { |
664
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
665
|
0
|
|
|
|
|
0
|
my %args = ( |
666
|
|
|
|
|
|
|
opts => {}, |
667
|
|
|
|
|
|
|
abort_on_empty => 1, |
668
|
|
|
|
|
|
|
val => '', |
669
|
|
|
|
|
|
|
@_, |
670
|
|
|
|
|
|
|
); |
671
|
|
|
|
|
|
|
|
672
|
0
|
|
0
|
|
|
0
|
$args{txt} //= "\n"; |
673
|
0
|
|
|
|
|
0
|
$args{txt} .= " |
674
|
|
|
|
|
|
|
# Please enter your message. Lines starting with '#' |
675
|
|
|
|
|
|
|
# are ignored. Empty content aborts. |
676
|
|
|
|
|
|
|
# |
677
|
|
|
|
|
|
|
"; |
678
|
|
|
|
|
|
|
|
679
|
0
|
|
|
|
|
0
|
my $now = time; |
680
|
|
|
|
|
|
|
|
681
|
0
|
|
|
|
|
0
|
foreach my $key ( sort keys %{ $args{opts} } ) { |
|
0
|
|
|
|
|
0
|
|
682
|
0
|
0
|
|
|
|
0
|
next if $key =~ m/^_/; |
683
|
0
|
0
|
|
|
|
0
|
next unless defined $args{opts}->{$key}; |
684
|
0
|
|
|
|
|
0
|
$args{txt} .= "# $key: $args{opts}->{$key}\n"; |
685
|
|
|
|
|
|
|
} |
686
|
|
|
|
|
|
|
|
687
|
0
|
|
|
|
|
0
|
require IO::Prompt::Tiny; |
688
|
0
|
0
|
|
|
|
0
|
if ( IO::Prompt::Tiny::_is_interactive() ) { |
689
|
0
|
|
|
|
|
0
|
require App::bif::Editor; |
690
|
0
|
|
|
|
|
0
|
$args{val} = App::bif::Editor->new( txt => $args{txt} )->result; |
691
|
|
|
|
|
|
|
} |
692
|
|
|
|
|
|
|
|
693
|
0
|
|
|
|
|
0
|
$args{val} =~ s/^#.*//gm; |
694
|
0
|
|
|
|
|
0
|
$args{val} =~ s/^\n+//s; |
695
|
0
|
|
|
|
|
0
|
$args{val} =~ s/\n*$/\n/s; |
696
|
|
|
|
|
|
|
|
697
|
0
|
0
|
|
|
|
0
|
if ( $args{abort_on_empty} ) { |
698
|
|
|
|
|
|
|
return $self->err( 'EmptyContent', 'aborting due to empty content.' ) |
699
|
0
|
0
|
|
|
|
0
|
if $args{val} =~ m/^[\s\n]*$/s; |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
0
|
|
|
|
|
0
|
return $args{val}; |
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
my $old = ''; |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
sub lprint { |
708
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
709
|
0
|
|
|
|
|
0
|
my $msg = shift; |
710
|
|
|
|
|
|
|
|
711
|
0
|
0
|
0
|
|
|
0
|
if ( $pager or $self->opts->{debug} ) { |
712
|
0
|
|
|
|
|
0
|
return print $msg . "\n"; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
|
715
|
0
|
|
|
|
|
0
|
local $| = 1; |
716
|
|
|
|
|
|
|
|
717
|
0
|
|
|
|
|
0
|
my $chars = print ' ' x length($old), "\b" x length($old), $msg, "\r"; |
718
|
0
|
0
|
|
|
|
0
|
$old = $msg =~ m/\n/ ? '' : $msg; |
719
|
0
|
|
|
|
|
0
|
return $chars; |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
sub get_change { |
723
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
724
|
0
|
|
0
|
|
|
0
|
my $token = shift // Carp::croak('get_change needs defined'); |
725
|
0
|
|
|
|
|
0
|
my $first_change_id = shift; |
726
|
|
|
|
|
|
|
|
727
|
0
|
0
|
|
|
|
0
|
return $self->err( 'InvalidChangeID', |
728
|
|
|
|
|
|
|
"invalid change ID (must be cID): $token" ) |
729
|
|
|
|
|
|
|
unless $token =~ m/^c(\d+)$/; |
730
|
|
|
|
|
|
|
|
731
|
0
|
|
|
|
|
0
|
my $id = $1; |
732
|
0
|
|
|
|
|
0
|
my $db = $self->db; |
733
|
|
|
|
|
|
|
|
734
|
0
|
|
|
|
|
0
|
my $data = $db->xhashref( |
735
|
|
|
|
|
|
|
select => [ 'c.id AS id', 'c.uuid AS uuid', ], |
736
|
|
|
|
|
|
|
from => 'changes c', |
737
|
|
|
|
|
|
|
where => { 'c.id' => $id }, |
738
|
|
|
|
|
|
|
); |
739
|
|
|
|
|
|
|
|
740
|
0
|
0
|
|
|
|
0
|
return $self->err( 'ChangeNotFound', "change not found: $token" ) |
741
|
|
|
|
|
|
|
unless $data; |
742
|
|
|
|
|
|
|
|
743
|
0
|
0
|
|
|
|
0
|
if ($first_change_id) { |
744
|
0
|
|
|
|
|
0
|
my $t = $db->xhashref( |
745
|
|
|
|
|
|
|
select => 1, |
746
|
|
|
|
|
|
|
from => 'changes_tree ct', |
747
|
|
|
|
|
|
|
where => { |
748
|
|
|
|
|
|
|
'ct.child' => $id, |
749
|
|
|
|
|
|
|
'ct.parent' => $first_change_id, |
750
|
|
|
|
|
|
|
}, |
751
|
|
|
|
|
|
|
); |
752
|
|
|
|
|
|
|
|
753
|
0
|
0
|
|
|
|
0
|
return $self->err( 'FirstChangeMismatch', |
754
|
|
|
|
|
|
|
'first change id mismatch: c%d / c%d', |
755
|
|
|
|
|
|
|
$first_change_id, $id ) |
756
|
|
|
|
|
|
|
unless $t; |
757
|
|
|
|
|
|
|
} |
758
|
|
|
|
|
|
|
|
759
|
0
|
|
|
|
|
0
|
return $data; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
sub get_node { |
763
|
3
|
|
|
3
|
1
|
5
|
my $self = shift; |
764
|
|
|
|
|
|
|
|
765
|
3
|
|
33
|
|
|
10
|
my $token = shift // Carp::confess('get_node needs defined'); |
766
|
3
|
|
|
|
|
5
|
my $kind = shift; |
767
|
3
|
|
|
|
|
17
|
my $db = $self->db; |
768
|
|
|
|
|
|
|
|
769
|
0
|
|
|
|
|
0
|
state $have_qv = DBIx::ThinSQL->import(qw/ qv bv /); |
770
|
|
|
|
|
|
|
|
771
|
0
|
0
|
|
|
|
0
|
if ( $token =~ m/^\d+$/ ) { |
772
|
0
|
|
|
|
|
0
|
my $data = $db->xhashref( |
773
|
|
|
|
|
|
|
select => [ |
774
|
|
|
|
|
|
|
'n.id AS id', |
775
|
|
|
|
|
|
|
'n.kind AS kind', |
776
|
|
|
|
|
|
|
'n.uuid AS uuid', |
777
|
|
|
|
|
|
|
'n.first_change_id AS first_change_id', |
778
|
|
|
|
|
|
|
], |
779
|
|
|
|
|
|
|
from => 'nodes n', |
780
|
|
|
|
|
|
|
where => { 'n.id' => $token }, |
781
|
|
|
|
|
|
|
); |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
return $self->err( 'WrongKind', 'node (%s) is not a %s: %d', |
784
|
|
|
|
|
|
|
$data->{kind}, $kind, $token ) |
785
|
0
|
0
|
0
|
|
|
0
|
if $data && $kind && $kind ne $data->{kind}; |
|
|
|
0
|
|
|
|
|
786
|
|
|
|
|
|
|
|
787
|
0
|
0
|
|
|
|
0
|
return $data if $data; |
788
|
|
|
|
|
|
|
} |
789
|
|
|
|
|
|
|
|
790
|
0
|
|
|
|
|
0
|
my $pinfo = eval { $self->get_project($token) }; |
|
0
|
|
|
|
|
0
|
|
791
|
0
|
0
|
0
|
|
|
0
|
die $@ if ( $@ && $@->isa('Bif::Error::AmbiguousPath') ); |
792
|
0
|
0
|
|
|
|
0
|
return $pinfo if $pinfo; |
793
|
|
|
|
|
|
|
|
794
|
0
|
|
0
|
|
|
0
|
$kind ||= 'node'; |
795
|
0
|
|
|
|
|
0
|
return $self->err( 'TopicNotFound', "$kind not found: $token" ); |
796
|
|
|
|
|
|
|
} |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
sub current_work { |
799
|
1
|
|
|
1
|
1
|
2
|
my $self = shift; |
800
|
1
|
|
|
|
|
7
|
return $self->dbw->xhashref( |
801
|
|
|
|
|
|
|
select => [ |
802
|
|
|
|
|
|
|
'n.id AS node_id', |
803
|
|
|
|
|
|
|
'n.kind AS kind', |
804
|
|
|
|
|
|
|
'n.path AS path', |
805
|
|
|
|
|
|
|
'wb.start AS start', |
806
|
|
|
|
|
|
|
'wb.billable AS billable', |
807
|
|
|
|
|
|
|
], |
808
|
|
|
|
|
|
|
from => 'work_buffers wb', |
809
|
|
|
|
|
|
|
inner_join => 'nodes n', |
810
|
|
|
|
|
|
|
on => 'n.id = wb.node_id', |
811
|
|
|
|
|
|
|
where => { 'wb.stop' => undef }, |
812
|
|
|
|
|
|
|
); |
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
sub start_work { |
816
|
50
|
|
|
50
|
1
|
150
|
my $self = shift; |
817
|
50
|
|
|
|
|
295
|
my $args = {@_}; |
818
|
50
|
|
|
|
|
314
|
my $dbw = $self->dbw; |
819
|
|
|
|
|
|
|
|
820
|
50
|
50
|
|
|
|
261
|
if ( $args->{save} ) { |
821
|
0
|
|
|
|
|
0
|
my $ref = $dbw->xhashref( |
822
|
|
|
|
|
|
|
select => '*', |
823
|
|
|
|
|
|
|
from => 'work_buffers', |
824
|
|
|
|
|
|
|
where => { stop => undef }, |
825
|
|
|
|
|
|
|
); |
826
|
|
|
|
|
|
|
|
827
|
0
|
0
|
|
|
|
0
|
if ($ref) { |
828
|
0
|
|
|
|
|
0
|
$self->stop_work( stop => $args->{start} ); |
829
|
0
|
|
|
|
|
0
|
$self->work_buffer($ref); |
830
|
|
|
|
|
|
|
} |
831
|
|
|
|
|
|
|
} |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
return $self->dbw->xdo( |
834
|
|
|
|
|
|
|
insert_into => 'work_buffers', |
835
|
|
|
|
|
|
|
values => { |
836
|
|
|
|
|
|
|
node_id => $args->{node_id}, |
837
|
|
|
|
|
|
|
start => $args->{start}, |
838
|
|
|
|
|
|
|
start_comment => $args->{start_comment}, |
839
|
|
|
|
|
|
|
stop => $args->{stop}, |
840
|
|
|
|
|
|
|
stop_comment => $args->{stop_comment}, |
841
|
|
|
|
|
|
|
billable => $args->{billable}, |
842
|
|
|
|
|
|
|
}, |
843
|
50
|
|
|
|
|
204
|
); |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
sub stop_work { |
847
|
101
|
|
|
101
|
1
|
235
|
my $self = shift; |
848
|
101
|
|
|
|
|
394
|
my $args = {@_}; |
849
|
101
|
|
|
|
|
379
|
my $dbw = $self->dbw; |
850
|
101
|
|
|
|
|
1244
|
my $ref = $dbw->xhashref( |
851
|
|
|
|
|
|
|
select => '*', |
852
|
|
|
|
|
|
|
from => 'work_buffers', |
853
|
|
|
|
|
|
|
where => { stop => undef }, |
854
|
|
|
|
|
|
|
); |
855
|
|
|
|
|
|
|
|
856
|
101
|
50
|
66
|
|
|
40557
|
$self->work_buffer($ref) if $ref and $args->{save}; |
857
|
|
|
|
|
|
|
|
858
|
101
|
100
|
|
|
|
394
|
if ($ref) { |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# We are currently working something so we need to check if the |
861
|
|
|
|
|
|
|
# start time is yesterday (for some kind of yesterday) and |
862
|
|
|
|
|
|
|
# insert (multiple) work buffers that don't cross the midnight |
863
|
|
|
|
|
|
|
# boundary. |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
# The trick is that the calculation has to be done in the |
866
|
|
|
|
|
|
|
# timezone of the $ref work buffer. The code below is probably |
867
|
|
|
|
|
|
|
# broken if the current timezone offste is different to |
868
|
|
|
|
|
|
|
# $ref->{offset}. |
869
|
|
|
|
|
|
|
|
870
|
50
|
|
|
|
|
642
|
state $have_time_piece = require Time::Piece; |
871
|
50
|
|
|
|
|
736
|
state $have_time_seconds = require Time::Seconds; |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
my $stop_ymd = |
874
|
50
|
|
|
|
|
767
|
Time::Piece->gmtime( $args->{stop} + $ref->{offset} )->ymd; |
875
|
|
|
|
|
|
|
my $boundary = |
876
|
|
|
|
|
|
|
Time::Piece->strptime( |
877
|
50
|
|
|
|
|
7670
|
Time::Piece->gmtime( $ref->{start} + $ref->{offset} )->ymd, |
878
|
|
|
|
|
|
|
'%Y-%m-%d' ) + |
879
|
|
|
|
|
|
|
Time::Seconds->ONE_DAY - 1; |
880
|
|
|
|
|
|
|
|
881
|
50
|
|
|
|
|
11150
|
until ( $boundary->ymd eq $stop_ymd ) { |
882
|
|
|
|
|
|
|
$dbw->xdo( |
883
|
|
|
|
|
|
|
update => 'work_buffers', |
884
|
|
|
|
|
|
|
set => { stop => $boundary->epoch - $ref->{offset} }, |
885
|
0
|
|
|
|
|
0
|
where => { stop => undef }, |
886
|
|
|
|
|
|
|
); |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
$self->dbw->xdo( |
889
|
|
|
|
|
|
|
insert_into => 'work_buffers', |
890
|
|
|
|
|
|
|
values => { |
891
|
|
|
|
|
|
|
node_id => $ref->{node_id}, |
892
|
|
|
|
|
|
|
start => ( $boundary - $ref->{offset} + 1 )->epoch, |
893
|
|
|
|
|
|
|
start_comment => $ref->{start_comment}, |
894
|
|
|
|
|
|
|
stop => undef, |
895
|
|
|
|
|
|
|
stop_comment => $ref->{stop_comment}, |
896
|
|
|
|
|
|
|
billable => $ref->{billable}, |
897
|
|
|
|
|
|
|
}, |
898
|
0
|
|
|
|
|
0
|
); |
899
|
|
|
|
|
|
|
|
900
|
0
|
|
|
|
|
0
|
$boundary = $boundary + Time::Seconds->ONE_DAY; |
901
|
|
|
|
|
|
|
} |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
$dbw->xdo( |
905
|
|
|
|
|
|
|
update => 'work_buffers', |
906
|
|
|
|
|
|
|
set => { |
907
|
|
|
|
|
|
|
stop => $args->{stop}, |
908
|
|
|
|
|
|
|
stop_comment => $args->{stop_comment}, |
909
|
|
|
|
|
|
|
}, |
910
|
101
|
|
|
|
|
1618
|
where => { stop => undef }, |
911
|
|
|
|
|
|
|
); |
912
|
|
|
|
|
|
|
|
913
|
101
|
50
|
66
|
|
|
38819
|
if ( $args->{restore} and my $saved = $self->work_buffer ) { |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
$self->start_work( |
916
|
|
|
|
|
|
|
node_id => $saved->{node_id}, |
917
|
|
|
|
|
|
|
offset => $saved->{offset}, |
918
|
|
|
|
|
|
|
start => $args->{stop}, |
919
|
|
|
|
|
|
|
start_comment => $saved->{start_comment}, |
920
|
|
|
|
|
|
|
billable => $saved->{billable}, |
921
|
0
|
|
|
|
|
0
|
); |
922
|
|
|
|
|
|
|
|
923
|
0
|
|
|
|
|
0
|
$self->work_buffer(undef); |
924
|
|
|
|
|
|
|
} |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
sub save_work { |
928
|
50
|
|
|
50
|
0
|
116
|
my $self = shift; |
929
|
50
|
|
|
|
|
169
|
my $args = {@_}; |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
$self->dbw->xdo( |
932
|
|
|
|
|
|
|
insert_into => [ |
933
|
|
|
|
|
|
|
'func_new_work', qw/change_id node_id offset start stop |
934
|
|
|
|
|
|
|
start_comment stop_comment/ |
935
|
|
|
|
|
|
|
], |
936
|
|
|
|
|
|
|
select => [ |
937
|
|
|
|
|
|
|
$args->{change_id}, $args->{node_id}, |
938
|
|
|
|
|
|
|
'wb.offset', 'wb.start', |
939
|
|
|
|
|
|
|
'wb.stop', 'wb.start_comment', |
940
|
|
|
|
|
|
|
'wb.stop_comment', |
941
|
|
|
|
|
|
|
], |
942
|
|
|
|
|
|
|
from => 'work_buffers wb', |
943
|
|
|
|
|
|
|
where => { |
944
|
|
|
|
|
|
|
'wb.node_id' => $args->{node_id}, |
945
|
50
|
|
|
|
|
211
|
'wb.billable' => 1, |
946
|
|
|
|
|
|
|
'wb.stop !' => undef, |
947
|
|
|
|
|
|
|
}, |
948
|
|
|
|
|
|
|
); |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
$self->dbw->xdo( |
951
|
|
|
|
|
|
|
delete_from => 'work_buffers', |
952
|
|
|
|
|
|
|
where => { |
953
|
|
|
|
|
|
|
'node_id' => $args->{node_id}, |
954
|
50
|
|
|
|
|
64359
|
'billable' => 1, |
955
|
|
|
|
|
|
|
'stop !' => undef, |
956
|
|
|
|
|
|
|
} |
957
|
|
|
|
|
|
|
); |
958
|
|
|
|
|
|
|
} |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
sub new_change { |
961
|
51
|
|
|
51
|
1
|
1234
|
my $self = shift; |
962
|
51
|
|
|
|
|
273
|
my %vals = @_; |
963
|
51
|
|
|
|
|
240
|
my $dbw = $self->dbw; |
964
|
|
|
|
|
|
|
|
965
|
51
|
|
33
|
|
|
539
|
$vals{id} ||= $dbw->nextval('changes'); |
966
|
51
|
|
|
|
|
13460
|
my ( $author, $author_contact, $author_contact_method, $author_shortname ) |
967
|
|
|
|
|
|
|
= $dbw->xlist( |
968
|
|
|
|
|
|
|
select => [qw/e.name ecm.mvalue ecm.method i.shortname/], |
969
|
|
|
|
|
|
|
from => 'bifkv b', |
970
|
|
|
|
|
|
|
inner_join => 'entities e', |
971
|
|
|
|
|
|
|
on => 'e.id = b.identity_id', |
972
|
|
|
|
|
|
|
inner_join => 'identities i', |
973
|
|
|
|
|
|
|
on => 'i.id = b.identity_id', |
974
|
|
|
|
|
|
|
inner_join => 'entity_contact_methods ecm', |
975
|
|
|
|
|
|
|
on => 'ecm.id = e.default_contact_method_id', |
976
|
|
|
|
|
|
|
where => { key => 'self' }, |
977
|
|
|
|
|
|
|
); |
978
|
51
|
|
66
|
|
|
45972
|
$vals{author} //= $author; |
979
|
51
|
|
66
|
|
|
440
|
$vals{author_contact} //= $author_contact; |
980
|
51
|
|
66
|
|
|
195
|
$vals{author_contact_method} //= $author_contact_method; |
981
|
51
|
|
66
|
|
|
326
|
$vals{author_shortname} //= $author_shortname; |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
return $self->err( 'NoSelfIdentity', |
984
|
|
|
|
|
|
|
'no "self" identity defined at change begin' ) |
985
|
51
|
100
|
|
|
|
200
|
unless $vals{author}; |
986
|
|
|
|
|
|
|
|
987
|
50
|
|
|
|
|
276
|
$dbw->xdo( |
988
|
|
|
|
|
|
|
insert_into => 'func_begin_change', |
989
|
|
|
|
|
|
|
values => \%vals, |
990
|
|
|
|
|
|
|
); |
991
|
|
|
|
|
|
|
|
992
|
50
|
|
|
|
|
61220
|
return $vals{id}; |
993
|
|
|
|
|
|
|
} |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
sub check { |
996
|
50
|
|
|
50
|
1
|
118
|
my $self = shift; |
997
|
50
|
|
|
|
|
1169
|
my $id = shift; |
998
|
50
|
|
33
|
|
|
232
|
my $db = shift || $self->db; |
999
|
|
|
|
|
|
|
|
1000
|
50
|
|
|
|
|
27199
|
state $have_changeset = require Bif::DB::Plugin::ChangeUUIDv1; |
1001
|
50
|
|
|
|
|
295924
|
state $have_yaml = require YAML::Tiny; |
1002
|
50
|
|
|
|
|
259208
|
state $have_encode = require Encode; |
1003
|
50
|
|
|
|
|
252
|
state $have_digest = require Digest::SHA; |
1004
|
|
|
|
|
|
|
|
1005
|
50
|
|
33
|
|
|
779
|
my $changeset = |
1006
|
|
|
|
|
|
|
$db->uchangeset_v1($id) || Carp::croak "invalid change.id: $id"; |
1007
|
|
|
|
|
|
|
|
1008
|
50
|
|
|
|
|
138
|
my $begin = shift @$changeset; |
1009
|
50
|
|
|
|
|
103
|
my $end = pop @$changeset; |
1010
|
50
|
|
|
|
|
151
|
my $uuid = delete $end->{uuid}; |
1011
|
50
|
|
|
|
|
195
|
my $short = substr( $uuid, 0, 8 ); |
1012
|
|
|
|
|
|
|
|
1013
|
50
|
|
|
|
|
157
|
foreach my $x (@$changeset) { |
1014
|
|
|
|
|
|
|
next |
1015
|
|
|
|
|
|
|
unless ref $x eq 'HASH' |
1016
|
|
|
|
|
|
|
&& exists $x->{_delta} |
1017
|
200
|
100
|
33
|
|
|
1567
|
&& $x->{_delta} =~ m/^new_/; |
|
|
|
66
|
|
|
|
|
1018
|
|
|
|
|
|
|
|
1019
|
150
|
|
|
|
|
262
|
delete $x->{uuid}; |
1020
|
|
|
|
|
|
|
} |
1021
|
|
|
|
|
|
|
|
1022
|
50
|
|
|
|
|
361
|
my $yaml = YAML::Tiny::Dump( [ $begin, @$changeset, $end ] ); |
1023
|
50
|
|
|
|
|
66101
|
my $sha1 = Digest::SHA::sha1_hex( Encode::encode( 'UTF-8', $yaml ) ); |
1024
|
|
|
|
|
|
|
|
1025
|
50
|
|
|
|
|
12506
|
my $action = $db->xval( |
1026
|
|
|
|
|
|
|
select => ['c.action'], |
1027
|
|
|
|
|
|
|
from => 'changes c', |
1028
|
|
|
|
|
|
|
where => { 'c.id' => $id }, |
1029
|
|
|
|
|
|
|
); |
1030
|
|
|
|
|
|
|
|
1031
|
50
|
|
|
|
|
18791
|
my ( $red, $reset ) = $self->colours( 'red', 'reset' ); |
1032
|
50
|
50
|
|
|
|
1268
|
return ( 1, "[change: $id <$short>] $action" ) if $uuid eq $sha1; |
1033
|
0
|
|
|
|
|
0
|
return ( 0, "[change: $id <$short>] $action ${red}INVALID$reset" ); |
1034
|
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
sub end_change { |
1037
|
50
|
|
|
50
|
0
|
133
|
my $self = shift; |
1038
|
50
|
|
|
|
|
1089
|
my $dbw = $self->dbw; |
1039
|
50
|
|
|
|
|
338
|
my %args = @_; |
1040
|
|
|
|
|
|
|
|
1041
|
50
|
|
|
|
|
3492
|
my $iid = $dbw->xval( |
1042
|
|
|
|
|
|
|
select => [ 'bif.identity_id', ], |
1043
|
|
|
|
|
|
|
from => 'bifkv bif', |
1044
|
|
|
|
|
|
|
where => { 'bif.key' => 'self' }, |
1045
|
|
|
|
|
|
|
); |
1046
|
|
|
|
|
|
|
|
1047
|
50
|
50
|
|
|
|
16275
|
return $self->err( 'NoSelfIdentity', |
1048
|
|
|
|
|
|
|
'no "self" identity defined at change end' ) |
1049
|
|
|
|
|
|
|
unless $iid; |
1050
|
|
|
|
|
|
|
|
1051
|
50
|
|
|
|
|
436
|
$dbw->xdo( |
1052
|
|
|
|
|
|
|
insert_into => 'func_end_change', |
1053
|
|
|
|
|
|
|
values => { |
1054
|
|
|
|
|
|
|
identity_id => $iid, |
1055
|
|
|
|
|
|
|
%args, |
1056
|
|
|
|
|
|
|
}, |
1057
|
|
|
|
|
|
|
); |
1058
|
|
|
|
|
|
|
|
1059
|
50
|
|
|
|
|
42430
|
$dbw->xdo( |
1060
|
|
|
|
|
|
|
insert_into => 'func_merge_changes', |
1061
|
|
|
|
|
|
|
values => { merge => 1 }, |
1062
|
|
|
|
|
|
|
); |
1063
|
|
|
|
|
|
|
|
1064
|
50
|
|
|
|
|
340424
|
my $change_id = $dbw->xval( select => 'currval("changes")' ); |
1065
|
50
|
|
|
|
|
21202
|
my ( $ok, $str ) = $self->check( $change_id, $dbw ); |
1066
|
50
|
50
|
|
|
|
66781
|
return print $str. "\n" if $ok; |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
# Show the diff to see what's wrong |
1069
|
0
|
|
|
|
|
0
|
$self->new_cmd( |
1070
|
|
|
|
|
|
|
'App::bif::show::change', |
1071
|
|
|
|
|
|
|
db => $self->dbw, # to make current txn visible |
1072
|
|
|
|
|
|
|
opts => { |
1073
|
|
|
|
|
|
|
uid => 'c' . $change_id, |
1074
|
|
|
|
|
|
|
diff => 1, |
1075
|
|
|
|
|
|
|
} |
1076
|
|
|
|
|
|
|
)->run; |
1077
|
|
|
|
|
|
|
|
1078
|
0
|
|
|
|
|
0
|
my $keep_invalid = $dbw->xval( |
1079
|
|
|
|
|
|
|
select => 'bool_val', |
1080
|
|
|
|
|
|
|
from => 'bifkv', |
1081
|
|
|
|
|
|
|
where => { key => 'keep_invalid' }, |
1082
|
|
|
|
|
|
|
); |
1083
|
0
|
0
|
|
|
|
0
|
return $self->err( 'InvalidUUID', $str ) unless $keep_invalid; |
1084
|
0
|
|
|
|
|
0
|
return print $str; |
1085
|
|
|
|
|
|
|
} |
1086
|
|
|
|
|
|
|
|
1087
|
|
|
|
|
|
|
sub DESTROY { |
1088
|
240
|
|
|
240
|
|
35367
|
my $self = shift; |
1089
|
|
|
|
|
|
|
Log::Any::Adapter->remove( $self->{_bif_log_any_adapter} ) |
1090
|
240
|
50
|
|
|
|
7047
|
if $self->{_bif_log_any_adapter}; |
1091
|
|
|
|
|
|
|
} |
1092
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
package Bif::OK; |
1094
|
|
|
|
|
|
|
use overload |
1095
|
48
|
|
|
48
|
|
352
|
bool => sub { 1 }, |
1096
|
55
|
|
|
|
|
729
|
'""' => \&as_string, |
1097
|
55
|
|
|
55
|
|
189888
|
fallback => 1; |
|
55
|
|
|
|
|
97
|
|
1098
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
sub new { |
1100
|
157
|
|
|
157
|
|
4389
|
my $proto = shift; |
1101
|
157
|
|
|
|
|
275
|
my $opts = shift; |
1102
|
157
|
|
33
|
|
|
656
|
$opts->{_bif_ok_type} = shift || Carp::confess('missing type'); |
1103
|
157
|
|
100
|
|
|
903
|
$opts->{_bif_ok_msg} = shift || ''; |
1104
|
157
|
100
|
|
|
|
501
|
$opts->{_bif_ok_msg} = sprintf( $opts->{_bif_ok_msg}, @_ ) if @_; |
1105
|
|
|
|
|
|
|
|
1106
|
157
|
|
|
|
|
528
|
my $class = $proto . '::' . $opts->{_bif_ok_type}; |
1107
|
|
|
|
|
|
|
{ |
1108
|
55
|
|
|
55
|
|
9139
|
no strict 'refs'; |
|
55
|
|
|
|
|
103
|
|
|
55
|
|
|
|
|
8903
|
|
|
157
|
|
|
|
|
256
|
|
1109
|
157
|
|
|
|
|
358
|
*{ $class . '::ISA' } = [$proto]; |
|
157
|
|
|
|
|
2687
|
|
1110
|
|
|
|
|
|
|
} |
1111
|
|
|
|
|
|
|
|
1112
|
157
|
|
|
|
|
5088
|
return bless {%$opts}, $class; |
1113
|
|
|
|
|
|
|
} |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
sub as_string { |
1116
|
8
|
|
|
8
|
|
3566
|
my $self = shift; |
1117
|
|
|
|
|
|
|
return $self->{_bif_ok_msg} |
1118
|
8
|
100
|
66
|
|
|
96
|
if $self->{_bif_ok_msg} && !ref $self->{_bif_ok_msg}; |
1119
|
3
|
|
|
|
|
39
|
return ref $self; |
1120
|
|
|
|
|
|
|
} |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
package Bif::Error; |
1123
|
|
|
|
|
|
|
use overload |
1124
|
77
|
|
|
77
|
|
7327
|
bool => sub { 1 }, |
1125
|
55
|
|
|
55
|
|
290
|
fallback => 1; |
|
55
|
|
|
|
|
102
|
|
|
55
|
|
|
|
|
348
|
|
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
our @ISA = ('Bif::OK'); |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
1; |
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
__END__ |