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

package App::bif;
use strict;
use warnings;
use feature 'state';
use utf8;    # for render_table
use Bif::Mo;
use Carp ();
use Config::Tiny;
use File::HomeDir;
use Log::Any qw/$log/;
use Path::Tiny qw/path rootdir cwd/;

our $VERSION = '0.1.5_6';
our $pager;

sub DBVERSION { 1 }
sub MSWin32   { $^O eq 'MSWin32' }

has debug => ( is => 'rw', );

has db => (
    is      => 'ro',
    default => \&_build_db,
);

has dbw => (
    is      => 'rw',           # for bif-new-repo?
    default => \&_build_dbw,
);

has _colours => (
    is      => 'ro',
    default => {},
);

has config => (
    is      => 'ro',
    default => {},
);

has no_pager => (
    is      => 'rw',
    default => sub {
        my $self = shift;
        return ( !-t STDOUT ) || $self->opts->{no_pager};
    },
);

has now => (
    is      => 'ro',
    default => sub { time },
);

has opts => (
    is       => 'ro',
    required => 1,
);

has repo => (
    is      => 'rw',            # needed by init
    default => \&_build_repo,
);

has term_width => (
    is      => 'ro',
    default => sub {
        my $width;
        if (MSWin32) {
            require Term::Size::Win32;
            $width = ( Term::Size::Win32::chars(*STDOUT) )[0] || 80;
        }
        else {
            require Term::Size::Perl;
            $width = ( Term::Size::Perl::chars(*STDOUT) )[0] || 80;
        }
        $log->debugf( 'bif: terminal width %d', $width );
        return $width;
    },
);

has term_height => (
    is      => 'ro',
    default => sub {
        my $height;
        if (MSWin32) {
            require Term::Size::Win32;
            $height = ( Term::Size::Win32::chars(*STDOUT) )[1] || 40;
        }
        else {
            require Term::Size::Perl;
            $height = ( Term::Size::Perl::chars(*STDOUT) )[1] || 40;
        }
        $log->debugf( 'bif: terminal height %d', $height );
        return $height;
    },
);

has user_repo => (
    is      => 'ro',
    default => \&_build_user_repo,
);

has user_db => (
    is      => 'ro',
    default => \&_build_user_db,
);

has user_dbw => (
    is      => 'ro',
    default => \&_build_user_dbw,
);

has work_buffer => ( is => 'rw', );

sub BUILD {
    my $self = shift;
    my $opts = $self->opts;

    # For Term::ANSIColor
    $ENV{ANSI_COLORS_DISABLED} //= $opts->{no_color} || !-t STDOUT;

    binmode STDIN,  ':encoding(utf8)';
    binmode STDOUT, ':encoding(utf8)';

    if ( $self->debug( $self->debug // $opts->{debug} ) ) {
        require Log::Any::Adapter;
        if ( exists $INC{'Test/More.pm'} ) {

            # Log::Any::Adapter::Diag can be found in t/lib/
            Log::Any::Adapter->set('Diag');
        }
        else {
            Log::Any::Adapter->set('+App::bif::LAA');
        }
        $self->start_pager();
    }

    $log->infof( 'bif: %s %s', ref $self, $opts );

    return;
}

sub _build_user_repo {
    my $self = shift;
    my $repo = path( File::HomeDir->my_home, '.bifu' )->absolute;

    $self->err( 'UserRepoNotFound',
        'user repository not found (try "bif init -u -i")' )
      unless -d $repo;

    $log->debug( 'bif: user_repo: ' . $repo );

    my $file = $repo->child('config');
    return $repo unless $file->exists;

    my $config = $self->config;
    my $conf = Config::Tiny->read( $file, 'utf8' )
      || return $self->err( 'ConfigNotFound',
        $file . ' ' . Config::Tiny->errstr );

    # Merge in the repo config with the current context (user) config
    while ( my ( $k1, $v1 ) = each %$conf ) {
        if ( ref $v1 eq 'HASH' ) {
            while ( my ( $k2, $v2 ) = each %$v1 ) {
                if ( $k1 eq '_' ) {
                    $config->{$k2} = $v2;
                }
                else {
                    $config->{$k1}->{$k2} = $v2;
                }
            }
        }
        else {
            $config->{$k1} = $v1;
        }
    }

    return $repo;
}

sub _build_repo {
    my $self = shift;
    $self->user_repo;    # build user repo first

    my $repo = $self->find_repo('.bif')
      || $self->err( 'RepoNotFound', 'directory not found: .bif' );

    $log->debug( 'bif: repo: ' . $repo );

    my $file = $repo->child('config');
    return $repo unless $file->exists;

    $log->debug( 'bif: repo_conf: ' . $file );

    # Trigger user config
    $self->user_repo;

    my $config = $self->config;
    my $conf = Config::Tiny->read( $file, 'utf8' )
      || return $self->err( 'ConfigNotFound',
        $file . ' ' . Config::Tiny->errstr );

    # Merge in the repo config with the current context (user) config
    while ( my ( $k1, $v1 ) = each %$conf ) {
        if ( ref $v1 eq 'HASH' ) {
            while ( my ( $k2, $v2 ) = each %$v1 ) {
                if ( $k1 eq '_' ) {
                    $config->{$k2} = $v2;
                }
                else {
                    $config->{$k1}->{$k2} = $v2;
                }
            }
        }
        else {
            $config->{$k1} = $v1;
        }
    }

    return $repo;
}

sub dbfile {
    my $self    = shift;
    my $version = shift;
    return sprintf( 'db-v%d.sqlite3', $version );
}

sub _build_user_db {
    my $self = shift;
    my $file = $self->user_repo->child( $self->dbfile( $self->DBVERSION ) );

    return $self->err( 'DBNotFound', 'database not found: %s', $file )
      unless -f $file;

    my $dsn = 'dbi:SQLite:dbname=' . $file;

    require Bif::DB;
    my $db = Bif::DB->connect( $dsn, undef, undef, undef, $self->debug );

    $log->debug( 'bif: user_db: ' . $dsn );
    $log->debug( 'bif: SQLite version: ' . $db->{sqlite_version} );

    return $db;
}

sub _build_user_dbw {
    my $self = shift;
    my $file = $self->user_repo->child( $self->dbfile( $self->DBVERSION ) );

    return $self->err( 'DBNotFound', 'database not found: %s', $file )
      unless -f $file;

    my $dsn = 'dbi:SQLite:dbname=' . $file;

    require Bif::DBW;
    my $dbw = Bif::DBW->connect( $dsn, undef, undef, undef, $self->debug );

    $log->debug( 'bif: user_dbw: ' . $dsn );
    $log->debug( 'bif: SQLite version: ' . $dbw->{sqlite_version} );

    return $dbw;
}

sub _build_db {
    my $self = shift;
    my $file = $self->repo->child( $self->dbfile( $self->DBVERSION ) );

    return $self->err( 'DBNotFound', 'database not found: %s', $file )
      unless -f $file;

    my $dsn = 'dbi:SQLite:dbname=' . $file;

    require Bif::DB;
    my $db = Bif::DB->connect( $dsn, undef, undef, undef, $self->debug );

    $log->debug( 'bif: db: ' . $dsn );
    $log->debug( 'bif: SQLite version: ' . $db->{sqlite_version} );

    return $db;
}

sub _build_dbw {
    my $self = shift;
    my $file = $self->repo->child( $self->dbfile( $self->DBVERSION ) );

    return $self->err( 'DBNotFound', 'database not found: %s', $file )
      unless -f $file;

    my $dsn = 'dbi:SQLite:dbname=' . $file;

    require Bif::DBW;
    my $dbw = Bif::DBW->connect( $dsn, undef, undef, undef, $self->debug );

    $log->debug( 'bif: dbw: ' . $dsn );
    $log->debug( 'bif: SQLite version: ' . $dbw->{sqlite_version} );

    return $dbw;
}

### class methods ###

sub new_cmd {
    my $self  = shift;
    my $class = shift;

    Carp::croak($@) unless eval "require $class;";

    return $class->new( %$self, @_ );
}

sub dispatch {
    my $self  = shift;
    my $class = shift;

    Carp::croak($@) unless eval "require $class;";

    return $class->new( %$self, @_ )->run;
}

# Run user defined aliases
sub run {
    my $self  = shift;
    my $opts  = $self->opts;
    my @cmd   = @{ $opts->{alias} };
    my $alias = shift @cmd;

    use File::HomeDir;
    use Path::Tiny;

    my $repo = path( File::HomeDir->my_home, '.bifu' );
    die usage(qq{unknown COMMAND or ALIAS "$alias"}) unless -d $repo;

    # Trigger user config
    $self->user_repo;
    my $str = $self->config->{'user.alias'}->{$alias}
      or die usage(qq{unknown COMMAND or ALIAS "$alias"});

    # Make sure these options are correctly passed through (or not)
    delete $opts->{alias};
    $opts->{debug}     = undef if exists $opts->{debug};
    $opts->{no_pager}  = undef if exists $opts->{no_pager};
    $opts->{no_color}  = undef if exists $opts->{no_color};
    $opts->{user_repo} = undef if exists $opts->{user_repo};

    unshift( @cmd, split( ' ', $str ) );

    use OptArgs qw/class_optargs/;
    my ( $class, $newopts ) = OptArgs::class_optargs( 'App::bif', $opts, @cmd );

    return $class->new(
        opts      => $newopts,
        user_repo => $self->user_repo,
    )->run;
}

sub find_repo {
    my $self = shift;
    my $name = shift;

    return $self->user_repo if $self->opts->{user_repo};

    my $try = cwd;

    while (1) {
        if ( -d ( my $repo = $try->child($name) ) ) {
            return $repo;
        }
        elsif ( -f $repo ) {    # inside a repo directory
            return $try;
        }
        last if $try->is_rootdir;
        $try = $try->parent;
    }

    return;
}

sub colours {
    my $self = shift;
    state $have_term_ansicolor = require Term::ANSIColor;

    return map { '' } @_ if $self->opts->{no_color};

    my $ref = $self->_colours;
    map { $ref->{$_} //= Term::ANSIColor::color($_) } @_;
    return map { $ref->{$_} } @_ if wantarray;
    return $ref->{ $_[0] };
}

sub header {
    my $self = shift;
    state $reset = $self->colours(qw/reset/);
    state $dark  = $self->colours(qw/dark/);

    my ( $key, $val, $val2 ) = @_;
    return [
        ( $key ? $key . ':' : '' ) . $reset,
        $val . ( defined $val2 ? $dark . ' <' . $val2 . '>' : '' ) . $reset
    ];
}

sub s2hms {
    my $self = shift;
    my $s    = shift;

    return sprintf(
        '%+0.2d:%0.2d:%0.2d',
        int( $s / 3600 ),
        int( ( $s - 3600 * int( $s / 3600 ) ) / 60 ),
        $s % 60
    );
}

sub s2hm {
    my $self = shift;
    my $s    = shift;

    return sprintf( '%+0.2d:%0.2d',
        int( $s / 3600 ),
        int( $s - 3600 * int( $s / 3600 ) ) / 60 );
}

sub datetime2s {
    my $self   = shift;
    my $dt     = shift;
    my $new_dt = $dt;

    if ( $dt =~ m/^(\d?\d):(\d{2})$/ ) {
        my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
          localtime(time);

        $new_dt = sprintf(
            '%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d',
            $year + 1900,
            $mon + 1, $mday, $1, $2, 0
        );
    }
    elsif ( $dt =~ m/^(\d{2}):(\d{2}):(\d{2})$/ ) {
        my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
          localtime(time);

        $new_dt = sprintf(
            '%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d',
            $year + 1900,
            $mon + 1, $mday, $1, $2, $3
        );
    }
    elsif ( $dt =~ m/^yesterday (\d?\d):(\d{2})$/ ) {
        my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
          localtime( time - 24 * 60 * 60 );

        $new_dt = sprintf(
            '%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d',
            $year + 1900,
            $mon + 1, $mday, $1, $2, 0
        );
    }
    elsif ( $dt =~ m/^yesterday (\d?\d):(\d{2}):(\d{2})$/ ) {
        my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
          localtime( time - 24 * 60 * 60 );

        $new_dt = sprintf(
            '%0.4d-%0.2d-%0.2d %0.2d:%0.2d:%0.2d',
            $year + 1900,
            $mon + 1, $mday, $1, $2, $3
        );
    }
    elsif ( $dt =~ m/^(\d{4})-(\d{2})-(\d{2})$/ ) {
        $new_dt .= $dt . ' 00:00:00';
    }
    elsif ( $dt =~ m/^(\d{4})-(\d{2})-(\d{2}) (\d?\d):(\d{2})$/ ) {
        $new_dt = $dt . ':00';
    }

    $log->debugf( 'datetime2s "%s" -> "%s"', $dt, $new_dt );
    if ( $new_dt =~ m/^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2})$/ ) {
        require Time::Local;
        return Time::Local::timelocal( $6, $5, $4, $3, $2 - 1, $1 - 1900 );
    }

    return $self->err( 'InvalidDateTime', 'invalid date/time string: %s', $dt );
}

sub ctime_ago {
    my $self = shift;
    my $row  = shift;

    state $have_time_piece    = require Time::Piece;
    state $have_time_duration = require Time::Duration;

    use locale;

    return (
        Time::Duration::ago( $row->{ctime_age}, 1 ),
        Time::Piece->strptime( $row->{ctime} + $row->{ctimetz}, '%s' )
          ->strftime('%a %Y-%m-%d %H:%M ') . $row->{ctimetzhm}
    );
}

sub mtime_ago {
    my $self = shift;
    my $row  = shift;

    state $have_time_piece    = require Time::Piece;
    state $have_time_duration = require Time::Duration;

    use locale;

    return (
        Time::Duration::ago( $row->{mtime_age}, 1 ),
        Time::Piece->strptime( $row->{mtime} + $row->{mtimetz}, '%s' )
          ->strftime('%a %Y-%m-%d %H:%M ') . $row->{mtimetzhm}
    );
}

sub err {
    my $self = shift;
    Carp::croak('err($type, $msg, [$arg])') unless @_ >= 2;
    my $err = shift;
    my $msg = shift;

    die $msg if eval { $msg->isa('Bif::Error') };
    my ( $red, $reset ) = $self->colours(qw/red reset/);

    $msg = $red . 'error:' . $reset . ' ' . $msg . "\n";

    die Bif::Error->new( $self->opts, $err, $msg, @_ );
}

sub ok {
    my $self = shift;
    Carp::croak('ok($type, [$arg])') unless @_;
    my $ok = shift;
    return Bif::OK->new( $self->opts, $ok, @_ );
}

sub start_pager {
    my $self  = shift;
    my $lines = shift;

    return if $pager or $self->no_pager;

    if ($lines) {
        my $term_height = $self->term_height;
        if ( $lines <= $term_height ) {
            $log->debug("bif: no start_pager ($lines <= $term_height)");
            return;
        }
    }

    local $ENV{'LESS'} = '-FXeR';
    local $ENV{'MORE'} = '-FXer' unless MSWin32;

    require App::bif::Pager;
    $pager = App::bif::Pager->new;

    $log->debugf( 'bif: start_pager (fileno: %d)', fileno( $pager->fh ) );

    return $pager;
}

sub end_pager {
    my $self = shift;
    return unless $pager;

    $log->debug('bif: end_pager');
    $pager = undef;
    return;
}

sub user_id {
    my $self = shift;
    my $id   = $self->db->xval(
        select => 'bif.identity_id',
        from   => 'bifkv bif',
        where  => { 'bif.key' => 'self' },
    );
    return $id;
}

sub uuid2id {
    my $self = shift;
    my $try  = shift // Carp::confess 'uuid2id needs defined';
    my $opts = $self->opts;
    Carp::croak 'usage' if @_;

    return $try unless exists $opts->{uuid} && $opts->{uuid};
    my @list = $self->db->uuid2id($try);

    return $self->err( 'UuidNotFound', "uuid not found: $try" )
      unless @list;

    return $self->err( 'UuidAmbiguous',
        "ambiguious uuid: $try\n    "
          . join( "\n    ", map { "$_->[1] -> ID:$_->[0]" } @list ) )
      if @list > 1;

    return $list[0]->[0];
}

sub get_project {
    my $self = shift;
    my $path = shift // Carp::confess 'path must be defined';
    my $db   = $self->db;

    my @matches = $db->get_projects($path);

    return $self->err( 'ProjectNotFound', "project not found: $path" )
      unless @matches;

    return $matches[0] if 1 == @matches;

    return $self->err( 'AmbiguousPath',
        "ambiguous path \"$path\" matches the following:\n" . '    '
          . join( "\n    ", map { "$_->{path}" } @matches ) );
}

sub get_hub {
    my $self = shift;
    my $name = shift;                       # || Carp::confess 'get_hub($name)';
    my $hub  = $self->db->get_hub($name);

    return $self->err( 'HubNotFound', "hub not found: $name" )
      unless $hub;

    return $hub;
}

sub render_table {
    my $self   = shift;
    my $format = shift;
    my $header = shift;
    my $data   = shift;
    my $indent = shift || 0;

    my ( $white, $dark, $reset ) = $self->colours(qw/yellow dark reset/);
    require Text::FormatTable;

    my $table = Text::FormatTable->new($format);

    if ($header) {
        $header->[0] = $white . $header->[0];
        push( @$header, ( pop @$header ) . $reset );
        $table->head(@$header);
    }

    foreach my $row (@$data) {
        $table->row(@$row);
    }

    my $term_width = $self->term_width;
    return $table->render($term_width) unless $indent;

    my $str = $table->render( $term_width - $indent );

    my $prefix = ' ' x $indent;
    $str =~ s/^/$prefix/gm;
    return $str;
}

sub prompt_edit {
    my $self = shift;
    my %args = (
        opts           => {},
        abort_on_empty => 1,
        val            => '',
        @_,
    );

    $args{txt} //= "\n";
    $args{txt} .= "
# Please enter your message. Lines starting with '#'
# are ignored. Empty content aborts.
#
";

    my $now = time;

    foreach my $key ( sort keys %{ $args{opts} } ) {
        next if $key =~ m/^_/;
        next unless defined $args{opts}->{$key};
        $args{txt} .= "#     $key: $args{opts}->{$key}\n";
    }

    require IO::Prompt::Tiny;
    if ( IO::Prompt::Tiny::_is_interactive() ) {
        require App::bif::Editor;
        $args{val} = App::bif::Editor->new( txt => $args{txt} )->result;
    }

    $args{val} =~ s/^#.*//gm;
    $args{val} =~ s/^\n+//s;
    $args{val} =~ s/\n*$/\n/s;

    if ( $args{abort_on_empty} ) {
        return $self->err( 'EmptyContent', 'aborting due to empty content.' )
          if $args{val} =~ m/^[\s\n]*$/s;
    }

    return $args{val};
}

my $old = '';

sub lprint {
    my $self = shift;
    my $msg  = shift;

    if ( $pager or $self->opts->{debug} ) {
        return print $msg . "\n";
    }

    local $| = 1;

    my $chars = print ' ' x length($old), "\b" x length($old), $msg, "\r";
    $old = $msg =~ m/\n/ ? '' : $msg;
    return $chars;
}

sub get_change {
    my $self            = shift;
    my $token           = shift // Carp::croak('get_change needs defined');
    my $first_change_id = shift;

    return $self->err( 'InvalidChangeID',
        "invalid change ID (must be cID): $token" )
      unless $token =~ m/^c(\d+)$/;

    my $id = $1;
    my $db = $self->db;

    my $data = $db->xhashref(
        select => [ 'c.id AS id', 'c.uuid AS uuid', ],
        from   => 'changes c',
        where => { 'c.id' => $id },
    );

    return $self->err( 'ChangeNotFound', "change not found: $token" )
      unless $data;

    if ($first_change_id) {
        my $t = $db->xhashref(
            select => 1,
            from   => 'changes_tree ct',
            where  => {
                'ct.child'  => $id,
                'ct.parent' => $first_change_id,
            },
        );

        return $self->err( 'FirstChangeMismatch',
            'first change id mismatch: c%d / c%d',
            $first_change_id, $id )
          unless $t;
    }

    return $data;
}

sub get_node {
    my $self = shift;

    my $token = shift // Carp::confess('get_node needs defined');
    my $kind  = shift;
    my $db    = $self->db;

    state $have_qv = DBIx::ThinSQL->import(qw/ qv bv /);

    if ( $token =~ m/^\d+$/ ) {
        my $data = $db->xhashref(
            select => [
                'n.id AS id',
                'n.kind AS kind',
                't.tkind AS tkind',
                'n.uuid AS uuid',
                'n.first_change_id AS first_change_id',
            ],
            from      => 'nodes n',
            left_join => 'topics t',
            on        => 't.id = n.id',
            where     => { 'n.id' => $token },
        );

        return $self->err( 'WrongKind', 'node (%s) is not a %s: %d',
            $data->{kind}, $kind, $token )
          if $data && $kind && $kind ne $data->{kind};

        return $data if $data;
    }

    my $pinfo = eval { $self->get_project($token) };
    die $@ if ( $@ && $@->isa('Bif::Error::AmbiguousPath') );
    return $pinfo if $pinfo;

    $kind ||= 'node';
    return $self->err( 'TopicNotFound', "$kind not found: $token" );
}

sub current_work {
    my $self = shift;
    return $self->dbw->xhashref(
        select => [
            'n.id AS node_id',
            'n.kind AS kind',
            'n.path AS path',
            'wb.start AS start',
            'wb.billable AS billable',
            'COALESCE(t.title,"") AS title',
        ],
        from       => 'work_buffers wb',
        inner_join => 'nodes n',
        on         => 'n.id = wb.node_id',
        left_join  => 'topics t',
        on         => 't.id = n.id',
        where      => { 'wb.stop' => undef },
    );
}

sub start_work {
    my $self = shift;
    my $args = {@_};
    my $dbw  = $self->dbw;

    if ( $args->{save} ) {
        my $ref = $dbw->xhashref(
            select => '*',
            from   => 'work_buffers',
            where  => { stop => undef },
        );

        if ($ref) {
            $self->stop_work( stop => $args->{start} );
            $self->work_buffer($ref);
        }
    }

    return $self->dbw->xdo(
        insert_into => 'work_buffers',
        values      => {
            node_id       => $args->{node_id},
            start         => $args->{start},
            start_comment => $args->{start_comment},
            stop          => $args->{stop},
            stop_comment  => $args->{stop_comment},
            billable      => $args->{billable},
        },
    );
}

sub stop_work {
    my $self = shift;
    my $args = {@_};
    my $dbw  = $self->dbw;
    my $ref  = $dbw->xhashref(
        select => '*',
        from   => 'work_buffers',
        where  => { stop => undef },
    );

    $self->work_buffer($ref) if $ref and $args->{save};

    if ($ref) {

        # We are currently working something so we need to check if the
        # start time is yesterday (for some kind of yesterday) and
        # insert (multiple) work buffers that don't cross the midnight
        # boundary.

        # The trick is that the calculation has to be done in the
        # timezone of the $ref work buffer. The code below is probably
        # broken if the current timezone offste is different to
        # $ref->{offset}.

        state $have_time_piece   = require Time::Piece;
        state $have_time_seconds = require Time::Seconds;

        my $stop_ymd =
          Time::Piece->gmtime( $args->{stop} + $ref->{offset} )->ymd;
        my $boundary =
          Time::Piece->strptime(
            Time::Piece->gmtime( $ref->{start} + $ref->{offset} )->ymd,
            '%Y-%m-%d' ) +
          Time::Seconds->ONE_DAY - 1;

        until ( $boundary->ymd eq $stop_ymd ) {
            $dbw->xdo(
                update => 'work_buffers',
                set    => { stop => $boundary->epoch - $ref->{offset} },
                where  => { stop => undef },
            );

            $self->dbw->xdo(
                insert_into => 'work_buffers',
                values      => {
                    node_id       => $ref->{node_id},
                    start         => ( $boundary - $ref->{offset} + 1 )->epoch,
                    start_comment => $ref->{start_comment},
                    stop          => undef,
                    stop_comment  => $ref->{stop_comment},
                    billable      => $ref->{billable},
                },
            );

            $boundary = $boundary + Time::Seconds->ONE_DAY;
        }
    }

    $dbw->xdo(
        update => 'work_buffers',
        set    => {
            stop         => $args->{stop},
            stop_comment => $args->{stop_comment},
        },
        where => { stop => undef },
    );

    if ( $args->{restore} and my $saved = $self->work_buffer ) {

        $self->start_work(
            node_id       => $saved->{node_id},
            offset        => $saved->{offset},
            start         => $args->{stop},
            start_comment => $saved->{start_comment},
            billable      => $saved->{billable},
        );

        $self->work_buffer(undef);
    }
}

sub record_work {
    my $self = shift;
    my $args = {@_};

    $self->dbw->xdo(
        insert_into => [
            'func_new_work', qw/change_id node_id offset start stop
              start_comment stop_comment/
        ],
        select => [
            $args->{change_id}, $args->{node_id},
            'wb.offset',        'wb.start',
            'wb.stop',          'wb.start_comment',
            'wb.stop_comment',
        ],
        from  => 'work_buffers wb',
        where => {
            'wb.node_id'  => $args->{node_id},
            'wb.billable' => 1,
            'wb.stop !'   => undef,
        },
    );

    $self->dbw->xdo(
        delete_from => 'work_buffers',
        where       => {
            'node_id'  => $args->{node_id},
            'billable' => 1,
            'stop !'   => undef,
        }
    );
}

sub new_change {
    my $self = shift;
    my %vals = @_;
    my $dbw  = $self->dbw;

    $vals{id} ||= $dbw->nextval('changes');
    my ( $author, $author_contact, $author_contact_method, $author_shortname )
      = $dbw->xlist(
        select     => [qw/e.name ecm.mvalue ecm.method i.shortname/],
        from       => 'bifkv b',
        inner_join => 'entities e',
        on         => 'e.id = b.identity_id',
        inner_join => 'identities i',
        on         => 'i.id = b.identity_id',
        inner_join => 'entity_contact_methods ecm',
        on         => 'ecm.id = e.default_contact_method_id',
        where      => { key => 'self' },
      );
    $vals{author}                //= $author;
    $vals{author_contact}        //= $author_contact;
    $vals{author_contact_method} //= $author_contact_method;
    $vals{author_shortname}      //= $author_shortname;

    return $self->err( 'NoSelfIdentity',
        'no "self" identity defined at change begin' )
      unless $vals{author};

    $dbw->xdo(
        insert_into => 'func_begin_change',
        values      => \%vals,
    );

    return $vals{id};
}

sub check {
    my $self = shift;
    my $id   = shift;
    my $db   = shift || $self->db;

    state $have_changeset = require Bif::DB::Plugin::ChangeUUIDv1;
    state $have_yaml      = require YAML::Tiny;
    state $have_encode    = require Encode;
    state $have_digest    = require Digest::SHA;

    my $changeset =
      $db->uchangeset_v1($id) || Carp::croak "invalid change.id: $id";

    my $begin = shift @$changeset;
    my $end   = pop @$changeset;
    my $uuid  = delete $end->{uuid};
    my $short = substr( $uuid, 0, 8 );

    foreach my $x (@$changeset) {
        next
          unless ref $x eq 'HASH'
          && exists $x->{_delta}
          && $x->{_delta} =~ m/^new_/;

        delete $x->{uuid};
    }

    my $yaml = YAML::Tiny::Dump( [ $begin, @$changeset, $end ] );
    my $sha1 = Digest::SHA::sha1_hex( Encode::encode( 'UTF-8', $yaml ) );

    my $action = $db->xval(
        select => ['c.action'],
        from   => 'changes c',
        where  => { 'c.id' => $id },
    );

    my ( $red, $reset ) = $self->colours( 'red', 'reset' );
    return ( 1, "[change: $id <$short>] $action" ) if $uuid eq $sha1;
    return ( 0, "[change: $id <$short>] $action ${red}INVALID$reset" );
}

sub end_change {
    my $self = shift;
    my $dbw  = $self->dbw;
    my %args = @_;

    my $iid = $dbw->xval(
        select => [ 'bif.identity_id', ],
        from   => 'bifkv bif',
        where  => { 'bif.key' => 'self' },
    );

    return $self->err( 'NoSelfIdentity',
        'no "self" identity defined at change end' )
      unless $iid;

    $dbw->xdo(
        insert_into => 'func_end_change',
        values      => {
            identity_id => $iid,
            %args,
        },
    );

    $dbw->xdo(
        insert_into => 'func_merge_changes',
        values      => { merge => 1 },
    );

    my $change_id = $dbw->xval( select => 'currval("changes")' );
    my ( $ok, $str ) = $self->check( $change_id, $dbw );
    return print $str. "\n" if $ok;

    # Show the diff to see what's wrong
    $self->new_cmd(
        'App::bif::show::change',
        db   => $self->dbw,    # to make current txn visible
        opts => {
            uid  => 'c' . $change_id,
            diff => 1,
        }
    )->run;

    my $keep_invalid = $dbw->xval(
        select => 'bool_val',
        from   => 'bifkv',
        where  => { key => 'keep_invalid' },
    );
    return $self->err( 'InvalidUUID', $str ) unless $keep_invalid;
    return print $str;
}

sub DESTROY {
    my $self = shift;
    Log::Any::Adapter->remove( $self->{_bif_log_any_adapter} )
      if $self->{_bif_log_any_adapter};
}

package Bif::OK;
use overload
  bool     => sub { 1 },
  '""'     => \&as_string,
  fallback => 1;

sub new {
    my $proto = shift;
    my $opts  = shift;
    $opts->{_bif_ok_type} = shift || Carp::confess('missing type');
    $opts->{_bif_ok_msg}  = shift || '';
    $opts->{_bif_ok_msg} = sprintf( $opts->{_bif_ok_msg}, @_ ) if @_;

    my $class = $proto . '::' . $opts->{_bif_ok_type};
    {
        no strict 'refs';
        *{ $class . '::ISA' } = [$proto];
    }

    return bless {%$opts}, $class;
}

sub as_string {
    my $self = shift;
    return $self->{_bif_ok_msg}
      if $self->{_bif_ok_msg} && !ref $self->{_bif_ok_msg};
    return ref $self;
}

package Bif::Error;
use overload
  bool     => sub { 1 },
  fallback => 1;

our @ISA = ('Bif::OK');

1;

__END__