changed all instances of FileHandle to IO::File

[spider.git] / perl / DXMsg.pm

diff --git a/perl/DXMsg.pm b/perl/DXMsg.pm
index 39bd3065ab57e0fd3e4af2550d41107c6877b842..13af2cc02eac81e6bb85369add0fa39b3ce4a75e 100644 (file)
--- a/perl/DXMsg.pm
+++ b/perl/DXMsg.pm
@@ -11,6 +11,7 @@
 #
 # PC28 field 11 is the RR required flag
 # PC28 field 12 is a VIA routing (ie it is a node call) 
+#
 
 package DXMsg;
 
@@ -25,7 +26,8 @@ use DXProtVars;
 use DXProtout;
 use DXDebug;
 use DXLog;
-use FileHandle;
+use IO::File;
+use Fcntl;
 use Carp;
 
 use strict;
@@ -66,6 +68,13 @@ $forwardfn = "$msgdir/forward.pl";  # the forwarding table
                  keep => '0,Keep this?,yesno',
                 );
 
+sub DESTROY
+{
+       my $self = shift;
+       undef $self->{lines};
+       undef $self->{gotit};
+}
+
 # allocate a new object
 # called fromnode, tonode, from, to, datetime, private?, subject, nolinesper  
 sub alloc                  
@@ -75,7 +84,7 @@ sub alloc
        $self->{msgno} = shift;
        my $to = shift;
        #  $to =~ s/-\d+$//o;
-       $self->{to} = $to;
+       $self->{to} = ($to eq $main::mycall) ? $main::myalias : $to;
        my $from = shift;
        $from =~ s/-\d+$//o;
        $self->{from} = uc $from;
@@ -252,7 +261,7 @@ sub process
                        $f[3] =~ s/^\///o;   # remove the leading /
                        $f[3] = lc $f[3];       # to lower case;
                        dbg('msg', "incoming file $f[3]\n");
-                       last SWITCH if $f[3] =~ /^(perl|cmd|local|src|lib|include|sys|msg|connect)/; # prevent access to executables
+                       $f[3] = 'packclus/' . $f[3] unless $f[3] =~ /^packclus\//o;
                        
                        # create any directories
                        my @part = split /\//, $f[3];
@@ -322,7 +331,7 @@ sub store
        if ($ref->{file}) {                     # a file
                dbg('msg', "To be stored in $ref->{to}\n");
                
-               my $fh = new FileHandle "$ref->{to}", "w";
+               my $fh = new IO::File "$ref->{to}", "w";
                if (defined $fh) {
                        my $line;
                        foreach $line (@{$lines}) {
@@ -342,7 +351,7 @@ sub store
                dbg('msg', "To be stored in $fn\n");
                
                # now save the file, overwriting what's there, YES I KNOW OK! (I will change it if it's a problem)
-               my $fh = new FileHandle "$fn", "w";
+               my $fh = new IO::File "$fn", "w";
                if (defined $fh) {
                        my $rr = $ref->{rrreq} ? '1' : '0';
                        my $priv = $ref->{private} ? '1': '0';
@@ -411,7 +420,7 @@ sub read_msg_header
        my @f;
        my $size;
        
-       $file = new FileHandle;
+       $file = new IO::File;
        if (!open($file, $fn)) {
                print "Error reading $fn $!\n";
                return undef;
@@ -456,7 +465,7 @@ sub read_msg_body
        my $fn = filename($msgno);
        my @out;
        
-       $file = new FileHandle;
+       $file = new IO::File;
        if (!open($file, $fn)) {
                print "Error reading $fn $!\n";
                return undef;
@@ -528,9 +537,10 @@ sub queue_msg
                        my $noderef;
                        foreach $noderef (@nodelist) {
                                next if $noderef->call eq $main::mycall;
-                               next if $noderef->isolate;               # maybe add code for stuff originated here?
                                next if grep { $_ eq $noderef->call } @{$ref->{gotit}};
-                               next if DXUser->get( ${$ref->{gotit}}[0] )->isolate;  # is the origin isolated?
+                               next unless $ref->forward_it($noderef->call);           # check the forwarding file
+                               # next if $noderef->isolate;               # maybe add code for stuff originated here?
+                               # next if DXUser->get( ${$ref->{gotit}}[0] )->isolate;  # is the origin isolated?
                                
                                # if we are here we have a node that doesn't have this message
                                $ref->start_msg($noderef) if !get_busy($noderef->call)  && $noderef->state eq 'normal';
@@ -613,7 +623,7 @@ sub next_transno
        my $fn = "$msgdir/$name";
        my $msgno;
        
-       my $fh = new FileHandle;
+       my $fh = new IO::File;
        if (sysopen($fh, $fn, O_RDWR|O_CREAT, 0666)) {
                $fh->autoflush(1);
                $msgno = $fh->getline;
@@ -632,7 +642,7 @@ sub next_transno
 # initialise the message 'system', read in all the message headers
 sub init
 {
-       my $dir = new FileHandle;
+       my $dir = new IO::File;
        my @dir;
        my $ref;
 
@@ -816,6 +826,39 @@ sub load_badmsg
        return @out;
 }
 
+#
+# forward that message or not according to the forwarding table
+# returns 1 for forward, 0 - to ignore
+#
+
+sub forward_it
+{
+       my $ref = shift;
+       my $call = shift;
+       my $i;
+       
+       for ($i = 0; $i < @forward; $i += 5) {
+               my ($sort, $field, $pattern, $action, $bbs) = @forward[$i..($i+4)]; 
+               my $tested;
+               
+               # are we interested?
+               last if $ref->{private} && $sort ne 'P';
+               last if !$ref->{private} && $sort ne 'B';
+               
+               # select field
+               $tested = $ref->{to} if $field eq 'T';
+               $tested = $ref->{from} if $field eq 'F';
+               $tested = $ref->{origin} if $field eq 'O';
+               $tested = $ref->{subject} if $field eq 'S';
+
+               if (!$pattern || $tested =~ m{$pattern}i) {
+                       return 0 if $action eq 'I';
+                       return 1 if !$bbs || grep $_ eq $call, @{$bbs};
+               }
+       }
+       return 0;
+}
+
 no strict;
 sub AUTOLOAD
 {