#
# Copyright (c) 2004-2007 - Consultas, PKG.fr
#
# This file is part of A2P.
#
# A2P is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# A2P is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with A2P; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
# $Id: Tools.pm 3 2007-10-18 16:20:19Z guillaume $
#
# Some usefull subfunctions
#

package A2P::Tools;

use strict;
use integer;
use Fcntl;
use Errno qw( EINTR EACCES EAGAIN );
use Encode 'from_to';
use Fcntl qw(
    :flock
    O_CREAT O_RDWR F_GETLK F_SETLK F_SETLKW F_WRLCK F_UNLCK SEEK_SET
    );
use IO::Handle ;
use DB_File ;
use Time::HiRes qw( tv_interval gettimeofday usleep ) ;
use A2P::Globals;
use A2P::Syslog;

BEGIN {
    use Exporter ();
    our ( $VERSION , @ISA , @EXPORT_OK );

    $VERSION = sprintf "%s", q$Rev: 994 $ =~ /(\d[0-9.]+)\s+/ ;

    @ISA = qw(Exporter);
    @EXPORT_OK = qw(    &debugbuffer  &compute     &mychomp  &FreeSharedList
                        &FcntlLocked  &getrusage   &ShortID  &WaitFcntlLocked
                        &SharedList   &myreadline  &ms       &FcntlUnlocked
                    );
}
our $VERSION ;

sub mychomp( \$ ) {
    my $buffer = shift ;
    my $ret = 0 ;

    $ret = chomp $$buffer ;

    if ( ord( substr( $$buffer , -1 , 1 )) == 0x0D ) {
        $$buffer = substr( $$buffer , 0 , length( $$buffer )-1 );
        $ret ++;
    }

    # Strip from last spaces unless argument provided
    while ( ! @_ and ord( substr( $$buffer , -1 , 1 )) == 0x40 ) {
        $$buffer = substr( $$buffer , 0 , length( $$buffer )-1 );
        $ret ++;
    }

    return $ret ;
}

sub myreadline(\*;\$) {
    my ( $file , $buffer ) = @_ ;
    my ( $char , $long , $ret ) = ( " " , 1 , 0 );

    while ( $long and $char ne chr(0x0A) and ! eof($file)) {
        $ret += $long = read( $file , $char , 1 );
        $$buffer .= $char ;
    }

    return $ret ;
}

my $bugindex = '  0 1 2 3  4 5 6 7  8 9 A B  C D E F' ;

sub debugbuffer {
    my $buffer = shift ;
    my $kind   = shift ;

    # Force kind flag if no conversion is required
    $kind = $TO_CONVERT unless ($DO_CONVERT);

    # Will return an array of RAW buffer conversion
    my $ref = [] ;

    return $ref
        if ( length( $buffer ) == 0 or $NO_SYSLOG_DEBUG ) ;

    undef $kind
        if ( defined($kind) and $kind ne "NO TEXT" );

    if ( defined( $kind ) ) {
        &Debug( " DEBUGBUFFER:$bugindex" ) ;
        push @{$ref}, $bugindex ;

    } else {
        &Debug( " DEBUGBUFFER:$bugindex |      EBCDIC      |      ASCII       |" );
        push @{$ref}, "$bugindex |      EBCDIC      |      ASCII       |" ;
    }

    my ( $len , $max ) = ( 16 , length( $buffer ) );

    my $index = 0 ;
    my ( $hex , $ebcdic , $ascii );

INNER:
    while ( $index < $max ) {
OUTER:
        while ( $index%$len < $len ) {
            $hex = $ebcdic = $ascii = "" if ( $index%$len == 0 );

            my $char = substr( $buffer , $index , 1 ) ;
            my $chr  = ord( $char ) ;
            $hex .= " " if ( $index%4 == 0 ) ;
            $hex .= sprintf( "%02x" , $chr ) ;
            unless (defined( $kind )) {
                $ebcdic .= ( $chr & 127 < 32 ) ? "." : $char ;
                &from_to( $char , $FROM_CONVERT , $TO_CONVERT );
                $ascii .= ( ord($char) & 127 < 32 )? "." : $char ;
            }
            $index ++ ;
            last OUTER if ( $index%$len == 0 );
            last INNER if ( $index > $max );
        }#OUTER

        if ( defined( $kind ) ) {
            &Debug( "DEBUGBUFFER:$hex" );
            push @{$ref}, $hex ;

        } else {
            &Debug( "DEBUGBUFFER:$hex | $ebcdic | $ascii |" );
            push @{$ref}, "$hex | $ebcdic | $ascii |" ;
        }
    }#INNER

    if ( $index%$len ) {
        unless (defined( $kind )) {
            my $sp = $len - ($index%$len) ;
            $hex .= " " x (2*$sp + $sp/4 ) . " | $ebcdic" . " " x $sp .
                "  | $ascii" . " " x $sp . "  |";
        }
        &Debug( "DEBUGBUFFER:$hex" );
        push @{$ref}, $hex ;
    }

    # Return RAW array to eventually be logged later as information after
    # and error (exemple: bad format of PTX field)
    return $ref ;
}

################################################
# File locking direct system call
# Wait a filehandle as argument

# "s!s!l!l!l!" for 32bits env... for 64bits env, should use "s!s!QQl!"
my $arch = qx/uname -p/ ;
chomp $arch ;
my $pack_string = $arch !~ /64$/ ? "s!s!l!l!l!" : "s!s!QQl!" ;
my $write_lock_flock_struct = pack $pack_string, F_WRLCK, SEEK_SET, 0, 0, 0 ;
sub FcntlLocked {
    &UPSTAT('FCNTLLOCKED-CALL');
    my $handle = shift ;

    &Debug("Handle = $handle ".ref($handle)) if (defined($handle));

    unless (ref($handle) =~ /^GLOB/) {
        &Error("Can't only try locking defined handles");
        return 0 ;
    }

    # Try to lock the file handle
    fcntl( $handle, F_SETLK, $write_lock_flock_struct )
        or &Debug("Can't lock handle with fcntl call: $! ".int($!)), return 0;

    return 1;
}

sub WaitFcntlLocked {
    &UPSTAT('WAITFCNTLLOCKED-CALL');
    my $handle = shift ;

    unless (ref($handle) =~ /^GLOB/) {
        &Error("Can't only try locking defined handles");
        return 0 ;
    }

    $! = 0 ;
    # Try to lock the file handle retrying when interrupted
    while ( ! fcntl( $handle, F_SETLKW, $write_lock_flock_struct )) {
        last unless ( $! == EINTR );
        $! = 0 ;
    }

    if ($!) {
        &Debug("Can't waiting lock on handle with fcntl call: $! ".int($!));
        return 0 ;
    }

    return 1;
}

# "s!s!l!l!l!" for 32bits env... for 64bits env, should use "s!s!QQl!"
my $unlock_flock_struct = pack $pack_string, F_UNLCK, 0, 0, 0, 0 ;
sub FcntlUnlocked {
    &UPSTAT('FCNTLUNLOCKED-CALL');
    my $handle = shift ;

    unless (ref($handle) =~ /^GLOB/) {
        &Error("Can't only try unlocking defined handles");
        return 0 ;
    }

    $! = 0 ;

    # Try to lock the file handle
    fcntl( $handle, F_SETLK, $unlock_flock_struct )
        or &Debug("Can't unlock handle with fcntl call: $! ".int($!)), return 0;

    &Debug("Current system error: $! ".int($!)) if $! ;
    return 1;
}

sub __NR_getrusage () { 77 }   # Value taken from <asm/unistd.h>

################################################
# getrusage system call
sub getrusage {
    my $who = shift || 0 ;
    my $rusage = " " x ( 18 * 4 ) ; # Size of struc rusage
    my @struct ;

    if ( $who == 0 ) {
        &Debug("Getting rusage for T$$");

    } elsif ($who == -1 ) {
        &Debug("Getting rusage for T$$ children");

    } else {
        &Error("Can't get rusage for $who");
        return ();
    }

    $! = 0 ;
    my $Ret = syscall( __NR_getrusage , $who , $rusage );
    (&Debug("Can't getrusage with fcntl call: $!"), return ()) if ($Ret == -1);

    #struct timeval (from bits/time.h)
    #  {
    #    __time_t tv_sec;       /* Seconds.  */       --> long int
    #    __suseconds_t tv_usec; /* Microseconds.  */  --> long int
    #  };

    my (      #struct rusage { (from man getrusage)
              #struct timeval ru_utime; /* user time used */
                $ru_utime__tv_sec, $ru_utime__tv_usec,
              #struct timeval ru_stime; /* system time used */
                $ru_stime__tv_sec, $ru_stime__tv_usec,
        $ru_maxrss,     # long   ru_maxrss;   /* maximum resident set size */
        $ru_ixrss,      # long   ru_ixrss;    /* integral shared memory size */
        $ru_idrss,      # long   ru_idrss;    /* integral unshared data size */
        $ru_isrss,      # long   ru_isrss;    /* integral unshared stack size */
        $ru_minflt,     # long   ru_minflt;   /* page reclaims */
        $ru_majflt,     # long   ru_majflt;   /* page faults */
        $ru_nswap,      # long   ru_nswap;    /* swaps */
        $ru_inblock,    # long   ru_inblock;  /* block input operations */
        $ru_oublock,    # long   ru_oublock;  /* block output operations */
        $ru_msgsnd,     # long   ru_msgsnd;   /* messages sent */
        $ru_msgrcv,     # long   ru_msgrcv;   /* messages received */
        $ru_nsignals,   # long   ru_nsignals; /* signals received */
        $ru_nvcsw,      # long   ru_nvcsw;    /* voluntary context switches */
        $ru_nivcsw      # long   ru_nivcsw;   /* involuntary context switches */
    );

    @struct = unpack( "l!18" , $rusage );

    return @struct ;
}

#========================================================================
# Private table to compute identifier
my @cons = split(//,'bcdfgjklmnprstvxz');
my @voy  = split(//,'aeiou' );
my ( $mC , $mV ) = ( scalar(@cons) , scalar(@voy) ) ;
#========================================================================
sub ShortID {
    my $length = shift || 4 ;
    my $id = "" ;
    $id .= $length % 2 ? $cons[rand($mC)] : $voy[rand($mV)] while ( $length -- );
    return $id ;
}

sub compute {
    my ( $bufref , $pos , $long ) = @_ ;
    my ( $ret , $mul ) = ( 0 , 1 ) ;

    return &Error("[DEV] Unsupported use of 'compute' tool: long $long > 4")
        if ( $long > 4 );

    return &Error("[DEV] Unsupported use of 'compute' tool: long $long < 0")
        if ( $long < 0 );

    &Debug("Buffer is not as long as expected")
        if ( $pos + $long > length( $$bufref ) );

    # Avoid infinite loop if long is negative
    while ( $long--  ) {
        $ret += ord( substr( $$bufref , $pos + $long , 1 ) ) * $mul ;
        $mul <<= 8 ;
    }

    return $ret ;
}

#========================================================================
# SharedList is a facility to shared lists between processes
my %lists = (
    # Key = name of the list -> is also used to tie the list
    # Value = Array ref: [
    #   Array ref of the tied list
    #   Array ref to a list of values to push in tied list
    #   FileHandle of the locking file if tied or 0
    # ]
    ) ;
sub SharedList {
    # Return an array ref to which push values
    my $list = shift || 'shared_list_of_lost_values' ;
    my $List = uc($list) ;

    my $force = shift || 0 ;

    $! = 0 ;

    # The shared list should better be in shared memory
    my $base = $SHMDIR . '/.shared-list-' . $list ;

    # 1. Initiliaze hash if not done in our processus
    unless (exists($lists{$list})) {
        $lists{$list} = [ [], [], 0 ] ;
    }

    # 2. Get the array refs for that list
    my ( $tied, $kept, $fh ) = @{$lists{$list}} ;
    &Debug("FileHandle not previously released for $list list locking")
        if ($fh);

    # 3. Try to open files and tie list and return $kept ref on any error
    # 3.1. Open LCK file
    undef $fh ;
    unless (open($fh, '>', $base.'.LCK')) {
        &UPSTAT('SHARED-LIST-OPEN-ERRNO-'.int($!));
        &Debug("Can't open $base.LCK lock file: $!");
        return $kept ;
    }

    # 3.2. Lock file without blocking
    unless (flock($fh, $force ? LOCK_EX : LOCK_EX | LOCK_NB)) {
        &UPSTAT('SHARED-LIST-LOCK-ERRNO-'.int($!));
        # Only log on other error than ressource is busy (EAGAIN)
        &Debug("Can't lock $list list: $!") unless ($! == EAGAIN);
        close ($fh);
        return $kept ;
    }
    &TIMESTAT('SHARED-LIST-LOCKED-'.$List);
    &TIMESTAT('SHARED-LIST-GET-TIED-'.$List);

    # Keep internal statistics on DB_File size
    &MAXSTAT('SHARED-LIST-FILE-SIZE-'.$List,(-s $base));

    # 3.3. Tie the list
    my @tied ;
    unless (tie @tied, 'DB_File', $base, O_CREAT|O_RDWR, oct(660), $DB_RECNO ) {
        &UPSTAT('SHARED-LIST-TIE-ERRNO-'.int($!));
        &Debug("Can't tie $list list: $!");
        &TIMESTAT('SHARED-LIST-GET-TIED-'.$List);
        flock($fh, LOCK_UN);
        &TIMESTAT('SHARED-LIST-LOCKED-'.$List);
        close ($fh);
        return $kept ;
    }
    &TIMESTAT('SHARED-LIST-GET-TIED-'.$List);
    &TIMESTAT('SHARED-LIST-TIED-'.$List);

    # 3.4. File is locked and tied, keep this information
    $lists{$list}->[0] = \@tied ;
    $lists{$list}->[2] = $fh ;
    &UPSTAT('SHARED-LIST-TIED-'.$List);

    # 4. Inject now kept values
    if (@{$kept}) {
        &UPSTAT('SHARED-LIST-INJECT-KEPT-'.$List);
        &MAXSTAT('SHARED-LIST-KEPT-'.$List,scalar(@{$kept}));
        push @tied, @{$kept};
        # Keep the kept reference as empty array
        $lists{$list}->[1] = [] ;
    }

    # 5. Return the ref to the tied array
    return \@tied ;
}

sub FreeSharedList {
    # Free a shared list
    my $list = shift || 'shared_list_of_lost_values' ;
    my $List = uc($list) ;

    # 1. Initiliaze hash if not done in our processus
    unless (exists($lists{$list})) {
        &Debug("Can't free not shared $list list");
        return 0 ;
    }

    # 2. Get the array refs for that list
    my ( $tied, $kept, $fh ) = @{$lists{$list}} ;

    # 3. Untie the list is really tied and locked
    if ($fh) {
        my $tied_array = tied(@{$tied}) ;
        if (defined($tied_array)) {
            &UPSTAT('SHARED-LIST-SYNC-'.$List);
            $tied_array->sync ;
            undef $tied_array ;
        }

        # Untie the array
        untie @{$tied} ;
        &TIMESTAT('SHARED-LIST-TIED-'.$List);

        # Unlock the lock file
        flock($fh, LOCK_UN);
        &TIMESTAT('SHARED-LIST-LOCKED-'.$List);
        close ($fh);
        $lists{$list}->[2] = 0 ;
        &UPSTAT('SHARED-LIST-UNTIED-'.$List);
    }
}

sub ms {
    # Avoid use of integer to support large integer on 32 bits platforms
    no integer ;

    # Get current millisecond
    my ( $sec , $usec ) = &gettimeofday() ;

    # If a parameter is defined, we want to add the seconds with it. It could be
    # a negative number to get a timer to compare
    $sec += shift if @_ ;

    return int( $sec * 1000 + $usec / 1000 ) ;
}

1;
