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

Last change on this file since 3 was 3, checked in by guillaume, 16 years ago
  • AUTHORS: Ajout des différents contributeurs
  • COPYING: Ajout de la licence GPL v3
  • a2p: Préparation des sources pour leur publication sous GPL
  • Property svn:keywords set to Id
File size: 13.7 KB
Line 
1#
2# Copyright (c) 2004-2007 - Consultas, PKG.fr
3#
4# This file is part of A2P.
5#
6# A2P is free software; you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation; either version 2 of the License, or
9# (at your option) any later version.
10#
11# A2P is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with A2P; if not, write to the Free Software
18# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
19#
20# $Id: Tools.pm 3 2007-10-18 16:20:19Z guillaume $
21#
22# Some usefull subfunctions
23#
24
25package A2P::Tools;
26
27use strict;
28use integer;
29use Fcntl;
30use Errno qw( EINTR EACCES EAGAIN );
31use Encode 'from_to';
32use Fcntl qw(
33    :flock
34    O_CREAT O_RDWR F_GETLK F_SETLK F_SETLKW F_WRLCK F_UNLCK SEEK_SET
35    );
36use IO::Handle ;
37use DB_File ;
38use Time::HiRes qw( tv_interval gettimeofday usleep ) ;
39use A2P::Globals;
40use A2P::Syslog;
41
42BEGIN {
43    use Exporter ();
44    our ( $VERSION , @ISA , @EXPORT_OK );
45
46    $VERSION = sprintf "%s", q$Rev: 994 $ =~ /(\d[0-9.]+)\s+/ ;
47
48    @ISA = qw(Exporter);
49    @EXPORT_OK = qw(    &debugbuffer  &compute     &mychomp  &FreeSharedList
50                        &FcntlLocked  &getrusage   &ShortID  &WaitFcntlLocked
51                        &SharedList   &myreadline  &ms       &FcntlUnlocked
52                    );
53}
54our $VERSION ;
55
56sub mychomp( \$ ) {
57    my $buffer = shift ;
58    my $ret = 0 ;
59
60    $ret = chomp $$buffer ;
61
62    if ( ord( substr( $$buffer , -1 , 1 )) == 0x0D ) {
63        $$buffer = substr( $$buffer , 0 , length( $$buffer )-1 );
64        $ret ++;
65    }
66
67    # Strip from last spaces unless argument provided
68    while ( ! @_ and ord( substr( $$buffer , -1 , 1 )) == 0x40 ) {
69        $$buffer = substr( $$buffer , 0 , length( $$buffer )-1 );
70        $ret ++;
71    }
72
73    return $ret ;
74}
75
76sub myreadline(\*;\$) {
77    my ( $file , $buffer ) = @_ ;
78    my ( $char , $long , $ret ) = ( " " , 1 , 0 );
79
80    while ( $long and $char ne chr(0x0A) and ! eof($file)) {
81        $ret += $long = read( $file , $char , 1 );
82        $$buffer .= $char ;
83    }
84
85    return $ret ;
86}
87
88my $bugindex = '  0 1 2 3  4 5 6 7  8 9 A B  C D E F' ;
89
90sub debugbuffer {
91    my $buffer = shift ;
92    my $kind   = shift ;
93
94    # Force kind flag if no conversion is required
95    $kind = $TO_CONVERT unless ($DO_CONVERT);
96
97    # Will return an array of RAW buffer conversion
98    my $ref = [] ;
99
100    return $ref
101        if ( length( $buffer ) == 0 or $NO_SYSLOG_DEBUG ) ;
102
103    undef $kind
104        if ( defined($kind) and $kind ne "NO TEXT" );
105
106    if ( defined( $kind ) ) {
107        &Debug( " DEBUGBUFFER:$bugindex" ) ;
108        push @{$ref}, $bugindex ;
109
110    } else {
111        &Debug( " DEBUGBUFFER:$bugindex |      EBCDIC      |      ASCII       |" );
112        push @{$ref}, "$bugindex |      EBCDIC      |      ASCII       |" ;
113    }
114
115    my ( $len , $max ) = ( 16 , length( $buffer ) );
116
117    my $index = 0 ;
118    my ( $hex , $ebcdic , $ascii );
119
120INNER:
121    while ( $index < $max ) {
122OUTER:
123        while ( $index%$len < $len ) {
124            $hex = $ebcdic = $ascii = "" if ( $index%$len == 0 );
125
126            my $char = substr( $buffer , $index , 1 ) ;
127            my $chr  = ord( $char ) ;
128            $hex .= " " if ( $index%4 == 0 ) ;
129            $hex .= sprintf( "%02x" , $chr ) ;
130            unless (defined( $kind )) {
131                $ebcdic .= ( $chr & 127 < 32 ) ? "." : $char ;
132                &from_to( $char , $FROM_CONVERT , $TO_CONVERT );
133                $ascii .= ( ord($char) & 127 < 32 )? "." : $char ;
134            }
135            $index ++ ;
136            last OUTER if ( $index%$len == 0 );
137            last INNER if ( $index > $max );
138        }#OUTER
139
140        if ( defined( $kind ) ) {
141            &Debug( "DEBUGBUFFER:$hex" );
142            push @{$ref}, $hex ;
143
144        } else {
145            &Debug( "DEBUGBUFFER:$hex | $ebcdic | $ascii |" );
146            push @{$ref}, "$hex | $ebcdic | $ascii |" ;
147        }
148    }#INNER
149
150    if ( $index%$len ) {
151        unless (defined( $kind )) {
152            my $sp = $len - ($index%$len) ;
153            $hex .= " " x (2*$sp + $sp/4 ) . " | $ebcdic" . " " x $sp .
154                "  | $ascii" . " " x $sp . "  |";
155        }
156        &Debug( "DEBUGBUFFER:$hex" );
157        push @{$ref}, $hex ;
158    }
159
160    # Return RAW array to eventually be logged later as information after
161    # and error (exemple: bad format of PTX field)
162    return $ref ;
163}
164
165################################################
166# File locking direct system call
167# Wait a filehandle as argument
168
169# "s!s!l!l!l!" for 32bits env... for 64bits env, should use "s!s!QQl!"
170my $arch = qx/uname -p/ ;
171chomp $arch ;
172my $pack_string = $arch !~ /64$/ ? "s!s!l!l!l!" : "s!s!QQl!" ;
173my $write_lock_flock_struct = pack $pack_string, F_WRLCK, SEEK_SET, 0, 0, 0 ;
174sub FcntlLocked {
175    &UPSTAT('FCNTLLOCKED-CALL');
176    my $handle = shift ;
177
178    &Debug("Handle = $handle ".ref($handle)) if (defined($handle));
179
180    unless (ref($handle) =~ /^GLOB/) {
181        &Error("Can't only try locking defined handles");
182        return 0 ;
183    }
184
185    # Try to lock the file handle
186    fcntl( $handle, F_SETLK, $write_lock_flock_struct )
187        or &Debug("Can't lock handle with fcntl call: $! ".int($!)), return 0;
188
189    return 1;
190}
191
192sub WaitFcntlLocked {
193    &UPSTAT('WAITFCNTLLOCKED-CALL');
194    my $handle = shift ;
195
196    unless (ref($handle) =~ /^GLOB/) {
197        &Error("Can't only try locking defined handles");
198        return 0 ;
199    }
200
201    $! = 0 ;
202    # Try to lock the file handle retrying when interrupted
203    while ( ! fcntl( $handle, F_SETLKW, $write_lock_flock_struct )) {
204        last unless ( $! == EINTR );
205        $! = 0 ;
206    }
207
208    if ($!) {
209        &Debug("Can't waiting lock on handle with fcntl call: $! ".int($!));
210        return 0 ;
211    }
212
213    return 1;
214}
215
216# "s!s!l!l!l!" for 32bits env... for 64bits env, should use "s!s!QQl!"
217my $unlock_flock_struct = pack $pack_string, F_UNLCK, 0, 0, 0, 0 ;
218sub FcntlUnlocked {
219    &UPSTAT('FCNTLUNLOCKED-CALL');
220    my $handle = shift ;
221
222    unless (ref($handle) =~ /^GLOB/) {
223        &Error("Can't only try unlocking defined handles");
224        return 0 ;
225    }
226
227    $! = 0 ;
228
229    # Try to lock the file handle
230    fcntl( $handle, F_SETLK, $unlock_flock_struct )
231        or &Debug("Can't unlock handle with fcntl call: $! ".int($!)), return 0;
232
233    &Debug("Current system error: $! ".int($!)) if $! ;
234    return 1;
235}
236
237sub __NR_getrusage () { 77 }   # Value taken from <asm/unistd.h>
238
239################################################
240# getrusage system call
241sub getrusage {
242    my $who = shift || 0 ;
243    my $rusage = " " x ( 18 * 4 ) ; # Size of struc rusage
244    my @struct ;
245
246    if ( $who == 0 ) {
247        &Debug("Getting rusage for T$$");
248
249    } elsif ($who == -1 ) {
250        &Debug("Getting rusage for T$$ children");
251
252    } else {
253        &Error("Can't get rusage for $who");
254        return ();
255    }
256
257    $! = 0 ;
258    my $Ret = syscall( __NR_getrusage , $who , $rusage );
259    (&Debug("Can't getrusage with fcntl call: $!"), return ()) if ($Ret == -1);
260
261    #struct timeval (from bits/time.h)
262    #  {
263    #    __time_t tv_sec;       /* Seconds.  */       --> long int
264    #    __suseconds_t tv_usec; /* Microseconds.  */  --> long int
265    #  };
266
267    my (      #struct rusage { (from man getrusage)
268              #struct timeval ru_utime; /* user time used */
269                $ru_utime__tv_sec, $ru_utime__tv_usec,
270              #struct timeval ru_stime; /* system time used */
271                $ru_stime__tv_sec, $ru_stime__tv_usec,
272        $ru_maxrss,     # long   ru_maxrss;   /* maximum resident set size */
273        $ru_ixrss,      # long   ru_ixrss;    /* integral shared memory size */
274        $ru_idrss,      # long   ru_idrss;    /* integral unshared data size */
275        $ru_isrss,      # long   ru_isrss;    /* integral unshared stack size */
276        $ru_minflt,     # long   ru_minflt;   /* page reclaims */
277        $ru_majflt,     # long   ru_majflt;   /* page faults */
278        $ru_nswap,      # long   ru_nswap;    /* swaps */
279        $ru_inblock,    # long   ru_inblock;  /* block input operations */
280        $ru_oublock,    # long   ru_oublock;  /* block output operations */
281        $ru_msgsnd,     # long   ru_msgsnd;   /* messages sent */
282        $ru_msgrcv,     # long   ru_msgrcv;   /* messages received */
283        $ru_nsignals,   # long   ru_nsignals; /* signals received */
284        $ru_nvcsw,      # long   ru_nvcsw;    /* voluntary context switches */
285        $ru_nivcsw      # long   ru_nivcsw;   /* involuntary context switches */
286    );
287
288    @struct = unpack( "l!18" , $rusage );
289
290    return @struct ;
291}
292
293#========================================================================
294# Private table to compute identifier
295my @cons = split(//,'bcdfgjklmnprstvxz');
296my @voy  = split(//,'aeiou' );
297my ( $mC , $mV ) = ( scalar(@cons) , scalar(@voy) ) ;
298#========================================================================
299sub ShortID {
300    my $length = shift || 4 ;
301    my $id = "" ;
302    $id .= $length % 2 ? $cons[rand($mC)] : $voy[rand($mV)] while ( $length -- );
303    return $id ;
304}
305
306sub compute {
307    my ( $bufref , $pos , $long ) = @_ ;
308    my ( $ret , $mul ) = ( 0 , 1 ) ;
309
310    return &Error("[DEV] Unsupported use of 'compute' tool: long $long > 4")
311        if ( $long > 4 );
312
313    return &Error("[DEV] Unsupported use of 'compute' tool: long $long < 0")
314        if ( $long < 0 );
315
316    &Debug("Buffer is not as long as expected")
317        if ( $pos + $long > length( $$bufref ) );
318
319    # Avoid infinite loop if long is negative
320    while ( $long--  ) {
321        $ret += ord( substr( $$bufref , $pos + $long , 1 ) ) * $mul ;
322        $mul <<= 8 ;
323    }
324
325    return $ret ;
326}
327
328#========================================================================
329# SharedList is a facility to shared lists between processes
330my %lists = (
331    # Key = name of the list -> is also used to tie the list
332    # Value = Array ref: [
333    #   Array ref of the tied list
334    #   Array ref to a list of values to push in tied list
335    #   FileHandle of the locking file if tied or 0
336    # ]
337    ) ;
338sub SharedList {
339    # Return an array ref to which push values
340    my $list = shift || 'shared_list_of_lost_values' ;
341    my $List = uc($list) ;
342
343    my $force = shift || 0 ;
344
345    $! = 0 ;
346
347    # The shared list should better be in shared memory
348    my $base = $SHMDIR . '/.shared-list-' . $list ;
349
350    # 1. Initiliaze hash if not done in our processus
351    unless (exists($lists{$list})) {
352        $lists{$list} = [ [], [], 0 ] ;
353    }
354
355    # 2. Get the array refs for that list
356    my ( $tied, $kept, $fh ) = @{$lists{$list}} ;
357    &Debug("FileHandle not previously released for $list list locking")
358        if ($fh);
359
360    # 3. Try to open files and tie list and return $kept ref on any error
361    # 3.1. Open LCK file
362    undef $fh ;
363    unless (open($fh, '>', $base.'.LCK')) {
364        &UPSTAT('SHARED-LIST-OPEN-ERRNO-'.int($!));
365        &Debug("Can't open $base.LCK lock file: $!");
366        return $kept ;
367    }
368
369    # 3.2. Lock file without blocking
370    unless (flock($fh, $force ? LOCK_EX : LOCK_EX | LOCK_NB)) {
371        &UPSTAT('SHARED-LIST-LOCK-ERRNO-'.int($!));
372        # Only log on other error than ressource is busy (EAGAIN)
373        &Debug("Can't lock $list list: $!") unless ($! == EAGAIN);
374        close ($fh);
375        return $kept ;
376    }
377    &TIMESTAT('SHARED-LIST-LOCKED-'.$List);
378    &TIMESTAT('SHARED-LIST-GET-TIED-'.$List);
379
380    # Keep internal statistics on DB_File size
381    &MAXSTAT('SHARED-LIST-FILE-SIZE-'.$List,(-s $base));
382
383    # 3.3. Tie the list
384    my @tied ;
385    unless (tie @tied, 'DB_File', $base, O_CREAT|O_RDWR, oct(660), $DB_RECNO ) {
386        &UPSTAT('SHARED-LIST-TIE-ERRNO-'.int($!));
387        &Debug("Can't tie $list list: $!");
388        &TIMESTAT('SHARED-LIST-GET-TIED-'.$List);
389        flock($fh, LOCK_UN);
390        &TIMESTAT('SHARED-LIST-LOCKED-'.$List);
391        close ($fh);
392        return $kept ;
393    }
394    &TIMESTAT('SHARED-LIST-GET-TIED-'.$List);
395    &TIMESTAT('SHARED-LIST-TIED-'.$List);
396
397    # 3.4. File is locked and tied, keep this information
398    $lists{$list}->[0] = \@tied ;
399    $lists{$list}->[2] = $fh ;
400    &UPSTAT('SHARED-LIST-TIED-'.$List);
401
402    # 4. Inject now kept values
403    if (@{$kept}) {
404        &UPSTAT('SHARED-LIST-INJECT-KEPT-'.$List);
405        &MAXSTAT('SHARED-LIST-KEPT-'.$List,scalar(@{$kept}));
406        push @tied, @{$kept};
407        # Keep the kept reference as empty array
408        $lists{$list}->[1] = [] ;
409    }
410
411    # 5. Return the ref to the tied array
412    return \@tied ;
413}
414
415sub FreeSharedList {
416    # Free a shared list
417    my $list = shift || 'shared_list_of_lost_values' ;
418    my $List = uc($list) ;
419
420    # 1. Initiliaze hash if not done in our processus
421    unless (exists($lists{$list})) {
422        &Debug("Can't free not shared $list list");
423        return 0 ;
424    }
425
426    # 2. Get the array refs for that list
427    my ( $tied, $kept, $fh ) = @{$lists{$list}} ;
428
429    # 3. Untie the list is really tied and locked
430    if ($fh) {
431        my $tied_array = tied(@{$tied}) ;
432        if (defined($tied_array)) {
433            &UPSTAT('SHARED-LIST-SYNC-'.$List);
434            $tied_array->sync ;
435            undef $tied_array ;
436        }
437
438        # Untie the array
439        untie @{$tied} ;
440        &TIMESTAT('SHARED-LIST-TIED-'.$List);
441
442        # Unlock the lock file
443        flock($fh, LOCK_UN);
444        &TIMESTAT('SHARED-LIST-LOCKED-'.$List);
445        close ($fh);
446        $lists{$list}->[2] = 0 ;
447        &UPSTAT('SHARED-LIST-UNTIED-'.$List);
448    }
449}
450
451sub ms {
452    # Avoid use of integer to support large integer on 32 bits platforms
453    no integer ;
454
455    # Get current millisecond
456    my ( $sec , $usec ) = &gettimeofday() ;
457
458    # If a parameter is defined, we want to add the seconds with it. It could be
459    # a negative number to get a timer to compare
460    $sec += shift if @_ ;
461
462    return int( $sec * 1000 + $usec / 1000 ) ;
463}
464
4651;
Note: See TracBrowser for help on using the repository browser.