File Coverage

blib/lib/App/bif.pm
Criterion Covered Total %
statement 252 462 54.5
branch 47 166 28.3
condition 37 98 37.7
subroutine 50 65 76.9
pod 26 35 74.2
total 412 826 49.8


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__