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