src/Shm.pl

   1 #
   2 #   Shm.pl: Shared Memory stuff.
   3 #    Author: dms
   4 #   Version: 20000201
   5 #   Created: 20000124
   6 #
   7
   8 if (&IsParam("useStrict")) { use strict; }
   9
  10 sub openSHM {
  11     my $IPC_PRIVATE = 0;
  12     my $size = 2000;
  13
  14     if (defined( $_ = shmget($IPC_PRIVATE, $size, 0777) )) {
  15         &status("Created shared memory (shm) key: [$_]");
  16         return $_;
  17     } else {
  18         &ERROR("openSHM: failed.");
  19         &ERROR("Please delete some shared memory with ipcs or ipcrm.");
  20         exit 1;
  21     }
  22 }
  23
  24 sub closeSHM {
  25     my ($key) = @_;
  26     my $IPC_RMID = 0;
  27
  28     return '' if (!defined $key);
  29
  30     &shmFlush();
  31     &status("Closed shared memory (shm) key: [$key]");
  32     return shmctl($key, $IPC_RMID, 0);
  33 }
  34
  35 sub shmRead {
  36     my ($key) = @_;
  37     my $position = 0;
  38     my $size = 3*80;
  39     my $retval = '';
  40
  41     if (shmread($key,$retval,$position,$size)) {
  42         return $retval;
  43     } else {
  44         &ERROR("shmRead: failed: $!");
  45         return '';
  46     }
  47 }
  48
  49 sub shmWrite {
  50     my ($key, $str) = @_;
  51     my $position = 0;
  52     my $size = 80*3;
  53
  54     # NULL hack.
  55     ### TODO: create shmClear to deal with this.
  56     if ($str !~ /^$/) {
  57         my $read = &shmRead($key);
  58         $read =~ s/\0+//g;
  59         $str = $read ."||". $str if ($read ne "");
  60     }
  61
  62     if (!shmwrite($key,$str,$position,$size)) {
  63         &ERROR("shmWrite: failed: $!");
  64     }
  65 }
  66
  67 #######
  68 # Helpers
  69 #
  70
  71 # Usage: &addForked($name);
  72 # Return: 1 for success, 0 for failure.
  73 sub addForked {
  74     my ($name) = @_;
  75     my $forker_timeout  = 360;  # 6mins, in seconds.
  76     if (!defined $name) {
  77         &WARN("addForked: name == NULL.");
  78         return 0;
  79     }
  80
  81     foreach (keys %forked) {
  82         my $time = time() - $forked{$_}{Time};
  83         next unless ($time > $forker_timeout);
  84
  85         ### TODO: use &time2string()?
  86         &WARN("Fork: looks like we lost '$_', executed $time ago.");
  87         delete $forked{$_};
  88     }
  89
  90     my $count = 0;
  91     while (scalar keys %forked > 2) {   # 2 or more == fail.
  92         sleep 1;
  93
  94         if ($count > 3) {       # 3 seconds.
  95             my $list = join(', ', keys %forked);
  96             if (defined $who) {
  97                 &msg($who, "already running ($list) => exceeded allowed forked processes count (1?).");
  98             } else {
  99                 &status("Fork: I ran too many forked processes :) Giving up $name.");
 100             }
 101             return 0;
 102         }
 103
 104         $count++;
 105     }
 106
 107     if (exists $forked{$name}) {
 108         my $time = $forked{$name}{Time};
 109         if (-d "/proc/$forked{$name}{PID}") {
 110             &status("fork: still running; good. BAIL OUT.");
 111         } else {
 112             &status("fork: lost the fork? REMOVE IT!");
 113         }
 114
 115         if (time() - $time > 900) {     # stale fork > 15m.
 116             &status("forked: forked{$name} presumably exited without notifying us.");
 117             $forked{$name}{Time} = time();
 118             return 1;
 119         } else {                                # fresh fork.
 120             &msg($who, "$name is already running ". &Time2String(time() - $forked{$name}));
 121             return 0;
 122         }
 123     } else {
 124         $forked{$name}{Time}    = time();
 125         $forkedtime             = time();
 126         $count{'Fork'}++;
 127         return 1;
 128     }
 129 }
 130
 131 sub delForked {
 132     my ($name) = @_;
 133     if (!defined $name) {
 134         &WARN("delForked: name == NULL.");
 135         return 0;
 136     }
 137
 138     if (exists $forked{$name}) {
 139         my $timestr = &Time2String(time() - $forked{$name}{Time});
 140         &status("fork: took $timestr for $name.");
 141         &shmWrite($shm,"DELETE FORK $name");
 142         return 1;
 143     } else {
 144         &ERROR("delForked: forked{$name} does not exist. should not happen.");
 145         return 0;
 146     }
 147 }
 148
 149 1;