File Coverage

blib/lib/FTN/Outbound/BSO.pm
Criterion Covered Total %
statement 88 278 31.6
branch 31 204 15.2
condition 14 111 12.6
subroutine 14 21 66.6
pod 6 6 100.0
total 153 620 24.6


line stmt bran cond sub pod time code
1 3     3   41435 use strict;
  3         3  
  3         78  
2 3     3   11 use warnings;
  3         3  
  3         82  
3 3     3   1612 use utf8;
  3         24  
  3         10  
4              
5             package FTN::Outbound::BSO;
6             $FTN::Outbound::BSO::VERSION = '20160516';
7             # fts-5005.002 BinkleyTerm Style Outbound
8             # except s/Continuous/Crash/g
9              
10 3     3   2124 use Log::Log4perl ();
  3         101195  
  3         57  
11 3     3   16 use Scalar::Util ();
  3         5  
  3         31  
12 3     3   1299 use Encode::Locale ();
  3         28960  
  3         56  
13 3     3   14 use Encode ();
  3         2  
  3         33  
14 3     3   9 use File::Spec ();
  3         2  
  3         38  
15 3     3   8 use Fcntl ();
  3         3  
  3         28  
16 3     3   1262 use FTN::Addr ();
  3         13208  
  3         65  
17 3     3   1803 use FTN::Outbound::Reference_file ();
  3         5250  
  3         14349  
18              
19             my %flavour_extension = ( immediate => [ qw/ iut ilo / ], # Xut (netmail) Xlo (reference file) by fts-5005.002
20             # continuous => [ qw/ c c / ], # except this one
21             crash => [ qw/ cut clo / ],
22             direct => [ qw/ dut dlo / ],
23             normal => [ qw/ out flo / ],
24             hold => [ qw/ hut hlo / ],
25             );
26             # Reference files consist of a number of lines (terminated by 0x0a or 0x0d,0x0a) each consisting of the name of the file to transfer to the remote system.
27              
28             # file_type => extension. both keys and values should be unique in their sets
29             # content notes are from fts-5005.002
30             my %control_file_extension = ( file_request => 'req', # file requests
31             # The format of request files is documented in FTS-0006.
32             busy => 'bsy', # busy control file.
33             # may contain one line of PID information (less than 70 characters).
34             call => 'csy', # call control file
35             # may contain one line of PID information (less than 70 characters).
36             hold => 'hld', # hold control file
37             # must contain a one line string with the expiration of the hold period expressed in UNIX-time.
38             # the second line of an hld file may contain one line of PID information. (Less than 70 characters)
39             try => 'try', # try control file
40             # A try file must contain one line string with a diagnostic message. It is for information purposes only.
41             # the second line of a try file may contain one line of PID information. ( < 70 characters)
42             );
43              
44             =head1 NAME
45              
46             FTN::Outbound::BSO - Object-oriented module for working with BinkleyTerm Style Outbound.
47              
48             =head1 VERSION
49              
50             version 20160516
51              
52             =head1 SYNOPSIS
53              
54             use Log::Log4perl ();
55             use Encode ();
56             use FTN::Outbound::BSO ();
57              
58             Log::Log4perl -> easy_init( $Log::Log4perl::INFO );
59              
60             my $bso = FTN::Outbound::BSO -> new( outbound_root => '/var/lib/ftn/outbound',
61             domain => 'fidonet',
62             zone => 2,
63             domain_abbrev => { fidonet => '_out',
64             homenet => 'leftnet',
65             },
66             maximum_session_time => 3600, # one hour
67             ) or die 'cannot create bso object';
68              
69             my $addr = FTN::Addr -> new( '2:451/30' );
70              
71             sub poll {
72             my $addr = shift;
73             my $bso = shift;
74              
75             my $flo = $bso -> addr_file_to_change( $addr,
76             'reference_file',
77             'normal'
78             );
79              
80             open my $fh, '>>', $flo
81             or die sprintf 'cannot open %s: %s', $flo, $!;
82              
83             print $fh '';
84              
85             close $fh;
86             }
87              
88             $bso -> busy_protected_sub( $addr,
89             \ &poll,
90             );
91              
92             =head1 DESCRIPTION
93              
94             FTN::Outbound::BSO module is for working with BinkleyTerm Style Outbound in FTN following specifications from fts-5005.002 document. Figuring out correct file to process might be a tricky process: different casing, few our main domains, other differences. This module helps with this task.
95              
96             =head1 OBJECT CREATION
97              
98             =head2 new
99              
100             Expects parameters as hash:
101              
102             outbound_root - directory path as a character string where whole outbound is located. Mandatory parameter. This directory should exist.
103              
104             By standard constructor needs our domain and zone. They can be provided as:
105              
106             our_addr - either FTN::Addr object representing our address or our address as a string which will be passed to FTN::Addr constructor.
107              
108             or as a pair:
109              
110             domain - domain part of our address as described in frl-1028.002.
111             zone - our zone in that domain
112              
113             At least one of the ways should be provided. In case both are our_addr has higher priority.
114              
115             domain_abbrev - hash reference where keys are known domains and values are directory names (without extension) in outbound_root for those domains. Mandatory parameter.
116              
117             reference_file_read_line_transform_sub - reference to a function that receives an octet string and returns a character string. Will be passed to FTN::Outbound::Reference_file constructor. If not provided reference file content won't be processed.
118              
119             maximum_session_time - maximum session time in seconds. If provided, all found busy files older than 2 * value will be removed during outbound scan.
120              
121             Returns newly created object on success.
122              
123             =cut
124              
125             sub new {
126 2     2 1 3566 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
127              
128 2 50       421 ref( my $class = shift ) and $logger -> logcroak( "I'm only a class method!" );
129              
130             return
131 2 50       6 unless @_;
132              
133 2 50       11 $logger -> logdie( sprintf 'constructor expects even number of arguments, but received %d of them',
134             scalar @_,
135             )
136             if @_ % 2;
137              
138 2         11 my %option = @_;
139 2         3 my %self;
140              
141             # validating
142             # mandatory parameters
143             $logger -> logdie( 'mandatory outbound_root is not provided' )
144 2 50       6 unless exists $option{outbound_root};
145              
146             # outbound_root
147 2         9 my $outbound_root_fs = Encode::encode( locale_fs => $option{outbound_root} );
148              
149 2 50       213 unless ( -e $outbound_root_fs ) {
150             $logger -> warn( sprintf 'outbound_root (%s) directory does not exist',
151             $option{outbound_root},
152 0         0 );
153              
154 0         0 return;
155             }
156              
157 2 50       7 unless ( -d _ ) { # if it exists it should be a directory
158             $logger -> warn( sprintf 'outbound_root (%s) does not point to the directory',
159             $option{outbound_root},
160 0         0 );
161              
162 0         0 return;
163             }
164              
165 2         6 $self{outbound_root} = $option{outbound_root};
166 2         4 $self{outbound_root_fs} = $outbound_root_fs;
167              
168              
169             # our_addr or ( domain + zone )
170 2 50 33     11 if ( exists $option{our_addr}
171             && $option{our_addr}
172             ) {
173 0 0 0     0 if ( ref $option{our_addr}
      0        
174             && Scalar::Util::blessed $option{our_addr}
175             && $option{our_addr} -> isa( 'FTN::Addr' )
176             ) {
177 0         0 $self{our_addr} = $option{our_addr};
178             } else {
179             $self{our_addr} = FTN::Addr -> new( $option{our_addr} )
180             or $logger -> logdie( sprintf 'incorrect value of our_addr: %s',
181             $option{our_addr},
182 0 0       0 );
183             }
184 0         0 $self{domain} = $self{our_addr} -> domain;
185 0         0 $self{zone} = $self{our_addr} -> zone;
186             } else {
187             $logger -> logdie( 'domain is not provided' )
188             unless exists $option{domain}
189 2 50 33     22 && $option{domain};
190              
191             $logger -> logdie( sprintf 'domain (%s) is not valid',
192             $option{domain},
193             )
194 2 50       16 unless $option{domain} =~ m/^[a-z\d_~-]{1,8}$/; # frl-1028.002
195              
196             $logger -> logdie( 'zone is not provided' )
197             unless exists $option{zone}
198 2 50 33     20 && $option{zone};
199              
200             $logger -> logdie( sprintf 'zone (%s) is not valid',
201             $option{zone},
202             )
203             unless $option{zone} =~ m/^\d+$/ # FRL-1002.001, frl-1028.002
204             && 1 <= $option{zone} # FRL-1002.001, frl-1028.002
205 2 50 33     23 && $option{zone} <= 32767; # FRL-1002.001, frl-1028.002
      33        
206              
207 2         4 $self{domain} = $option{domain};
208 2         4 $self{zone} = $option{zone};
209             }
210              
211             # domain abbreviations
212 2 50 33     17 if ( exists $option{domain_abbrev}
      33        
213             && defined $option{domain_abbrev}
214             && ref $option{domain_abbrev} eq 'HASH'
215             ) {
216             $logger -> logdie( sprintf 'our domain (%s) is not in the passed domain_abbrev hash!',
217             $self{domain},
218             )
219 2 50       6 unless exists $option{domain_abbrev}{ $self{domain} };
220              
221 2         31 $self{domain_abbrev} = $option{domain_abbrev};
222             } else {
223 0         0 $logger -> logdie( 'no valid domain_abbrev provided' );
224             }
225              
226             # reference file read line transform sub
227 2 50       8 if ( exists $option{reference_file_read_line_transform_sub} ) {
228             $logger -> logdie( 'incorrect value of reference_file_read_line_transform_sub (should be a sub reference)' )
229             unless defined $option{reference_file_read_line_transform_sub}
230 0 0 0     0 && 'CODE' eq ref $option{reference_file_read_line_transform_sub};
231              
232 0         0 $self{reference_file_read_line_transform_sub} = $option{reference_file_read_line_transform_sub};
233             }
234              
235             # maximum_session_time
236 2 50       5 if ( exists $option{maximum_session_time} ) {
237             $logger -> logdie( sprintf 'incorrect value of maximum_session_time: %s',
238             defined $option{maximum_session_time} ?
239             $option{maximum_session_time}
240             : 'undef'
241             )
242             unless defined $option{maximum_session_time}
243             && $option{maximum_session_time} =~ m/^\d+$/
244 0 0 0     0 && $option{maximum_session_time}; # cannot be 0
    0 0        
245              
246 0         0 $self{maximum_session_time} = $option{maximum_session_time};
247             }
248              
249 2         9 bless \ %self, $class;
250             }
251              
252             sub _store {
253 0     0   0 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
254              
255 0 0       0 ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
256              
257 0         0 my ( $file_prop,
258             $ext,
259             $target,
260             $net,
261             $node,
262             $point,
263             ) = @_;
264              
265 0         0 my %ext_netmail_flavour = map { $flavour_extension{ $_ }[ 0 ] => $_ } keys %flavour_extension;
  0         0  
266 0         0 my %ext_reference_file_flavour = map { $flavour_extension{ $_ }[ 1 ] => $_ } keys %flavour_extension;
  0         0  
267 0         0 my %ext_control_file = reverse %control_file_extension;
268              
269 0         0 my $lc_ext = lc $ext;
270              
271 0 0       0 if ( exists $ext_netmail_flavour{ $lc_ext } ) { # netmail
    0          
    0          
272 0         0 push @{ $target -> { $net }{ $node }{ $point }{netmail}{ $ext_netmail_flavour{ $lc_ext } } },
  0         0  
273             $file_prop;
274             } elsif ( exists $ext_reference_file_flavour{ $lc_ext } ) { # reference file
275 0         0 my $flavour = $ext_reference_file_flavour{ $lc_ext };
276             # referenced files
277 0 0 0     0 if ( $file_prop -> {size} # empty files are empty, right?
278             && exists $self -> {reference_file_read_line_transform_sub}
279             ) {
280             $file_prop -> {referenced_files} =
281             FTN::Outbound::Reference_file
282             -> new( $file_prop -> {full_name},
283             $self -> {reference_file_read_line_transform_sub},
284             )
285 0         0 -> read_existing_file
286             -> referenced_files;
287             }
288              
289 0         0 push @{ $target -> { $net }{ $node }{ $point }{reference_file}{ $flavour } },
  0         0  
290             $file_prop;
291             } elsif ( exists $ext_control_file{ $lc_ext } ) {
292 0 0       0 my $age = $file_prop -> {mstat} ? time - $file_prop -> {mstat} : 0;
293 0 0 0     0 if ( $ext_control_file{ $lc_ext } eq 'busy'
      0        
294             && exists $self -> {maximum_session_time}
295             && $self -> {maximum_session_time} * 2 < $age
296             ) { # try to remove if maximum_session_time is defined and busy is older than it
297             $logger -> info( sprintf 'removing expired busy %s (%d seconds old)',
298             $file_prop -> {full_name},
299 0         0 $age,
300             );
301              
302             unlink Encode::encode( locale_fs => $file_prop -> {full_name} )
303             or $logger -> logdie( sprintf 'could not unlink %s: %s',
304             $file_prop -> {full_name},
305 0 0       0 $!,
306             );
307             } else {
308 0         0 push @{ $target -> { $net }{ $node }{ $point }{ $ext_control_file{ $lc_ext } } },
  0         0  
309             $file_prop;
310             }
311             }
312             }
313              
314             =head1 OBJECT METHODS
315              
316             =head2 scan
317              
318             Scans outbound for all known domains. Old busy files might be removed.
319              
320             Returns itself for chaining.
321              
322             =cut
323              
324             sub scan {
325 0     0 1 0 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
326              
327 0 0       0 ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
328              
329             $logger -> logdie( sprintf 'outbound_root (%s) directory does not exist',
330             $self -> {outbound_root},
331             )
332 0 0       0 unless -e $self -> {outbound_root_fs};
333              
334             # if it exists it should be a directory
335             $logger -> logdie( sprintf 'outbound_root (%s) does not point to the directory',
336             $self -> {outbound_root},
337             )
338 0 0       0 unless -d _;
339              
340             # check outbound_root for all domain abbrevs and zones
341 0         0 my $domain_abbr_re = join '|', values %{ $self -> {domain_abbrev} };
  0         0  
342 0         0 my %result;
343              
344             opendir my $or_dh, $self -> {outbound_root_fs}
345             or $logger -> logdie( sprintf 'cannot opendir %s: %s',
346             $self -> {outbound_root},
347 0 0       0 $!,
348             );
349              
350 0         0 while ( my $dz_out = readdir $or_dh ) { # looking for domain abbreviations directories
351 0         0 $dz_out = Encode::decode( locale_fs => $dz_out );
352              
353             next # skipping hidden files and ..
354 0 0       0 if '.' eq substr $dz_out, 0, 1;
355              
356             my $dir_name = File::Spec -> catdir( $self -> {outbound_root},
357 0         0 $dz_out,
358             );
359              
360 0         0 my $dir_name_fs = Encode::encode( locale_fs => $dir_name );
361              
362             next # looking only for directories
363 0 0       0 unless -d $dir_name_fs;
364              
365             # our_domain_dir, our_domain_dir.9999, other_domain.9999
366             next
367             unless $dz_out =~ /^($domain_abbr_re)(?:\.([1-7]?[0-9a-f]{3}))?$/i
368             && ( $1 eq $self -> {domain_abbrev}{ $self -> {domain} }
369 0 0 0     0 || defined $2
      0        
370             );
371              
372             my ( $domain ) = grep $self -> {domain_abbrev}{ $_ } eq $1,
373 0         0 keys %{ $self -> {domain_abbrev} };
  0         0  
374              
375 0 0       0 my $zone = defined $2 ? hex $2 : $self -> {zone};
376              
377             next
378 0 0 0     0 unless 1 <= $zone && $zone <= 32767; # FRL-1002.001, frl-1028.002
379              
380 0         0 $logger -> debug( sprintf 'directory %s matches. domain: %s zone: %s',
381             $dz_out,
382             $domain,
383             $zone,
384             );
385              
386 0         0 $result{ $domain }{ $zone }{ $dz_out }{dir} = $dir_name;
387              
388             # now let's traverse found domain_abbrev[.zone] dir
389 0 0       0 opendir my $dz_dh, $dir_name_fs
390             or $logger -> logdie( sprintf 'cannot opendir %s: %s',
391             $dir_name,
392             $!,
393             );
394              
395 0         0 while ( readdir $dz_dh ) {
396 0         0 $_ = Encode::decode( locale_fs => $_ );
397              
398             next
399 0 0       0 unless m/^([0-9a-f]{4})([0-9a-f]{4})\.(.+)$/i;
400              
401 0         0 my ( $net, $node ) = map hex, $1, $2;
402 0         0 my $ext = $3;
403              
404 0         0 my $full_name = File::Spec -> catfile( $dir_name,
405             $_,
406             );
407              
408 0         0 my $full_name_fs = Encode::encode( locale_fs => $full_name );
409              
410 0 0 0     0 if ( lc( $ext ) eq 'pnt'
    0          
411             && -d $full_name_fs
412             ) { # points subdir
413 0         0 $logger -> debug( sprintf 'found %s#%d:%d/%d points subdirectory %s',
414             $domain,
415             $zone,
416             $net,
417             $node,
418             $full_name,
419             );
420              
421 0         0 $result{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir}{ $_ } = $full_name; # might be different hex casing for net/node or extension
422              
423 0 0       0 opendir my $p_dh, $full_name_fs
424             or $logger -> logdie( sprintf 'cannot opendir %s: %s',
425             $full_name,
426             $!,
427             );
428              
429 0         0 while ( my $file = readdir $p_dh ) {
430 0         0 $file = Encode::decode( locale_fs => $file );
431              
432             next
433 0 0       0 unless $file =~ m/^([0-9a-f]{8})\.(.+)$/i;
434              
435 0         0 my $point = hex $1;
436 0         0 my $ext = $2;
437              
438 0         0 my $full_name = File::Spec -> catfile( $full_name,
439             $file,
440             );
441              
442             next # in points dir we're interested in files only
443 0 0       0 unless -f Encode::encode( locale_fs => $full_name );
444              
445             $self -> _store( { name => $file,
446             full_name => $full_name,
447             size => -s _,
448             mstat => ( stat _ )[ 9 ],
449             },
450             $ext,
451 0         0 $result{ $domain }{ $zone }{ $dz_out },
452             $net,
453             $node,
454             $point,
455             );
456             }
457 0         0 closedir $p_dh;
458             } elsif ( -f $full_name_fs ) { # node related file
459             $self -> _store( { name => $_,
460             full_name => $full_name,
461             size => -s _,
462             mstat => ( stat _ )[ 9 ],
463             },
464             $ext,
465 0         0 $result{ $domain }{ $zone }{ $dz_out },
466             $net,
467             $node,
468             0, # point
469             );
470             }
471             }
472 0         0 closedir $dz_dh;
473              
474             }
475 0         0 closedir $or_dh;
476              
477 0         0 $self -> {scanned} = \ %result;
478              
479 0         0 $self;
480             }
481              
482             =head2 scanned_hash
483              
484             Returns internal structure representing scanned outbound (hash in list context, hashref in scalar context). If scan method hasn't been called, it will be called implicitly by this method.
485              
486             =cut
487              
488             sub scanned_hash {
489 0     0 1 0 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
490              
491 0 0       0 ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
492              
493             $self -> scan
494 0 0       0 unless exists $self -> {scanned};
495              
496             wantarray ?
497 0         0 %{ $self -> {scanned} }
498 0 0       0 : $self -> {scanned};
499             }
500              
501              
502             sub _validate_addr {
503 0     0   0 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
504              
505 0 0       0 ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
506              
507 0         0 my $addr = shift;
508              
509 0 0 0     0 $logger -> logdie( 'no valid address passed' )
      0        
      0        
510             unless defined $addr
511             && ref $addr
512             && Scalar::Util::blessed $addr
513             && $addr -> isa( 'FTN::Addr' );
514              
515             $logger -> logdie( 'passed address has unknown domain: %s',
516             $addr -> domain,
517             )
518 0 0       0 unless exists $self -> {domain_abbrev}{ $addr -> domain };
519              
520 0         0 $addr;
521             }
522              
523             =head2 is_busy
524              
525             Expects one parameter - address as FTN::Addr object. Returns true if that address is busy (connection session, mail processing, ...).
526              
527             =cut
528              
529             sub is_busy {
530 0     0 1 0 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
531              
532 0 0       0 ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
533              
534 0         0 my $addr = $self -> _validate_addr( shift );
535              
536             $self -> scan
537 0 0       0 unless exists $self -> {scanned};
538              
539             exists $self -> {scanned}{ $addr -> domain }
540             && exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }
541             && grep exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }
542             && exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }
543             && exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }
544             && exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }{busy},
545 0 0 0     0 keys %{ $self -> {scanned}{ $addr -> domain }{ $addr -> zone } };
  0   0     0  
546             }
547              
548             sub _select_domain_zone_dir { # best one. for updating. for checking need a list (another method or direct access to the structure)
549             # and make it if it doesn't exist or isn't good enough (e.g. our_domain_abbr.our_zone)
550 10     10   538 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
551              
552 10 50       136 ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
553              
554 10         9 my $domain = shift;
555 10         7 my $zone = shift;
556              
557             $logger -> logdie( 'unknown domain: %s',
558             $domain,
559             )
560 10 50       19 unless exists $self -> {domain_abbrev}{ $domain };
561              
562 10         13 my $best_match = $self -> {domain_abbrev}{ $domain };
563              
564             $best_match .= sprintf( '.%03x', $zone )
565             unless $domain eq $self -> {domain}
566 10 100 66     51 && $zone == $self -> {zone};
567              
568             $self -> scan
569 10 50       15 unless exists $self -> {scanned};
570              
571 10 50 33     74 if ( exists $self -> {scanned}{ $domain }
      66        
      33        
572             && exists $self -> {scanned}{ $domain }{ $zone }
573             && ( $domain ne $self -> {domain} # other domains have zones in extensions
574             || $zone != $self -> {zone} # other zones in our domain have zones in extensions
575             || grep length( $_ ) == length( $best_match ),
576             keys %{ $self -> {scanned}{ $domain }{ $zone } }
577             )
578             ) {
579 26         33 my @list = sort { length $a <=> length $b }
580 10         8 keys %{ $self -> {scanned}{ $domain }{ $zone } };
  10         37  
581              
582 10         23 my ( $t ) = grep $_ eq $best_match, @list; # might be exact case
583              
584 10 100       20 $best_match = defined $t ?
585             $t
586             : $list[ 0 ]; # if didn't find the best match, use very first existing
587             } else { # need to create
588             my $dir_full_name = File::Spec -> catdir( $self -> {outbound_root},
589 0         0 $best_match,
590             );
591              
592 0         0 $logger -> debug( sprintf 'creating directory for domain %s zone %d: %s',
593             $domain,
594             $zone,
595             $dir_full_name,
596             );
597              
598 0 0       0 mkdir Encode::encode( locale_fs => $dir_full_name )
599             or $logger -> logdie( sprintf 'cannot create domain/zone %s directory: %s',
600             $dir_full_name,
601             $!,
602             );
603              
604 0         0 $self -> {scanned}{ $domain }{ $zone }{ $best_match }{dir} = $dir_full_name;
605             }
606              
607             # $self -> {scanned}{ $domain }{ $zone }{ $best_match }{dir};
608 10         20 $best_match;
609             }
610              
611             sub _select_points_dir { # select best existing. or make it. for updating
612 6     6   517 my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
613              
614 6 50       102 ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
615              
616 6         6 my ( $domain,
617             $zone,
618             $net,
619             $node,
620             ) = @_;
621              
622             $logger -> logdie( 'unknown domain: %s',
623             $domain,
624             )
625 6 50       9 unless exists $self -> {domain_abbrev}{ $domain };
626              
627             # domain zone dir might not exist at all
628 6         11 my $dz_out = $self -> _select_domain_zone_dir( $domain, $zone );
629 6         17 my $points_dir = sprintf( '%04x%04x.pnt',
630             $net,
631             $node,
632             );
633              
634             # what if other_domain_abbr.zone (perfect one) doesn't have required points dir
635             # but other_domain_abbr.zOnE has?
636             my @dz_out_with_existing_points_dir = grep exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }
637             && exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }{ $node }
638             && exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }{ $node }{points_dir},
639             grep length $_ == length $dz_out, # to filter out our_domain.our_zone versions
640 6   33     4 keys %{ $self -> {scanned}{ $domain }{ $zone } };
  6         54  
641              
642 6 50       9 if ( @dz_out_with_existing_points_dir ) { # ok, there is at least one with points dir. how do we select best of them?
643             # let's prioritize domain_abbr[.zone] betterness over points_dir betterness
644 6 100       14 unless ( grep $_ eq $dz_out,
645             @dz_out_with_existing_points_dir
646             ) { # ok, there is no best domain_abbr[.zone]. let's try to find best points_dir
647 5         8 my ( $t ) = grep exists $self -> {scanned}{ $domain }{ $zone }{ $_ }{ $net }{ $node }{points_dir}{ $points_dir },
648             @dz_out_with_existing_points_dir;
649              
650 5 50       7 $dz_out = defined $t ? $t : $dz_out_with_existing_points_dir[ 0 ]; # if no best in either place, just use very first one
651             }
652              
653             # now we've got best outbound. let's find best points dir. or just very first
654 1         3 $points_dir = ( keys %{ $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir} } )[ 0 ]
655 6 100       14 unless exists $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir}{ $points_dir };
656              
657             } else { # doesn't exist. we need to create it using best domain_abbr[.zone] dir
658             my $dir_full_name = File::Spec -> catdir( $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{dir},
659 0         0 $points_dir,
660             );
661              
662 0         0 $logger -> debug( sprintf 'creating %s#%d:%d/%d points directory %s',
663             $domain,
664             $zone,
665             $net,
666             $node,
667             $dir_full_name,
668             );
669              
670 0 0       0 mkdir Encode::encode( locale_fs => $dir_full_name )
671             or $logger -> logdie( sprintf 'cannot create points directory %s: %s',
672             $dir_full_name,
673             $!,
674             );
675              
676 0         0 $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir}{ $points_dir } = $dir_full_name;
677             }
678              
679             # return ( dz_out, $points_dir) or full points directory path?
680 6         24 $self -> {scanned}{ $domain }{ $zone }{ $dz_out }{ $net }{ $node }{points_dir}{ $points_dir };
681             }
682              
683             =head2 busy_protected_sub
684              
685             Expects two parameters:
686              
687             address going to be dealt with as a FTN::Addr object
688              
689             function reference that will receive passed address and us ($self) as parameters and which should do all required operations related to the passed address.
690              
691             This method infinitely waits (most likely will be changed in the future) until address is not busy. Then it creates busy flag and calls passed function reference providing itself as an argument for it. After function return removes created busy flag.
692              
693             Returns itself for chaining.
694              
695             =cut
696              
697             sub busy_protected_sub { # address, sub_ref( self ). (order busy, execute sub, remove busy)
698 0     0 1   my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
699              
700 0 0         ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
701              
702 0           my $addr = $self -> _validate_addr( shift );
703              
704 0 0 0       $logger -> logdie( 'no valid sub_ref passed' )
      0        
705             unless @_
706             && defined $_[ 0 ]
707             && 'CODE' eq ref $_[ 0 ];
708              
709 0           my $sub_ref = shift;
710              
711             $self -> scan
712 0 0         unless exists $self -> {scanned};
713              
714             # check that it's not already busy
715 0           while ( $self -> is_busy( $addr ) ) {
716 0           sleep( 4 ); # blocking...
717 0           $self -> scan;
718             }
719              
720             # here there are no busy flag for passed address. make it in best dir then
721 0           my $busy_name;
722              
723 0 0         if ( $addr -> point ) { # possible dir creation
724 0           $busy_name = File::Spec -> catfile( $self -> _select_points_dir( $addr -> domain,
725             $addr -> zone,
726             $addr -> net,
727             $addr -> node,
728             ),
729             sprintf( '%08x',
730             $addr -> point,
731             ),
732             );
733             } else {
734 0           my $dz_out = $self -> _select_domain_zone_dir( $addr -> domain,
735             $addr -> zone,
736             );
737              
738             $busy_name = File::Spec -> catfile( $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $dz_out }{dir},
739 0           sprintf( '%04x%04x',
740             $addr -> net,
741             $addr -> node,
742             ),
743             );
744             }
745 0           $busy_name .= '.' . $control_file_extension{busy};
746              
747 0           my $busy_name_fs = Encode::encode( locale_fs => $busy_name );
748              
749 0 0         sysopen my $fh, $busy_name_fs, Fcntl::O_WRONLY | Fcntl::O_CREAT | Fcntl::O_EXCL
750             or $logger -> logdie( 'cannot open %s for writing: %s',
751             $busy_name,
752             $!,
753             );
754              
755 0 0         flock $fh, Fcntl::LOCK_EX
756             or $logger -> logdie( q[can't flock file %s: %s],
757             $busy_name,
758             $!
759             );
760              
761             # For information purposes a bsy file may contain one line of PID information (less than 70 characters).
762 0           printf $fh '%d %s',
763             $$,
764             substr( __FILE__, 0, 70 - 1 - length( $$ ) );
765              
766 0           eval {
767 0           $sub_ref -> ( $addr,
768             $self,
769             );
770             };
771              
772             # remove busy first
773 0           close $fh;
774              
775 0 0         unlink $busy_name_fs
776             or $logger -> logwarn( sprintf 'could not unlink %s: %s',
777             $busy_name,
778             $!,
779             );
780              
781 0 0         if ( $@ ) { # something bad happened
782 0           $logger -> logdie( 'referenced sub execution failed: %s',
783             $@,
784             );
785             }
786              
787 0           $self;
788             }
789              
790             =head2 addr_file_to_change
791              
792             Expects arguments:
793              
794             address going to be dealt with as a FTN::Addr object
795              
796             file type as one of netmail, reference_file, file_request, busy, call, hold, try.
797              
798             If file type is netmail or reference_file, then next parameter should be its flavour: immediate, crash, direct, normal, hold.
799              
800             If optional function reference passed, then it will be called with one parameter - name of the file to process. After that information in internal structure about that file will be updated.
801              
802             Does not deal with busy flag implicitly. Recommended usage is in the function passed to busy_protected_sub.
803              
804             Returns full name of the file to process (might not exists though).
805              
806             =cut
807              
808             sub addr_file_to_change { # addr, type ( netmail, file_reference, .. ), [flavour], [ sub_ref( filename ) ].
809             # figures required filetype name (new or existing) and calls subref with that name.
810             # does not deal with busy implicitly
811             # returns full name of changed file (might not exist though)
812 0     0 1   my $logger = Log::Log4perl -> get_logger( __PACKAGE__ );
813              
814 0 0         ref( my $self = shift ) or $logger -> logcroak( "I'm only an object method!" );
815              
816 0           my $addr = $self -> _validate_addr( shift );
817              
818 0           my @flavoured = qw/ netmail
819             reference_file
820             /;
821              
822 0 0         $logger -> logdie( 'no type passed' )
823             unless @_;
824              
825 0 0 0       $logger -> logdie( sprintf 'incorrect type: %s',
    0          
826             defined $_[ 0 ] ? $_[ 0 ] : 'undef',
827             )
828             unless defined $_[ 0 ]
829             && grep $_[ 0 ] eq $_,
830             @flavoured,
831             keys %control_file_extension;
832              
833 0           my $type = shift;
834              
835 0 0         my $filename = $addr -> point ?
836             sprintf( '%08x.', $addr -> point )
837             : sprintf( '%04x%04x.',
838             $addr -> net,
839             $addr -> node,
840             );
841              
842 0           my $flavoured = grep $type eq $_, @flavoured;
843 0           my $flavour;
844 0 0         if ( $flavoured ) {
845 0 0         $logger -> logdie( 'no flavour passed' )
846             unless @_;
847              
848 0           $flavour = shift;
849              
850             $logger -> logdie( sprintf 'incorrect flavour: %s',
851             defined $flavour ? $flavour : 'undef',
852             )
853             unless defined $flavour
854 0 0 0       && exists $flavour_extension{ $flavour };
    0          
855              
856             $filename .= $type eq $flavoured[ 0 ] ? # netmail
857             $flavour_extension{ $flavour }[ 0 ]
858 0 0         : $flavour_extension{ $flavour }[ 1 ];
859             } else {
860 0           $filename .= $control_file_extension{ $type };
861             }
862              
863 0           my $sub_ref;
864              
865 0 0         if ( @_ ) { # possible sub ref
866 0 0 0       $logger -> logdie( 'no valid sub_ref passed' )
867             unless defined $_[ 0 ]
868             && 'CODE' eq ref $_[ 0 ];
869              
870 0           $sub_ref = shift;
871             }
872              
873              
874             $self -> scan
875 0 0         unless exists $self -> {scanned};
876              
877              
878             # check any outdir except our_domain.our_zone for already existing file
879 0           my $dz_out = $self -> _select_domain_zone_dir( $addr -> domain, $addr -> zone );
880              
881             my @dz_out_with_existing_file = grep exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }
882             && exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }
883             && exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }
884             && exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }{ $type }
885             && ( ! $flavoured
886             || exists $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }{ $type }{ $flavour }
887             ),
888             grep length $_ == length $dz_out, # to filter out our_domain.our_zone versions
889 0   0       keys %{ $self -> {scanned}{ $addr -> domain }{ $addr -> zone } };
  0            
890              
891 0           my $full_filename;
892              
893 0 0         if ( @dz_out_with_existing_file ) { # file exists
894 0 0         unless ( grep $dz_out eq $_,
895             @dz_out_with_existing_file
896             ) { # best domain.zone does not have existing file. let's select best of the worst
897             # first try to find one with best formatted file
898             my ( $t ) = grep {
899 0           my $r = $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $_ }{ $addr -> net }{ $addr -> node }{ $addr -> point }{ $type };
  0            
900              
901 0 0         $r = $r -> { $flavour }
902             if $flavoured;
903              
904             grep $filename eq $_ -> {name},
905 0           @$r;
906             } @dz_out_with_existing_file;
907              
908 0 0         $dz_out = $t ? $t : $dz_out_with_existing_file[ 0 ]; # or just very first one
909             }
910              
911             # here we've got dz_out with existing file
912 0           my $r = $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $dz_out }{ $addr -> net }{ $addr -> node }{ $addr -> point }{ $type };
913              
914 0 0         $r = $r -> { $flavour }
915             if $flavoured;
916              
917             $filename = $r -> [ 0 ]{name}
918             unless grep $filename eq $_ -> {name}, # no best file name
919 0 0         @$r;
920              
921             ( $full_filename ) = map $_ -> {full_name},
922             grep $filename eq $_ -> {name},
923 0           @$r;
924              
925             # and remove it..
926 0           @$r = grep $filename ne $_ -> {name}, @$r;
927             } else { # no file - create it
928             $full_filename = File::Spec -> catfile( $addr -> point ?
929             $self -> _select_points_dir( $addr -> domain,
930             $addr -> zone,
931             $addr -> net,
932             $addr -> node,
933             )
934             : $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $dz_out }{dir},
935 0 0         $filename,
936             );
937             }
938              
939 0 0         if ( $sub_ref ) {
940 0           eval {
941 0           $sub_ref -> ( $full_filename );
942             };
943              
944 0 0         if ( $@ ) { # something bad happened
945 0           $logger -> logdie( sprintf 'referenced sub execution failed: %s',
946             $@,
947             );
948             }
949              
950             # update file information in internal structure
951             # first remove existing record about file (if it's known)
952             {
953 0           my $r = $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $dz_out }{ $addr -> net }{ $addr -> node }{ $addr -> point }{ $type };
  0            
954              
955 0 0         $r = $r -> { $flavour }
956             if $flavoured;
957              
958 0           my ( $record_idx ) = grep $_ -> {full_name} eq $full_filename, 0 .. $#$r;
959 0 0         splice @$r, $record_idx, 1
960             if defined $record_idx;
961              
962             # might be a good idea to remove empty parents as well if there was just one file
963             }
964              
965 0 0         if ( -e Encode::encode( locale_fs => $full_filename ) ) {
966 0           my $r = $self -> {scanned}{ $addr -> domain }{ $addr -> zone }{ $dz_out }{ $addr -> net }{ $addr -> node }{ $addr -> point }{ $type };
967              
968 0 0         $r = $r -> { $flavour }
969             if $flavoured;
970              
971 0           my %file_prop = ( name => $filename,
972             full_name => $full_filename,
973             mstat => ( stat _ )[ 9 ],
974             size => -s _,
975             );
976              
977             $file_prop{referenced_files} =
978             FTN::Outbound::Reference_file
979             -> new( $file_prop{full_name},
980             $self -> {reference_file_read_line_transform_sub},
981             )
982             -> read_existing_file
983             -> referenced_files
984             if $type eq 'reference_file'
985             && $file_prop{size} # empty files are empty, right?
986 0 0 0       && exists $self -> {reference_file_read_line_transform_sub};
      0        
987              
988 0           push @$r, \ %file_prop;
989             }
990             }
991              
992             # what to return - just full name or open handle? handle probably better (can update scanned structure, but buffered/unbuffered? access details?)
993             # let's try full name first
994 0           $full_filename;
995             }
996              
997             1;