File Coverage

blib/lib/File/SortedSeek/PERLANCAR.pm

Criterion	Covered	Total	%
statement	81	155	52.2
branch	22	78	28.2
condition	10	34	29.4
subroutine	13	25	52.0
pod	15	17	88.2
total	141	309	45.6

## no critic : Modules::ProhibitAutomaticExportation

package File::SortedSeek::PERLANCAR;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-04-25'; # DATE
our $DIST = 'File-SortedSeek-PERLANCAR'; # DIST
our $VERSION = '0.015.1'; # VERSION

use strict;
use warnings;
use Time::Local;
require Exporter;

use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION );

@ISA         = qw( Exporter );
@EXPORT      = ();
@EXPORT_OK   = qw( binsearch alphabetic numeric find_time get_between get_last );
%EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

my $descending  = 0;
my $cuddle      = 0;
my $line_length = 80;
my $error_msg   = '';
my $silent      = 0;
my $exact_match = 0;
my %months = ( Jan => 0, Feb => 1, Mar => 2, Apr => 3,
               May => 4, Jun => 5, Jul => 6, Aug => 7,
               Sep => 8, Oct => 9, Nov => 10,Dec => 11);
my $default_rec_sep = qw/\015\012|\015|\012/;

# some subs to set optional vars OO style
sub set_cuddle      { $cuddle = 1 };
sub set_no_cuddle   { $cuddle = 0 };
sub set_descending  { $descending = 1 };
sub set_ascending   { $descending = 0 };
sub set_max_tries   { };  # legacy method, no effect
sub set_line_length { };  # legacy method, no effect
sub set_silent      { $silent = 1 };
sub set_verbose     { $silent = 0 };
sub was_exact       { $exact_match };
sub error           { $error_msg; };

sub binsearch {
    local *FILE     = shift;
    my $string      = shift;
    my $compare_ref = shift;
    my $munge_ref   = shift;
    my $minoffset   = shift;
    my $maxoffset   = shift;
    $error_msg   = '';
    if ($descending) {
        _look( *FILE, $string, sub { -$compare_ref->(@_) }, $munge_ref, $minoffset, $maxoffset );
    } else {
        _look( *FILE, $string, $compare_ref, $munge_ref, $minoffset, $maxoffset );
    }
}

sub _alphabetic_compare { $descending ? $_[1] cmp $_[0] : $_[0] cmp $_[1] }

sub alphabetic {
    local *FILE     = shift;
    my $string      = shift;
    my $munge_ref   = shift;
    my $minoffset   = shift;
    my $maxoffset   = shift;
    $error_msg   = '';
    _look( *FILE, $string, \&_alphabetic_compare, $munge_ref, $minoffset, $maxoffset );
}

sub _numeric_compare { $descending ? $_[1] <=> $_[0] : $_[0] <=> $_[1] }

sub numeric {
    local *FILE     = shift;
    my $number      = shift;
    my $munge_ref   = shift;
    my $minoffset   = shift;
    my $maxoffset   = shift;
    $error_msg   = '';
    _look( *FILE, $number, \&_numeric_compare, $munge_ref, $minoffset, $maxoffset );
}

sub find_time {
    local *FILE     = shift;
    my $find        = shift || time;
    my $not_gmtime  = shift;
    $error_msg   = '';
    $find = get_epoch_seconds($find,$not_gmtime) unless $find =~ m/^[\d.]+$/;
    _look( *FILE, $find, \&_numeric_compare, \&get_epoch_seconds );
}

sub get_epoch_seconds {
    my ($line, $not_gmtime) = @_;
  return undef unless defined $line;
    my ($wday,$mon,$mday,$hours,$min,$sec,$year);
    # look for asctime format: Tue May 27 15:45:00 2008
    # ignore wday token as this is often dropped ie linux kernel messages
    if ($line =~ m/(\w{3})\s+(\d{1,2})\s+(\d\d):(\d\d):(\d\d)\s+(\d{4})/ ) {
       ($mon,$mday,$hours,$min,$sec,$year) = ($1,$2,$3,$4,$5,$6);
    }
    # look for apache time format: [21/May/2008:17:49:39 +1000]
    # ignore the time offset
    elsif($line =~ m!\[(\d{1,2})/(\w{3})/(\d{4}):(\d\d):(\d\d):(\d\d)!x ) {
       ($mday,$mon,$year,$hours,$min,$sec) = ($1,$2,$3,$4,$5,$6);
    }
    # look for straight epochtime data (ie squid log)
    elsif($line =~ m/^(\d+)/) {
        return $1;
    }
    unless ($year) {
        $error_msg = "Unable to find time like string in line:\n$line";
        warn $error_msg unless $silent;
      return undef;
    }
    $mon = $months{$mon};   # convert to numerical months 0 - 11
  return $not_gmtime ? timelocal($sec,$min,$hours,$mday,$mon,$year):
                       timegm($sec,$min,$hours,$mday,$mon,$year);
}

sub get_between {
    local *FILE = shift;
    my $begin   = shift || 0;
    my $finish  = shift || 0;
    my $rec_sep = shift || $default_rec_sep;
    $error_msg   = '';
    ($begin , $finish) =  ($finish, $begin) if $begin > $finish;
    my $bytes   = $finish - $begin;
    sysseek FILE, $begin, 0;
    my $read = sysread(FILE, my $buffer, $bytes);
    if ( $read < $bytes ) {
        $error_msg  = "Short read\nWanted: $bytes Got: $read\n";
        warn $error_msg unless $silent;
      return undef;
    }
    $buffer = substr $buffer, 0, $bytes;
    my @lines = split $rec_sep, $buffer;
  return wantarray ? @lines : [ @lines ];
}

sub get_last {
    local *FILE    = shift;
    my $num_lines  = shift;
    my $rec_sep    = shift || $default_rec_sep;
    $error_msg   = '';
    my @stat = stat(FILE) or return undef;
    my($size,$blksize) = @stat[7,11];
    $blksize ||= 8192;
    # grab the first chunk back from eof at block offset
    my $pos = $size - (($size % $blksize)|| $blksize );
    my $file = '';
    my ($buf, $lines);
    for(;;) {
        $pos = 0 if $pos < 0;
        sysseek(FILE,$pos,0);
        sysread(FILE, $buf, $blksize) or last; # returns 0 at eof;
        $file = $buf.$file;
        my $lines = () = $file =~ m/$rec_sep/g;
      last if $lines > $num_lines or $pos == 0;
        $pos -= $blksize;
    }
    my @file = split /$rec_sep/, $file;
    if ( $num_lines > @file ) {
        $error_msg = "Unable to find $num_lines\n";
        warn $error_msg unless $silent;
      return wantarray ? @file : \@file;
    }
    else {
        $num_lines = $#file - $num_lines + 1;
      return wantarray ? @file[$num_lines..$#file] : [@file[$num_lines..$#file]];
   }
}

# Modified version of Perl Search::Dict's look()

sub _look {
    local *FILE = shift;
    my($key,$comp,$xfrm,$minoffset,$maxoffset) = @_;
    local $_;
    return undef if not defined $key;
    my($size, $blksize);
    if (defined $maxoffset) {
        $size = $maxoffset;
    } else {
        my @stat = stat(FILE) or return undef;
        ($size, $blksize) = @stat[7,11];
        $maxoffset = $size-1;
    }
    $blksize ||= 8192;
    $minoffset ||= 0;
    $size -= $minoffset;

    # find the right block
    my($min, $max) = (0, int($size / $blksize));
    my $mid;
    while ($max - $min > 1) {
        $mid = int(($max + $min) / 2);
        seek(FILE, $mid * $blksize + $minoffset, 0) or return undef;
         if $mid; # probably a partial line
        $_ = ;
        $_ = $xfrm->($_) if $xfrm;
        chomp;
        (defined($_) && $comp->($_, $key) < 0) ? $min = $mid : $max = $mid;
    }
    # find the right line
    $min *= $blksize;
    seek(FILE,$min+$minoffset,0) or return undef;
     if $min; # probably a partial line
    my $prev_min = $min;
    for (;;) {
        $min = tell(FILE) - $minoffset;
        defined($_ = ) or last;
        $_ = $xfrm->($_) if $xfrm;
        chomp;
        my $cmp = $comp->($_, $key);
        $exact_match = $cmp==0 ? 1 : 0;
        if(!$cuddle and $cmp  >= 0){
            seek(FILE,$min+$minoffset,0);
            if ($min+$minoffset > $maxoffset) {
                $exact_match = 0;
                return undef;
            } else {
                return $min+$minoffset;
            }
        }
        if($cuddle and $cmp > 0){
            seek(FILE,$prev_min+$minoffset,0);
            if ($prev_min+$minoffset > $maxoffset) {
                $exact_match = 0;
                return undef;
            } else {
                return $prev_min+$minoffset;
            }
        }
        $prev_min = $min;
    }
    return undef;
}

1;
# ABSTRACT: A fork of File::SortedSeek with some more options

__END__