File Coverage

blib/lib/OptArgs2/StatusLine.pm

Criterion	Covered	Total	%
statement	54	59	91.5
branch	8	16	50.0
condition	7	10	70.0
subroutine	13	14	92.8
pod	0	2	0.0
total	82	101	81.1

use strict;
use warnings;

package OptArgs2::StatusLine {

    our @CARP_NOT;

    sub _croak {
        @CARP_NOT = (__PACKAGE__);
        require Carp;
        Carp::croak(@_);
    }

    sub import {
        no strict 'refs';
        my $class  = shift;
        my $caller = scalar caller;

        while (@_) {
            my ( $l, $p ) = ( shift, shift );

            if ( $l =~ s/^\$(.*)// ) {
                $l = $caller . '::' . $1;
            }
            else {
                die 'first argument must be like "$scalar"';
            }

            my $x;
            if ( defined $p && $p =~ s/^\$(.*)// ) {
                my $o = make_line_prefix( $x, my $y );
                $p = $caller . '::' . $1;
                *{$p} = \$y;
            }
            else {
                make_line( $x, $p );
            }

            *{$l} = \$x;
        }
    }

    sub make_line {
        my $o = tie $_[0], 'OptArgs2::StatusLine::Line';
        $o->{prefix} = $_[1] // '';
        $o;
    }

    sub make_line_prefix {
        my $o = tie $_[0], 'OptArgs2::StatusLine::Line';
        tie $_[1], 'OptArgs2::StatusLine::Prefix', $o;
        $o;
    }
}

package OptArgs2::StatusLine::Line {

    sub TIESCALAR {
        my $class = shift;
        no strict 'refs';
        bless {
            prefix => '',
            val    => undef,
        }, $class;
    }

    sub FETCH {
        my $self = shift;
        $self->{val};
    }

    sub STORE {
        my $self = shift;
        $self->{val} = shift // return;
        return if not defined $self->{val};

        my $NL = $self->{val} =~ s/\n\z// ? 1 : 0;
        my $fh = select;

        if ( -t $fh ) {
            $fh->printflush( $self->{prefix}
                  . $self->{val} . "\e[K"
                  . ( $NL ? "\n" : "\r" ) );
        }
        else {
            $fh->print( $self->{prefix} . $self->{val} . "\n" );
        }

        $self->{val} = '' if $NL;
    }
}

package OptArgs2::StatusLine::Prefix {

    sub TIESCALAR {
        my ( $class, $line ) = @_;
        bless \$line, $class;
    }

    sub FETCH {
        my $self = shift;
        $$self->{prefix};
    }

    sub STORE {
        my $self        = shift;
        my $o           = $$self;
        my $was_defined = defined $o->{prefix};
        $o->{prefix} = shift;
        $o->STORE( $o->{val} ) if defined $o->{prefix} and $was_defined;
    }
}

1;

__END__