| [3] | 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 | |
|---|
| 25 | package A2P::Tools; |
|---|
| 26 | |
|---|
| 27 | use strict; |
|---|
| 28 | use integer; |
|---|
| 29 | use Fcntl; |
|---|
| 30 | use Errno qw( EINTR EACCES EAGAIN ); |
|---|
| 31 | use Encode 'from_to'; |
|---|
| 32 | use Fcntl qw( |
|---|
| 33 | :flock |
|---|
| 34 | O_CREAT O_RDWR F_GETLK F_SETLK F_SETLKW F_WRLCK F_UNLCK SEEK_SET |
|---|
| 35 | ); |
|---|
| 36 | use IO::Handle ; |
|---|
| 37 | use DB_File ; |
|---|
| 38 | use Time::HiRes qw( tv_interval gettimeofday usleep ) ; |
|---|
| 39 | use A2P::Globals; |
|---|
| 40 | use A2P::Syslog; |
|---|
| 41 | |
|---|
| 42 | BEGIN { |
|---|
| 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 | } |
|---|
| 54 | our $VERSION ; |
|---|
| 55 | |
|---|
| 56 | sub 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 | |
|---|
| 76 | sub 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 | |
|---|
| 88 | my $bugindex = ' 0 1 2 3 4 5 6 7 8 9 A B C D E F' ; |
|---|
| 89 | |
|---|
| 90 | sub 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 | |
|---|
| 120 | INNER: |
|---|
| 121 | while ( $index < $max ) { |
|---|
| 122 | OUTER: |
|---|
| 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!" |
|---|
| 170 | my $arch = qx/uname -p/ ; |
|---|
| 171 | chomp $arch ; |
|---|
| 172 | my $pack_string = $arch !~ /64$/ ? "s!s!l!l!l!" : "s!s!QQl!" ; |
|---|
| 173 | my $write_lock_flock_struct = pack $pack_string, F_WRLCK, SEEK_SET, 0, 0, 0 ; |
|---|
| 174 | sub 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 | |
|---|
| 192 | sub 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!" |
|---|
| 217 | my $unlock_flock_struct = pack $pack_string, F_UNLCK, 0, 0, 0, 0 ; |
|---|
| 218 | sub 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 | |
|---|
| 237 | sub __NR_getrusage () { 77 } # Value taken from <asm/unistd.h> |
|---|
| 238 | |
|---|
| 239 | ################################################ |
|---|
| 240 | # getrusage system call |
|---|
| 241 | sub 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 |
|---|
| 295 | my @cons = split(//,'bcdfgjklmnprstvxz'); |
|---|
| 296 | my @voy = split(//,'aeiou' ); |
|---|
| 297 | my ( $mC , $mV ) = ( scalar(@cons) , scalar(@voy) ) ; |
|---|
| 298 | #======================================================================== |
|---|
| 299 | sub 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 | |
|---|
| 306 | sub 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 |
|---|
| 330 | my %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 | ) ; |
|---|
| 338 | sub 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 | |
|---|
| 415 | sub 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 | |
|---|
| 451 | sub 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 | |
|---|
| 465 | 1; |
|---|
