src/Shm.pl

   1 #
   2 #   Shm.pl: Shared Memory stuff.
   3 #    Author: dms
   4 #   Version: 20000201
   5 #   Created: 20000124
   6 #
   7
   8 # use strict;   # TODO
   9
  10 use POSIX qw(_exit);
  11
  12 my %shm_keys;
  13
  14 sub openSHM {
  15     my $IPC_PRIVATE = 0;
  16     my $size        = 2000;
  17
  18     if ( &IsParam('noSHM') ) {
  19         &status('Shared memory: Disabled. WARNING: bot may become unreliable');
  20         return 0;
  21     }
  22
  23     if ( defined( $_ = shmget( $IPC_PRIVATE, $size, 0777 ) ) ) {
  24         &status("Created shared memory (shm) key: [$_]");
  25         $shm_keys{$_} = {
  26             time     => time,
  27             accessed => 0,
  28             key      => $_,
  29         };
  30         return $_;
  31     }
  32     else {
  33         &ERROR('openSHM: failed.');
  34         &ERROR('Please delete some shared memory with ipcs or ipcrm.');
  35         exit 1;
  36     }
  37 }
  38
  39 sub closeSHM {
  40     my ($key) = @_;
  41     my $IPC_RMID = 0;
  42
  43     return '' if ( !defined $key );
  44
  45     &shmFlush();
  46     &status("Closed shared memory (shm) key: [$key]");
  47     return shmctl( $key, $IPC_RMID, 0 );
  48 }
  49
  50 sub shmRead {
  51     my ($key)    = @_;
  52     my $position = 0;
  53     my $size     = 3 * 80;
  54     my $retval   = '';
  55
  56     return '' if ( &IsParam('noSHM') );
  57
  58     if ( shmread( $key, $retval, $position, $size ) ) {
  59
  60         #&DEBUG("shmRead($key): $retval");
  61         return $retval;
  62     }
  63     else {
  64         &ERROR("shmRead: failed: $!");
  65         if ( exists $shm_keys{$_} ) {
  66             closeSHM($key);
  67         }
  68         ### TODO: if this fails, never try again.
  69         # What use is opening a SHM segment if we're not going to read it?
  70         # &openSHM();
  71         return '';
  72     }
  73 }
  74
  75 sub shmWrite {
  76     my ( $key, $str ) = @_;
  77     my $position = 0;
  78     my $size     = 80 * 3;
  79
  80     return if ( &IsParam('noSHM') );
  81
  82     $shm_keys{$keys}{accessed} = 1;
  83
  84     if ( length($str) > $size ) {
  85         &status("ERROR: length(str) (..)>$size...");
  86         return;
  87     }
  88
  89     if ( length($str) == 0 ) {
  90
  91         # does $size overwrite the whole lot?
  92         # if not, set to 2000.
  93         if ( !shmwrite( $key, '', $position, $size ) ) {
  94             &ERROR("shmWrite: failed: $!");
  95         }
  96         return;
  97     }
  98
  99     my $read = &shmRead($key);
 100     $read =~ s/\0+//g;
 101     if ( $read eq '' ) {
 102         $str = sprintf( '%s:%d:%d: ', $param{ircUser}, $bot_pid, time() );
 103     }
 104     else {
 105         $str = $read . '||' . $str;
 106     }
 107
 108     if ( !shmwrite( $key, $str, $position, $size ) ) {
 109         &DEBUG("shmWrite($key, $str)");
 110         &ERROR("shmWrite: failed: $!");
 111     }
 112 }
 113
 114 ##############
 115 ### Helpers
 116 ###
 117
 118 # Usage: &addForked($name);
 119 # Return: 1 for success, 0 for failure.
 120 sub addForked {
 121     my ($name) = @_;
 122     my $forker_timeout = 360;    # 6mins, in seconds.
 123     $forker = $name;
 124
 125     if ( !defined $name ) {
 126         &WARN('addForked: name == NULL.');
 127         return 0;
 128     }
 129
 130     foreach ( keys %forked ) {
 131         my $n    = $_;
 132         my $time = time() - $forked{$n}{Time};
 133         next unless ( $time > $forker_timeout );
 134
 135         ### TODO: use &time2string()?
 136         &WARN("Fork: looks like we lost '$n', executed $time ago");
 137
 138         my $pid = $forked{$n}{PID};
 139         if ( !defined $pid ) {
 140             &WARN("Fork: no pid for $n.");
 141             delete $forked{$n};
 142             next;
 143         }
 144
 145         if ( $pid == $bot_pid ) {
 146
 147             # don't kill parent, just warn.
 148             &status("Fork: pid == \$bot_pid == \$\$ ($bot_pid)");
 149
 150         }
 151         elsif ( -d "/proc/$pid" ) {    # pid != bot_pid.
 152             &status("Fork: killing $name ($pid)");
 153             kill 9, $pid;
 154         }
 155
 156         delete $forked{$n};
 157     }
 158
 159     my $count = 0;
 160     while ( scalar keys %forked > 1 ) {    # 2 or more == fail.
 161         sleep 1;
 162
 163         if ( $count > 3 ) {                # 3 seconds.
 164             my $list = join( ', ', keys %forked );
 165             if ( defined $who ) {
 166                 &msg( $who, "exceeded allowed forked count (shm $shm): $list" );
 167             }
 168             else {
 169                 &status(
 170 "Fork: I ran too many forked processes :) Giving up $name. Shm: $shm"
 171                 );
 172             }
 173
 174             return 0;
 175         }
 176
 177         $count++;
 178     }
 179
 180     if ( exists $forked{$name} and !scalar keys %{ $forked{$name} } ) {
 181         &WARN("addF: forked{$name} exists but is empty; deleting.");
 182         undef $forked{$name};
 183     }
 184
 185     if ( exists $forked{$name} and scalar keys %{ $forked{$name} } ) {
 186         my $time     = $forked{$name}{Time};
 187         my $continue = 0;
 188
 189         $continue++ if ( $forked{$name}{PID} == $$ );
 190
 191         if ($continue) {
 192             &WARN("hrm.. fork pid == mypid == $$; how did this happen?");
 193
 194         }
 195         elsif ( -d "/proc/$forked{$name}{PID}" ) {
 196             &status('fork: still running; good. BAIL OUT.');
 197             return 0;
 198
 199         }
 200         else {
 201             &WARN('Found dead fork; removing and resetting.');
 202             $continue = 1;
 203         }
 204
 205         if ($continue) {
 206
 207             # NOTHING.
 208
 209         }
 210         elsif ( time() - $time > 900 ) {    # stale fork > 15m.
 211             &status(
 212                 "forked: forked{$name} presumably exited without notifying us."
 213             );
 214
 215         }
 216         else {                              # fresh fork.
 217             &msg( $who,
 218                 "$name is already running " . &Time2String( time() - $time ) );
 219             return 0;
 220         }
 221     }
 222
 223     $forked{$name}{Time} = time();
 224     $forked{$name}{PID}  = $$;
 225     $forkedtime          = time();
 226     $count{'Fork'}++;
 227     return 1;
 228 }
 229
 230 sub delForked {
 231     my ($name) = @_;
 232
 233     return if ( $$ == $bot_pid );
 234
 235     if ( !defined $name ) {
 236         &WARN('delForked: name == NULL.');
 237         POSIX::_exit(0);
 238     }
 239
 240     if ( $name =~ /\.pl/ ) {
 241         &WARN("dF: name is name of source file ($name). FIX IT!");
 242     }
 243
 244     &showProc();    # just for informational purposes.
 245
 246     if ( exists $forked{$name} ) {
 247         my $timestr = &Time2String( time() - $forked{$name}{Time} );
 248         &status("fork: took $timestr for $name.");
 249         &shmWrite( $shm, "DELETE FORK $name" );
 250     }
 251     else {
 252         &ERROR("delForked: forked{$name} does not exist. should not happen.");
 253     }
 254
 255     &status("--- fork finished for '$name' ---");
 256
 257     POSIX::_exit(0);
 258 }
 259
 260 sub shmFlush {
 261     return if ( $$ != $::bot_pid );    # fork protection.
 262
 263     if (@_) {
 264         &ScheduleThis( 15 * 60, 'shmFlush' );    # 15 minutes
 265         return if ( $_[0] eq '2' );
 266     }
 267
 268     my $time;
 269     my $shmmsg = &shmRead($shm);
 270
 271     # remove padded \0's.
 272     $shmmsg =~ s/\0//g;
 273     return if ( length($shmmsg) == 0 );
 274     if ( $shmmsg =~ s/^(\S+):(\d+):(\d+): // ) {
 275         my $n   = $1;
 276         my $pid = $2;
 277         $time = $3;
 278     }
 279     else {
 280         &status("warn: shmmsg='$shmmsg'.");
 281         return;
 282     }
 283
 284     foreach ( split '\|\|', $shmmsg ) {
 285         next if (/^$/);
 286         &VERB( "shm: Processing '$_'.", 2 );
 287
 288         if (/^DCC SEND (\S+) (\S+)$/) {
 289             my ( $nick, $file ) = ( $1, $2 );
 290             if ( exists $dcc{'SEND'}{$who} ) {
 291                 &msg( $nick, 'DCC already active.' );
 292             }
 293             else {
 294                 &DEBUG("shm: dcc sending $2 to $1.");
 295                 $conn->new_send( $1, $2 );
 296                 $dcc{'SEND'}{$who} = time();
 297             }
 298         }
 299         elsif (/^SET FORKPID (\S+) (\S+)/) {
 300             $forked{$1}{PID} = $2;
 301         }
 302         elsif (/^DELETE FORK (\S+)$/) {
 303             delete $forked{$1};
 304         }
 305         elsif (/^EVAL (.*)$/) {
 306             &DEBUG("evaling '$1'.");
 307             eval $1;
 308         }
 309         else {
 310             &DEBUG("shm: unknown msg. ($_)");
 311         }
 312     }
 313
 314     &shmWrite( $shm, '' ) if ( $shmmsg ne '' );
 315 }
 316
 317 1;
 318
 319 # vim:ts=4:sw=4:expandtab:tw=80