File Coverage

blib/lib/Vi/QuickFix.pm

Criterion	Covered	Total	%
statement	85	174	48.8
branch	21	76	27.6
condition	12	34	35.2
subroutine	24	38	63.1
pod	0	12	0.0
total	142	334	42.5

#!/usr/bin/perl
package Vi::QuickFix;
use 5.008_000;
use strict; use warnings;
# use Carp;

our $VERSION;
BEGIN {
    $VERSION = ('$Revision: 1.135 $' =~ /(\d+.\d+)/)[ 0];
}

unless ( caller ) {
    # process <> if called as an executable
    exec_mode(1); # signal fact ( to END processing)
    require Getopt::Std;
    Getopt::Std::getopts( 'q:f:v', \ my %opt);
    print "$0 version $VERSION\n" and exit 0 if $opt{ v};
    err_open( $opt{ q} || $opt{ f});
    print && err_out( $_) while <>;
    exit;
}

###########################################################################

# keywords for ->import
use constant KEYWORDS => qw(silent sig tie fork);

# environment variable(s)
use constant VAR_SOURCEFILE => 'VI_QUICKFIX_SOURCEFILE';

BEGIN {{ # space for private variables

my $relay = '';             # method of transfer to error file: "sig" or "tie"
my %invocation;             # from where was import() called?

sub import {
    my $class = shift;
    my %keywords;
    @keywords{ KEYWORDS()} = ();
    $keywords{ shift()} = 1 while @_ and exists $keywords{ $_[ 0]};

    my $filename = shift;
    make_silent() if $keywords{ silent};
    my ( $wanted_relay) = grep $keywords{ $_}, qw( sig tie fork);
    $relay = $wanted_relay || default_relay();
    if ( my $reason = relay_obstacle( $relay) ) {
        croak( "Cannot use '$relay' method: $reason");
    }
    err_open($filename) unless $relay eq 'fork'; # happens in background
    if ( $relay eq 'tie' ) {
        # if tied, it's tied to ourselves (otherwise obstacle)
        tie *STDERR, 'Vi::QuickFix::Tee', '>&STDERR' unless tied *STDERR;
    } elsif ( $relay eq 'sig' ) {
        $SIG{ $_} = Vi::QuickFix::SigHandler->new( $_) for
            qw( __WARN__ __DIE__);
    } elsif ( $relay eq 'fork' ) {
        *STDERR = fork_relay($filename);
    }
    # save invocation for obligate message
    (undef, @invocation{qw(file line)}) = caller;
}

# internal variables
{
    my $exec_mode; # set if lib file is run as a script
    sub exec_mode {
        $exec_mode = shift if @_;
        $exec_mode;
    }

    my $silent = 0;             # switch off otherwise obligatory warning
    sub make_silent { $silent = 1 }
    sub is_silent { $silent }

    my $errfile = 'errors.err'; # name of error file
    my $errhandle; # write formatted errors here
    # open the given file (or default), set $errfile and $errhandle
    sub err_open {
        $errfile = shift || 'errors.err';
        $errhandle = IO::File->new( $errfile, '>') or warn(
            "Can't create error file '$errfile': $!"
        );
        $errhandle->autoflush if $errhandle;
    }

    sub err_print {
        print $errhandle @_ if $errhandle;
    }

    sub err_clean {
        my $unlink = shift;
        close $errhandle if $errhandle;
        unlink $errfile if $errfile and $unlink and not -s $errfile;
    }
}

sub err_out {
    # handle multiple, possibly multi-line messages (though usually
    # there will be only one)
    for ( map split( /\n+/), @_ ) {
        my $out;
        if ( /.+:\d+:/ ) { # already in QuickFix format, pass on
            err_print("$_\n");
        } else {
            for ( parse_perl_msg($_) ) {
                my ( $message, $file, $line, $rest) = @$_ or next;
                $message .= $rest if $rest =~ s/^,//;
                $file eq '-' and defined and $file = $_ for
                    $ENV{ VAR_SOURCEFILE()};
                err_print("$file:$line:$message\n");
            }
        }
    }
}

# use constant PERL_MSG => qr/^(.*?) at (.*?) line (\d+)(\.?|,.*)$/;
sub parse_perl_msg {
    my @coll;
    for ( shift ) {
        while ( m/ at /g ) {
            my $text = substr($_, 0, $-[0]);
            my $pos = pos;
            while ( m/ line (\d+)(\.?|,.*)$/g ) {
                my $file = substr($_, $pos, $-[0] - $pos);
                my $line = $1;
                my $rest = $2;
                push @coll, [$text, $file, $line, $rest];
            }
            pos = $pos;
        }
    }
    return @coll if @coll <= 1;
    my @existing = grep -e $_->[1], @coll;
    return @existing if @existing;
    return @coll;
}

# issue warning, erase error file
my $end_entiteled = $$;
END {
    # issue warning (only original process, and not in exec mode)
    unless ( is_silent or exec_mode() or $$ != $end_entiteled ) {
        my $invocation_at;
        if ( %invocation ) {
            $invocation_at = "at $invocation{file} line $invocation{line}";
        } else {
            $invocation_at = "at -M";
        }
        warn "QuickFix ($relay) active $invocation_at\n";
    }
    # silently remove objects
    make_silent();
    if ( $relay eq 'tie' ) {
        untie *STDERR;
    } elsif ( $relay eq 'sig' ) {
        $SIG{ $_} = 'DEFAULT' for qw( __WARN__ __DIE__);
    } elsif ( $relay eq 'fork' ) {
        close STDERR;
        wait_kid();
    }
    # remove file if created by us and empty
    err_clean($$ == $end_entiteled);
}

}}

use constant MINVERS => 5.008001; # minimum perl version for tie method
sub relay_obstacle {
    my $relay = shift || '';
    return '' unless $relay eq 'tie';
    if ( $] < MINVERS ) {
        return "perl version is $], must be >= @{[ MINVERS]}";
    }
    if ( my $tie_ob = tied *STDERR ) {
        my $tieclass = ref $tie_ob;
        return "STDERR already tied to '$tieclass'" unless
            $tieclass eq 'Vi::QuickFix::Tee';
    }
    return '';
}

sub default_relay { relay_obstacle( 'tie') ? 'sig' : 'tie' }

{
    use Carp;
    my ($read, $write, $kid);
    sub fork_relay {
        my $filename = shift;
        my $parent = $$;
        pipe $read, $write;
        if ( $kid = fork ) {
            # parent
            close $read;
            return $write;
        } else {
            Carp::croak "Can't fork: $!" unless  defined $kid;
            # kid
            close $write;
            err_open($filename);
            while ( <$read> ) {
                print STDERR $_;
                err_out($_);
            }
            err_clean(1);
            exit;
        }
    }

    use POSIX ":sys_wait_h";
    sub wait_kid {
        my $x;
        do { $x = waitpid -1, WNOHANG } while $x > 0;
    }
}

# common destructor method
package Vi::QuickFix::Destructor;

use Carp qw( shortmess);
BEGIN { our @CARP_NOT = qw( Vi::QuickFix) }
sub DESTROY {
    my $ob = shift;
    return if Vi::QuickFix::is_silent or $^C; # it's a mess under -c
    my $id = $ob->id;
    my $msg = shortmess( "QuickFix $id processing interrupted");
    # simulate intact QuickFix processing
    Vi::QuickFix::err_out( $msg);
    warn "$msg";
}

# Class to associate a DESTROY method with sig handlers
package Vi::QuickFix::SigHandler;
use base qw( Vi::QuickFix::Destructor);

# return a chaining handler for __WARN__ or __DIE__
sub new {
    my $class = shift;
    my $sig = shift;
    my $prev_handler = $SIG{ $sig};
    my $sub = sub {
        return $sig unless @_; # backdoor
        Vi::QuickFix::err_out( @_) unless $sig eq '__DIE__' and  _in_eval();
        my $code;
        # resolve string at call time
        if ( $prev_handler ) {
            $code = ref $prev_handler ?
                $prev_handler :
                \ &{ 'main::' . $prev_handler};
        }
        goto &$code if $code;
        die @_ if $sig eq '__DIE__';
        warn @_;
    };
    bless $sub, $class; # so we can have a destructor
}

sub _in_eval {
    my $i = -1; # first call with 0
    while ( defined(my $sub = (caller ++ $i)[3]) ) {
        return 1 if $sub =~ /^\(eval/;
    }
    return 0;
}

sub id {
    my $handler = shift;
    $handler->(); # call without args returns __WARN__ or __DIE__
}

# tie class to tee re-formatted output to an error file
package Vi::QuickFix::Tee;

use IO::File;
use Tie::Handle;
use base qw( Tie::StdHandle Vi::QuickFix::Destructor);

sub WRITE {
    my $fh = shift;
    my ( $scalar, $length) = @_;
    Vi::QuickFix::err_out( $scalar);
    $fh->Tie::StdHandle::WRITE( @_);
}

# work around buggy BINMODE in Tie::Stdhandle

sub BINMODE {
    binmode($_[0], $_[1])
}

sub id { 'STDERR' }

1;

__END__