1{ 2use strict; 3no strict "subs"; 4 5our $VERSION = "0.06"; 6 7# declare subs 8sub PVT(); sub CRA(); sub RCV(); sub SNT(); sub ATT(); sub TRS(); sub ORP(); sub K_S(); 9sub LOC(); sub HLD(); sub RSV(); sub FRQ(); sub RRQ(); sub RRC(); sub ARQ(); sub URQ(); 10sub A_S(); sub DIR(); sub ZON(); sub HUB(); sub IMM(); sub XMA(); sub KFS(); sub TFS(); 11sub LOK(); sub CFM(); sub HIR(); sub COV(); sub SIG(); sub LET(); 12 13# do some aliasing 14*post = \&putMsgInArea; 15*from = \$::fromaddr; 16*to = \$::toaddr; 17*addr = \$::toaddr; 18*sfrom = \$::fromname; 19*sto = \$::toname; 20*subj = \$::subject; 21 22# figure out basename function 23*basename = \&my_basename; 24#eval { require File::Basename; *basename = \&File::Basename::basename; }; 25 26# return 1 if it's my aka 27sub me { 28 my $s = $_[0]; $s =~ s/\.0$//; 29 for my $aka (@{$::config{addr}}) { return 1 if $aka eq $s; } 30 return 0; 31} 32# addvia($link=undef, $utc=undef) 33# $link - substitute aka for link to via 34# $utc - set to 1 to use GMT 35# add via to the $text; set $change=1, $addvia=0; 36sub addvia { 37 my $a = defined $::links{$_[0]}{aka} ? $::links{$_[0]}{aka} : $::config{addr}[0]; 38 my $offs = ''; 39 if (!$_[1]) { 40 $offs = gmtoff(); $offs = sprintf("%+g", $offs) unless $offs == 0; 41 } 42 $::text .= "\x01Via $a \@".strftime("%Y%m%d.%H%M%S", $_[1] ? gmtime : localtime). 43 ".UTC$offs $::hpt_ver+vtrack $VERSION\r"; 44 $::addvia = 0; $::change = 1; 45} 46# return age of message in days 47sub age () { 48 return (time-$::date)/(60*60*24); 49} 50# return loop count (^via of all our aka's) 51sub loop_cnt () { 52 my $addrs = '('.join('|', @{$::config{addr}}).')'; 53 my @vias = $::text =~ /(?:^|\r)\x01Via $addrs /g; 54 return scalar @vias; 55} 56# loop_age([$cnt]) 57# $cnt - loop number; return list if $cnt=undef 58# return loop age (days ago message passed through our system) 59sub loop_age { 60 my $addrs = '(?:'.join('|', @{$::config{addr}}).')'; 61 my @vias = $::text =~ /(?:^|\r)(\x01Via $addrs [^\r]*)/g; 62 my @ages; 63 for (my $i = 0; $i < @vias; $i++) { 64 if (defined $_[0] && ($i != $_[0])) { next; } 65 # $1 $2 $3 $4 $5 $6 $7 66 my $k = $vias[$i] =~ /^\x01Via\s+\S+\s+\@(\d{4})(\d{2})(\d{2})\.(\d{2})(\d{2})(\d{2})\.UTC([+-]\d+)?/o; 67 return undef unless defined $6; 68 my $t = mktime($6, $5, $4, $3, ($2)-1, ($1)-1900); 69 if (defined $7) { $t += (gmtoff() - $7)*3600; } else { $t += gmtoff()*3600; } 70 if (defined $_[0]) { return (time-$t)/(60*60*24); } 71 else { push @ages, (time-$t)/(60*60*24); } 72 } 73 return (@ages) ? @ages : undef; 74} 75# pack_age() 76# return hours since message was packed at my system, 77# undef if the last Via isn't my 78sub pack_age () { 79 my $addrs = '(?:'.join('|', @{$::config{addr}}).')'; 80 my @a = $::text =~ /(?:^|\r)\x01Via\s+$addrs\s+\@(\d{4})(\d{2})(\d{2})\.(\d{2})(\d{2})(\d{2})\.UTC([+-]\d+)?[^\r]*[\r\s]*$/o; 81 return undef unless defined @a; 82 my $t = mktime($a[5], $a[4], $a[3], $a[2], $a[1]-1, $a[0]-1900); 83 $t += (gmtoff() - $a[6])*3600; 84 return (time-$t)/3600; 85} 86# att_check($flags = 3) 87# $flags - where to find attaches; bit mask: 88# bit 0 (1): secure inbound 89# bit 1 (2): unsecure inbound 90# bit 2 (4): local inbound 91# return 1 if all attaches are present or it's non-ATT message 92sub att_check { 93 return 1 if !($::attr & (ATT | FRQ | URQ)); 94 my @files = $::subj =~ /([^ ,]+)/go; 95 my $where = defined $_[0] ? $_[0] : 3; 96 for my $s (@files) { 97 $s = basename($s); my $found = 0; 98 next unless defined $s; 99 if ($where & 1) { $found |= -e $::config{protInbound}.'/'.$s; } 100 if ($where & 2) { $found |= -e $::config{inbound}.'/'.$s; } 101 if ($where & 4) { $found |= -e $::config{localInbound}.'/'.$s; } 102 return 0 unless $found; 103 } 104 return 1; 105} 106# return number of attached files, 0 if none but ATT, undef if non-ATT message 107sub att_cnt () { 108 return undef unless $::attr & (ATT | FRQ | URQ); 109 my @files = $::subj =~ /([^ ,]+)/go; 110 return scalar @files; 111} 112# att_size($cnt, $flags = 3) 113# $cnt - number of attach; return list if $cnt=undef 114# $flags - see att_check() 115# return size of given attach, undef if it's not found 116sub att_size { 117 return undef if !($::attr & (ATT | FRQ | URQ)); 118 my @files = $::subj =~ /([^ ,]+)/go; 119 my $where = defined $_[1] ? $_[1] : 3; 120 my @sizes; 121 for (my $i = 0; $i < @files; $i++) { 122 if (defined $_[0] && $i != $_[0]) { next; } 123 my $s = basename($files[$i]); my $size; 124 if (defined $s) { 125 my $n = 0; 126 for my $dir (($::config{protInbound},$::config{inbound},$::config{localInbound})) { 127 next unless $where & (1<<$n++); 128 if (-e "$dir/$s") { $size = -s "$dir/$s"; last; } 129 } 130 } 131 if (defined $_[0]) { return $size; } else { push @sizes, $size; } 132 } 133 return (@sizes) ? @sizes : undef; 134} 135# att_kill($cnt, $flags = 3) 136# $cnt - number of attach; unlink all if undef 137# $flags - see att_check() 138# unlinks attaches of the current message 139sub att_kill { 140 return unless ($::attr & (ATT | FRQ | URQ)); 141 my @files = $::subj =~ /([^ ,]+)/go; 142 my $where = defined $_[1] ? $_[1] : 3; 143 for (my $i = 0; $i < @files; $i++) { 144 if (defined $_[0] && $i != $_[0]) { next; } 145 my $s = basename($files[$i]); 146 if (defined $s) { 147 my $n = 0; 148 for my $dir (($::config{protInbound},$::config{inbound},$::config{localInbound})) { 149 next unless $where & (1<<$n++); 150 if (-e "$dir/$s") { unlink "$dir/$s"; last; } 151 } 152 } 153 } 154} 155# att_conv($cnt) 156# $cnt - number of attach; all if undef 157# strip directory from attach file name 158sub att_conv { 159 return unless ($::attr & (ATT | FRQ | URQ)); 160 my @files = $::subj =~ /([^ ,]+)/go; 161 my $same = 1; 162 for (my $i = 0; $i < @files; $i++) { 163 next if (defined $_[0] && $i != $_[0]); 164 my $s = basename($files[$i]); 165 if ($s ne $files[$i]) { $files[$i] = $s; $same = 0; } 166 } 167 if (!$same) { $::subj = join ' ', @files; $::change = 1; } 168 return $same; 169} 170# msg_dekludge([$delim]) - remove kludges from the message 171sub msg_dekludge { 172 my @res = $::text =~ /(?:^|\r)([^\x01][^\r]*)/go; 173 return join $_[0]||"\r", @res; 174} 175# msg_kludges([@list]) - return kludges from the message 176sub msg_kludges { 177 my @klgs = @_ ? @_ : qw(INTL TOPT FMPT MSGID REPLY FLAGS); 178 my $klgs = '(?:'.join('|', @klgs).')'; 179 my @res = $::text =~ /(?:^|\r)(\x01$klgs[^\r]*)/gi; 180 return join "\r", @res; 181} 182# msg_vias([$delim]) - return via lines from the message 183sub msg_vias { 184 my @res = $::text =~ /(?:^|\r)(\x01Via [^\r]*)/go; 185 return join $_[0]||"\r", @res; 186} 187# msg_teerline - return the last line starting with '---' from the message 188sub msg_teerline { 189 my @res = $::text =~ /(?:^|\r)(---[^\r]*)/go; 190 return @res ? $res[-1] : undef; 191} 192# msg_origin - return the last origin line from the message 193sub msg_origin { 194 my @res = $::text =~ /(?:^|\r)( \* Origin: [^\r]*)/go; 195 return @res ? $res[-1] : undef; 196} 197# my basename function (works for dos and unix) 198sub my_basename { return ($_[0] =~ /[^\\\/:]+$/o) ? $& : undef; } 199 200} 201 2021; 203 204__END__ 205