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; |