File Coverage

blib/lib/App/bif.pm
Criterion Covered Total %
statement 252 461 54.6
branch 47 166 28.3
condition 37 96 38.5
subroutine 50 65 76.9
pod 26 35 74.2
total 412 823 50.0


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__