source: A2P/a2p/A2P/Com.pm @ 3

#
# 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: Com.pm 3 2007-10-18 16:20:19Z guillaume $
#

package A2P::Com ;

use strict ;
use Socket ;
use Time::HiRes qw( gettimeofday usleep );
use Fcntl qw(:flock F_SETLK F_WRLCK SEEK_SET);
use IO::Socket ;
use A2P::Globals ;

BEGIN {
    use Exporter ();

    our ( $VERSION , @ISA , @EXPORT_OK , @TT );

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

    @ISA = qw(Exporter);

    @EXPORT_OK = qw( &IsCom &GetCom
        &comCOM &comASK &comREQ &comLOG &comJOB &comSAY &comDONE &comINF &comTEST
        &comZIP &comUPD &comFILE &GetTmpFile &TakeComLocking &ReleaseComLocking
        &comXML
        );

    # Set timer ref to starting time
    @TT = ( $^T , ( $^T * 1_000_000 ) % 1_000_000 ) unless @TT ;
}
our $VERSION ;
our @TT ;

#############################################################################
##          Com tags lists                                                 ##
#############################################################################
# Constant tag index
sub comCOM  ()   {   0  };
sub comASK  ()   {   1  };
sub comREQ  ()   {   2  };
sub comLOG  ()   {   3  };
sub comJOB  ()   {   4  };
sub comSAY  ()   {   5  };
sub comINF  ()   {   6  };
sub comZIP  ()   {   7  };
sub comUPD  ()   {   8  };
sub comFILE ()   {  50  };
sub comXML  ()   { 1111 };
sub comTEST ()   { 8888 };
sub comDONE ()   { 9999 };

my $id = 1000 ;

my %Coms = (
    comCOM  ,  [  "<com id=", 0, " tid='"   , ""  , "'>" , "</com>" , 'COM' ],
    comASK  ,  [  "<ask id=", 0, " for='"   , ""  , "'>" , "</ask>" , 'ASK' ],
    comREQ  ,  [  "<req id=", 0, " to='"    , ""  , "'>" , "</req>" , 'REQ' ],
    comLOG  ,  [  "<log id=", 0, " level='" , ""  , "'>" , "</log>" , 'LOG' ],
    comJOB  ,  [  "<job id=", 0, " jid='"   , ""  , "'>" , "</job>" , 'JOB' ],
    comSAY  ,  [  "<say id=", 0, " for='"   , ""  , "'>" , "</say>" , 'SAY' ],
    comINF  ,  [  "<info id=",0, " kind='"  , ""  , "'>" , "</info>", 'INFO'],
    comZIP  ,  [  "<zip id=", 0, " file='"  , ""  , "'>" , "</zip>" , 'ZIP' ],
    comUPD  ,  [  "<maj id=", 0, " what='"  , ""  , "'>" , "</maj>" , 'MAJ' ],
    comFILE ,  [  "<file id=",0, " name='"  , ""  , "'>" , "</file>", 'FILE'],
    comDONE ,  [  "<done id=",0, ""         , ""  , ">"  , "</done>", 'DONE']
);

my %RegExp = (
    comCOM  ,  qr|^<com +id=\d{4} +tid=(["']?)(\d+)\1 *>(.*)</com>$|i   ,
    comASK  ,  qr|^<ask +id=\d{4} +for=(["']?)(\w+)\1 *>(.*)</ask>$|i   ,
    comREQ  ,  qr|^<req +id=\d{4} +to=(["']?)(\w+)\1 *>(.*)</req>$|i    ,
    comLOG  ,  qr|^<log +id=\d{4} +level=(["']?)(\w+)\1 *>(.*)</log>$|i ,
    comJOB  ,  qr|^<job +id=\d{4} +jid=(["']?)([-0-9a-zA-Z_.]+)\1 *>(.*)</job>$|i   ,
    comSAY  ,  qr|^<say +id=\d{4} +for=(["']?)(\w+)\1 *>(.*)</say>$|i,
    comINF  ,  qr|^<info +id=\d{4} +kind=(["']?)([\s\w]+)\1 *>(.*)</info>$|i,
    comZIP  ,  qr|^<zip +id=\d{4} +file=(["']?)([^\1>]+)\1 *>(.*)</zip>$|i,
    comUPD  ,  qr|^<maj +id=\d{4} +what=(["']?)(\w+)\1 *>(.*)</maj>$|i,
    comFILE ,  qr|^<file +id=\d{4} +name=(["']?)([^\1>]+)\1 *>(.*)</file>$|i,
    comDONE ,  qr|^<(done) +id=\d{4}.*>(.*)</done>$|i,
    comXML  ,  qr|^\s*<\w+.*>\s*$|s
);

sub GetCom {
    local $" = '' ;
    my $com = shift ;
    $Coms{$com}->[1] = $id < 10000 ? $id ++ : ( $id = 1000 ) ;
    $Coms{$com}->[3] = shift || "" ;
    return "@{$Coms{$com}}[0..4]@_" . $Coms{$com}->[5] ;
}

# IsCom returns a list of matched pattern (pattern is s=choosen from first arg)
sub IsCom {
    if ( $_[0] > 999 ) {
        return $_[1] =~ $RegExp{$_[0]} ;

    } else {
        @_ = $_[1] =~ $RegExp{$_[0]} ;
        # Remove matching apos before returning
        shift unless ( @_ and $_[0] =~ /^[^"']+$/ );
        return @_ ;
    }
}

sub timestamp {
    # Keep timer in the current minute
    my @tt = &gettimeofday() ;
    return sprintf("%.8d > ",
        (( $tt[0] - $TT[0] ) * 1_000_000 + ( $tt[1] - $TT[1] )) % 60_000_000 );
}

sub GetTmpFile {
    return $SERVICE_TMP . '/' . $_[0] ;
}

sub TakeComLocking {
    my $fh = shift ;
    my $locked = 0 ;

    if (defined($fh)) {
        # Try non blocking exclusive lock
        $locked = flock( $fh, LOCK_EX | LOCK_NB );
        # Else try blocking one
        $locked = flock( $fh, LOCK_EX ) unless ( $locked );

        &UPSTAT($locked?'GOOD-COMLOCKING':'BAD-COMLOCKING');
    }

    return $locked ;
}

sub ReleaseComLocking {
    my $fh = shift or return 0 ;
    flock( $fh, LOCK_UN );
}

1;