File Coverage

blib/lib/FTN/Packet.pm
Criterion Covered Total %
statement 81 168 48.2
branch 23 36 63.8
condition n/a
subroutine 4 5 80.0
pod 2 2 100.0
total 110 211 52.1


line stmt bran cond sub pod time code
1             package FTN::Packet;
2              
3 5     5   130721 use strict;
  5         14  
  5         196  
4 5     5   28 use warnings;
  5         9  
  5         182  
5 5     5   29 use Carp qw( croak );
  5         15  
  5         10323  
6              
7             =head1 NAME
8              
9             FTN::Packet - Reading or writing Fidonet Technology Networks (FTN) packets.
10              
11             =head1 VERSION
12              
13             VERSION 0.21
14              
15             =cut
16              
17             our $VERSION = '0.21';
18              
19             =head1 DESCRIPTION
20              
21             FTN::Packet is a Perl extension for reading or writing Fidonet Technology Networks (FTN) packets.
22              
23             =cut
24              
25             require Exporter;
26             require AutoLoader;
27              
28             =head1 EXPORT
29              
30             The following functions are available in this module: read_ftn_packet(),
31             write_ftn_packet().
32              
33             =cut
34              
35             our @ISA = qw(Exporter AutoLoader);
36             # Items to export into callers namespace by default. Note: do not export
37             # names by default without a very good reason. Use EXPORT_OK instead.
38             # Do not simply export all your public functions/methods/constants.
39             our @EXPORT_OK = qw( &read_ftn_packet &write_ftn_packet
40             );
41              
42             =head1 FUNCTIONS
43              
44             =head2 read_ftn_packet
45              
46             Syntax: $messages = read_ftn_packet($pkt_file);
47              
48             Read the messages in a Fidonet/FTN packet. It is passed the name and path of a
49             Fidonet/FTN packet file. Returns the messages in the packet as a reference to an
50             array of hashes, which can be read as follows:
51              
52             for $i ( 0 .. $#{$messages} ) {
53              
54             print "On message $i";
55              
56             $msg_area = ${$messages}[i]{area};
57             $msg_date = ${$messages}[i]{ftscdate};
58             $msg_tonode = ${$messages}[i]{tonode};
59             $msg_from = ${$messages}[i]{from};
60             $msg_to = ${$messages}[i]{to};
61             $msg_subj = ${$messages}[i]{subj};
62             $msg_msgid = ${$messages}[i]{msgid};
63             $msg_replyid = ${$messages}[i]{replyid};
64             $msg_body = ${$messages}[i]{body};
65             $msg_ctrl = ${$messages}[i]{ctrlinfo};
66              
67             # Processing of the contents of the message.
68              
69             }
70              
71             =cut
72              
73             ###############################################
74             # Read Messages from FTN packet
75             ###############################################
76             sub read_ftn_packet {
77              
78 4     4 1 4707 my ($packet_file) = @_;
79              
80 4         13 my ($packet_version,$origin_node,$destination_node,$origin_net,$destination_net,$attribute,$cost,$buffer);
81 0         0 my ($separator, $s, $date_time, $to, $from, $subject, $area, @lines, @kludges, $PKT,
82             $from_node, $to_node, @messages, $message_body, $message_id, $reply_id, $origin,
83             $mailer, $seen_by, $i, $k);
84              
85             # "$PKT" is a file pointer to the packet file being read
86 4 50       183 open( $PKT, q{<}, $packet_file ) or croak("Problem opening packet file: $packet_file");
87 4         12 binmode($PKT);
88              
89             # Ignore packet header
90 4         94 read($PKT,$buffer,58);
91              
92 4         19 while (!eof($PKT)) {
93              
94 8 100       57 last if (read($PKT, $buffer, 14) != 14);
95              
96 4         68 ($packet_version, $origin_node, $destination_node, $origin_net, $destination_net, $attribute, $cost) = unpack("SSSSSSS",$buffer);
97              
98             # not used for anything yet - 8/26/01 rjc
99 4         15 undef $packet_version;
100              
101             # not used for anything yet - 8/26/01 rjc
102 4         8 undef $attribute;
103              
104             # not used for anything yet - 12/15/01 rjc
105 4         7 undef $cost;
106              
107 4         10 $separator = $/;
108 4         41 local $/ = "\0";
109              
110 4         20 $date_time = <$PKT>;
111 4 50       26 if (length($date_time) > 20) {
112 0         0 $to = substr($date_time,20);
113             } else {
114 4         12 $to = <$PKT>;
115             }
116 4         10 $from = <$PKT>;
117 4         11 $subject = <$PKT>;
118              
119 4         29 $to =~ tr/\200-\377/\0-\177/; # mask hi-bit characters
120 4         9 $to =~ tr/\0-\037/\040-\077/; # mask control characters
121 4         11 $from =~ tr/\200-\377/\0-\177/; # mask hi-bit characters
122 4         10 $from =~ tr/\0-\037/\040-\077/; # mask control characters
123 4         10 $subject =~ tr/\0-\037/\040-\077/; # mask control characters
124              
125 4         13 $s = <$PKT>;
126 4         236 local $/ = $separator;
127              
128 4         14 $s =~ s/\x8d/\r/g;
129 4         35 @lines = split(/\r/,$s);
130              
131 4         10 undef $s;
132              
133 4 50       14 next if ($#lines < 0);
134              
135 4         10 $area = shift(@lines);
136 4         10 $_ = $area;
137              
138             # default netmail area name
139 4 100       26 $area ="NETMAIL" if /\//i;
140              
141             # strip "area:"
142 4         167 $area =~ s/.*://;
143              
144             # Force upper case ???
145 4         11 $area =~ tr/a-z/A-Z/;
146              
147 4         14 @kludges = ();
148              
149 4         14 for ($i = $k = 0; $i <= $#lines; $i++) {
150              
151 20 100       69 if ($lines[$i] =~ /^\001/) {
152 4         24 $kludges[$k++] = splice(@lines,$i,1);
153 4         13 redo;
154             }
155             }
156              
157 4         7 for (;;) {
158 8         17 $_ = pop(@lines);
159 8 100       29 last if ($_ eq "");
160 6 100       27 if (/ \* origin: /i) {
161 2         7 $origin = substr($_,11);
162 2         6 last;
163             }
164 4 50       14 if (/---/) {
165 0         0 $mailer = $_;
166             }
167 4 50       16 if (/seen-by/i) {
168 0         0 $seen_by=$_;
169             }
170             }
171              
172 4 50       13 if ( ! $mailer ) {
173 4         7 $mailer = "---";
174             }
175              
176 4 50       12 if ($#lines < 0) {
177 0         0 @lines = ("[empty message]");
178             }
179              
180             # get message body, ensuring that it starts empty
181 4         7 $message_body = "";
182              
183 4         9 foreach my $s (@lines) {
184 8         14 $s =~ tr/\0-\037/\040-\077/; # mask control characters
185 8         47 $s =~ s/\s+$//;
186 8         14 $s=~tr/^\*/ /;
187 8         32 $message_body .= "$s\n";
188             }
189              
190 4 50       22 $message_body .= "$mailer\n" if ($mailer);
191 4 100       21 $message_body .= " * Origin: $origin\n" if ($origin);
192              
193             # get control info, ensuring that it starts empty
194 4         8 my $control_info = "";
195 4 50       23 $control_info .= "$seen_by\n" if ($seen_by);
196 4         7 foreach my $c (@kludges) {
197 4         28 $c =~ s/^\001//;
198              
199             # If kludge starts with "MSGID:", stick that in a special
200             # variable.
201 4 50       30 if ( substr($c, 0, 6) eq "MSGID:" ) {
202 4         12 $message_id = substr($c, 7);
203             }
204              
205 4         17 $control_info .= "$c\n";
206             }
207              
208 4 50       12 if ( ! $message_id) {
209 0         0 $message_id = "message id not available";
210             }
211              
212             # get replyid from kludges? same way as get seenby?
213 4         10 $reply_id = "reply id not available";
214              
215             # need to pull zone num's from pkt instead of defaulting 1
216 4         19 $from_node = "1:$origin_net/$origin_node\n";
217 4         14 $to_node = "1:$destination_net/$destination_node\n";
218              
219 4         59 my %message_info = (
220              
221             area => $area,
222              
223             ftscdate => $date_time,
224              
225             ## not useing this yet...
226             #cost => $cost,
227              
228             fromnode => $from_node,
229             tonode => $to_node,
230              
231             from => $from,
232             to => $to,
233             subj => $subject,
234              
235             msgid => $message_id,
236             replyid => $reply_id,
237              
238             body => $message_body,
239              
240             ctrlinfo => $control_info
241              
242             );
243              
244 4         28 push(@messages, \%message_info);
245              
246             } # end while
247              
248 4         69 return \@messages;
249              
250             } # end sub read_ftn_packet
251              
252              
253             =head2 write_ftn_packet
254              
255             Syntax: write_ftn_packet($OutDir, \%packet_info, \@messages);
256              
257             Create a Fidonet/FTN packet, where:
258             $OutDir is the directory where the packet is to be created
259             \%packet_info is a reference to a hash containing the packet header
260             \@messages is reference to an array of references to hashes containing the messages.
261              
262             =cut
263              
264             sub write_ftn_packet {
265              
266 0     0 1   my ($OutDir, $packet_info, $messages) = @_;
267              
268 0           my ($packet_file, $PKT, @lines, $serialno, $buffer, $nmsgs, $i, $k, $message_ref);
269              
270 0           my $EOL = "\n\r";
271              
272             # This part is a definition of an FTN Packet format per FTS-0001
273              
274             # PKT Header; initialized variable are constants; last comments are
275             # in pack() notation
276              
277             # ${$packet_info}{OrgNode} # S
278             # ${$packet_info}{DestNode} # S
279 0           my ($year, $month, $day, $hour, $minutes, $seconds); # SSSSSS
280 0           my $Baud = 0; # S
281 0           my $packet_version = 2; # S Type 2 packet
282             # ${$packet_info}{OrgNet} # S
283             # ${$packet_info}{DestNet} # S
284 0           my $ProdCode = 0x1CFF; # S product code = 1CFF
285             # ${$packet_info}{PassWord} # a8
286             # ${$packet_info}{OrgZone} # S
287             # ${$packet_info}{DestZone} # S
288 0           my $AuxNet = ${$packet_info}{OrgNet}; # S
  0            
289 0           my $CapWord = 0x100; # S capability word: Type 2+
290 0           my $ProdCode2 = 0; # S ?
291 0           my $CapWord2 = 1; # S byte swapped cap. word
292             # ${$packet_info}{OrgZone} # S (repeat)
293             # ${$packet_info}{DestZone} # S (repeat)
294             # ${$packet_info}{OrgPoint} # S
295             # config file for node info?
296             # ${$packet_info}{DestPoint} # S
297 0           my $ProdSpec = 0; # L ?
298              
299             # MSG Header; duplicated variables are shown as comments to indicate
300             # the MSG Header structure
301              
302             # $packet_version # S (repeat)
303             # ${$packet_info}{OrgNode} # S (repeat)
304             # ${$packet_info}{DestNode} # S (repeat)
305             # ${$packet_info}{OrgNet} # S (repeat)
306             # ${$packet_info}{DestNet} # S (repeat)
307 0           my $attribute = 0; # S
308 0           my $Cost = 0; # S
309             # ${$message_ref}{DateTime} # a20 (this is a local())
310             # ${$message_ref}{To} # a? (36 max)
311             # ${$message_ref}{From} # a? (36 max)
312             # ${$message_ref}{Subj} # a? (72 max)
313              
314             #"AREA: " # c6 }
315             # ${$packet_info}{Area} # a? (max?) } all this is actually part
316             #possible kludges go here. 0x010x0D } of the TEXT postions
317             #TEXT goes here. (ends with 2 0x0D's ???) }
318              
319             # ${$packet_info}{TearLine}
320 0           my $Origin = " * Origin: ${$packet_info}{Origin} (${$packet_info}{OrgZone}:${$packet_info}{OrgNet}/${$packet_info}{OrgNode}.1)$EOL";
  0            
  0            
  0            
  0            
321 0           my $seen_by = "SEEN-BY: ${$packet_info}{OrgNet}/${$packet_info}{OrgNode}$EOL";
  0            
  0            
322 0           my $Path = "\1PATH: ${$packet_info}{OrgNet}/${$packet_info}{OrgNode}$EOL\0"; # note the \0 in $Path
  0            
  0            
323              
324             # repeat MSG Headers/TEXT
325              
326             # null (S) to mark done
327              
328             # this is where a loop would go if more than one feed
329              
330             # PKT name as per FTS
331 0           ($seconds, $minutes, $hour, $day, $month, $year) = localtime();
332 0           $year += 1900;
333              
334 0           $packet_file = sprintf("%s/%02d%02d%02d%02d.pkt",$OutDir,$day,$hour,$minutes,$seconds);
335              
336 0 0         open( $PKT, q{>}, "$packet_file" ) or croak('Cannot open FTN packet file for writing.');
337              
338 0           binmode($PKT);
339              
340             # write packet header
341 0           $buffer = pack("SSSSSSSSSSSSSa8SSSSSSSSSSL",
342 0           ${$packet_info}{OrgNode}, ${$packet_info}{DestNode},
  0            
343             $year, $month, $day, $hour, $minutes, $seconds,
344             $Baud, $packet_version,
345 0           ${$packet_info}{OrgNet}, ${$packet_info}{DestNet},
  0            
346 0           $ProdCode, ${$packet_info}{PassWord},
347 0           ${$packet_info}{OrgZone}, ${$packet_info}{DestZone}, $AuxNet,
  0            
348             $CapWord, $ProdCode2, $CapWord2,
349 0           ${$packet_info}{OrgZone}, ${$packet_info}{DestZone},
  0            
350 0           ${$packet_info}{OrgPoint}, ${$packet_info}{DestPoint}, $ProdSpec);
  0            
351 0           syswrite($PKT,$buffer,58);
352              
353             # needs to iterate over the array of hashes representing the messages
354 0           foreach my $message_ref ( @{$messages} ) {
  0            
355             #while ( @{$messages} > 0) {
356             #while ( @{$messages} ) {
357              
358             ## get next message hash reference
359             #$message_ref = pop(@{$messages});
360              
361             # get text body, translate LFs to CRs
362              
363 0           @lines = ${$message_ref}{Body};
  0            
364 0           @lines = grep { s/\n/\r/ } @lines;
  0            
365              
366             # kill leading blank lines
367              
368 0           shift(@lines) while ($lines[0] eq "\n");
369              
370             # informative only
371 0           ++$nmsgs;
372              
373             # write message to $PKT file
374              
375             # Write Message Header
376 0           $buffer = pack("SSSSSSSa20",
377 0           $packet_version,${$packet_info}{OrgNode},${$packet_info}{DestNode},${$packet_info}{OrgNet},
  0            
  0            
378 0           ${$packet_info}{DestNet},$attribute,$Cost,${$message_ref}{DateTime});
  0            
379 0           print $PKT $buffer;
380              
381 0           print $PKT "${$message_ref}{To}\0";
  0            
382 0           print $PKT "${$message_ref}{From}\0";
  0            
383 0           print $PKT "${$message_ref}{Subj}\0";
  0            
384 0           print $PKT "AREA: ${$packet_info}{Area}$EOL"; # note: CR not nul
  0            
385              
386 0           $serialno = unpack("%16C*",join('',@lines));
387 0           $serialno = sprintf("%lx",$serialno + time);
388 0           print $PKT "\1MSGID: ${$packet_info}{OrgZone}:${$packet_info}{OrgNet}/${$packet_info}{OrgNode}.${$packet_info}{OrgPoint} $serialno$EOL";
  0            
  0            
  0            
  0            
389              
390 0           print $PKT @lines;
391 0           print $PKT $EOL,${$packet_info}{TearLine},$Origin,$seen_by,$Path;
  0            
392              
393             # all done with array (frees mem?)
394 0           @lines = ();
395              
396             }
397              
398             # indicates no more messages
399 0           print $PKT "\0\0";
400              
401 0           close($PKT);
402              
403 0           return 0;
404             }
405              
406             1;
407             __END__