view release on metacpan or  search on metacpan

Traffic.pm  view on Meta::CPAN

      $STATS{$TODAY} = { $uid => { hits => 0, bytes => 0 }};
    } 
    # MOVE DATA FROM SHARED MEMORY INTO DBM FILE IF > 1 DAY INFO
    if ((keys %STATS > 1) and (USE_DBM)) { 
      unless (_move_shm_to_dbm($r)) {
        unless (semop($SEMID, pack "s*", 0, -1, SEM_UNDO)) {
          error("unable to release lock: $!");
        }
        return DECLINED;
      }
    }
  }
  $ref = $STATS{$TODAY};
  $$ref{$uid}{hits} += 1;
  $$ref{$uid}{bytes} += $bytes;
  $STATS{$TODAY} = $ref;
  unless (semop($SEMID, pack "s*", 0, -1, SEM_UNDO)) {
    error("unable to release lock: $!");
    return DECLINED;
  }
  OK; 
}

sub handler { shift->post_connection(\&logger) }

1;

__END__

sub error {
  my($error, $package, $line, $r);

  if (@_) {
    ($package, $line) = (caller)[0,2];
    $ERRMSG = join('', "$package [$line]: ", @_);
    eval { $r = Apache->request };
    unless ($@) {
      $r->log_error($ERRMSG);
    }
    return undef;
  } else {
    return $ERRMSG;
  }
}

sub fetch {
  my($start, $end, $wantuid, $all, @users) = @_;
  my(%hash, %uids, $uid, $db_obj, %db, $ref);

  $start = timegm(0, 0, 0, (localtime($start))[3..5]); # START OF DAY
  $end   = timegm(0, 0, 0, (localtime($end))[3..5]);
  tie(%STATS, 'IPC::Shareable', SHMKEY, { create => 'no' })
    or return error("unable to tie to shared memory: $!");
  if (-e DBPATH) { # DBM FILE WON'T EXIST UNTIL HANDLER HAS RUN FOR > 1 DAY
    $db_obj = tie %db, 'DB_File', DBPATH, O_RDONLY, MODE
      or return error("unable to open dbm file: $!");
  }
  @users = () if ($all);
  foreach(@users) {
    # LOOKUP THE USERNAME IF WE WERE PASSED A UID
    $_ = (getpwuid $_)[0] || $_ if ($_ =~ /^\d+$/);
    # LOOKUP THE UID
    (defined($uid = (getpwnam $_)[2])) || ($uid = $_);
    # STORE THE USERNAME INDEXED BY UID (unless $wantuid is true)
    $uids{$uid} = ($wantuid ? $uid : $_);
  }
  while($start <= $end) {
    unless ($all) {
      foreach(keys %uids) { # MAKE SURE WE RETURN VALUES FOR EVERY USER
        $hash{$start}{ $uids{$_} } = { bytes => 0, hits => 0 };
      }
    }
    if (exists $STATS{$start}) {
      $ref = $STATS{$start};
    } elsif ((defined $db_obj) and (exists $db{$start})) {
      $ref = thaw($db{$start});
    } else {
      $start += ONEDAY;
      next;
    }
    if ($all) {
      foreach(keys %$ref) {
        unless (defined $uids{$_}) {
          $uids{$_} = $_;
          if ((/^\d+$/) and (! $wantuid)) {
            $uids{$_} = (getpwuid $_)[0] || $_;
          }
        }
      }
    } 
    foreach(keys %uids) {
      next unless (exists $ref->{$_});
      $hash{$start}{ $uids{$_} }{bytes} = $ref->{$_}{bytes};
      $hash{$start}{ $uids{$_} }{hits}  = $ref->{$_}{hits};
    }
    $start += ONEDAY;
  }
  return \%hash;
}

sub remove {
  my($start, $end) = @_;
  my(%db, $db_obj);

  $start = timegm(0, 0, 0, (localtime($start))[3..5]); # START OF DAY
  $end   = timegm(0, 0, 0, (localtime($end))[3..5]);
  tie(%STATS, 'IPC::Shareable', SHMKEY, { create => 'no' })
    or return error("unable to tie to shared memory");
  if (-e DBPATH) {
    $db_obj = tie %db, 'DB_File', DBPATH, O_RDWR, MODE
      or return error("unable to tie dbm file: $!");
  }
  (defined($SEMID = semget(SEMKEY, 1, MODE))) 
    or return error("unable to obtain semaphore for locking: $!");
  semop($SEMID, pack "s*", 0, 0, 0, 0, 1, SEM_UNDO)
    or return error("unable to obtain lock: $!");
  while($start <= $end) {
    delete $STATS{$start};
    delete $db{$start} if (defined $db_obj);
    $start += ONEDAY;
  }
  $db_obj->sync if (defined $db_obj);
  semop($SEMID, pack "s*", 0, -1, SEM_UNDO)
    or return error("unable to release lock: $!");
  1;
}

# MOVE ALL DATA IN SHARED MEMORY INTO DBM FILE, _EXCEPT_ FOR CURRENT DAY
sub _move_shm_to_dbm {
  my $r = shift;
  my(%db);

  tie %db, 'DB_File', DBPATH, O_CREAT | O_RDWR, MODE
    or return error("unable to tie dbm file: $!");
  foreach (keys %STATS) {
    next if ($_ == $TODAY);
    $db{$_} = freeze($STATS{$_})
      or return error("error writing dbm: $!");
    delete $STATS{$_};
  }
  untie %db;
  1;
}

=head1 NAME