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