line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/bin/perl -w |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Copyright (C) 2002-2016 National Marrow Donor Program. All rights reserved. |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# For a description of this module, please refer to the POD documentation |
6
|
|
|
|
|
|
|
# embedded at the bottom of the file (e.g. perldoc EMDIS::ECS). |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
package EMDIS::ECS; |
9
|
|
|
|
|
|
|
|
10
|
6
|
|
|
6
|
|
13482
|
use CPAN::Version; |
|
6
|
|
|
|
|
7275
|
|
|
6
|
|
|
|
|
322
|
|
11
|
6
|
|
|
6
|
|
42
|
use Fcntl qw(:DEFAULT :flock); |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
1754
|
|
12
|
6
|
|
|
6
|
|
47
|
use File::Basename; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
343
|
|
13
|
6
|
|
|
6
|
|
2470
|
use File::Copy; |
|
6
|
|
|
|
|
23362
|
|
|
6
|
|
|
|
|
348
|
|
14
|
6
|
|
|
6
|
|
43
|
use File::Spec::Functions qw(catfile); |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
247
|
|
15
|
6
|
|
|
6
|
|
4482
|
use File::Temp qw(tempfile); |
|
6
|
|
|
|
|
124740
|
|
|
6
|
|
|
|
|
372
|
|
16
|
6
|
|
|
6
|
|
2865
|
use IO::File; |
|
6
|
|
|
|
|
5640
|
|
|
6
|
|
|
|
|
1068
|
|
17
|
6
|
|
|
6
|
|
44
|
use IO::Handle; |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
198
|
|
18
|
6
|
|
|
6
|
|
2765
|
use IPC::Open2; |
|
6
|
|
|
|
|
20881
|
|
|
6
|
|
|
|
|
311
|
|
19
|
6
|
|
|
6
|
|
3476
|
use Net::SMTP; |
|
6
|
|
|
|
|
551863
|
|
|
6
|
|
|
|
|
332
|
|
20
|
6
|
|
|
6
|
|
48
|
use strict; |
|
6
|
|
|
|
|
18
|
|
|
6
|
|
|
|
|
203
|
|
21
|
6
|
|
|
|
|
883
|
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS |
22
|
|
|
|
|
|
|
$ECS_CFG $ECS_NODE_TBL $FILEMODE @LOG_LEVEL |
23
|
6
|
|
|
6
|
|
33
|
$configured $pidfile $cmd_output $pid_saved); |
|
6
|
|
|
|
|
16
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# load OS specific modules at compile time, in BEGIN block |
26
|
|
|
|
|
|
|
BEGIN |
27
|
|
|
|
|
|
|
{ |
28
|
6
|
50
|
|
6
|
|
666
|
if( $^O =~ /MSWin32/ ) |
29
|
|
|
|
|
|
|
{ |
30
|
|
|
|
|
|
|
# Win32 only modules |
31
|
0
|
|
|
|
|
0
|
eval "require Win32::Process"; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# module/package version |
36
|
|
|
|
|
|
|
$VERSION = '0.40'; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# file creation mode (octal, a la chmod) |
39
|
|
|
|
|
|
|
$FILEMODE = 0660; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# subclass Exporter and define Exporter set up |
42
|
|
|
|
|
|
|
require Exporter; |
43
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
44
|
|
|
|
|
|
|
@EXPORT = (); # items exported by default |
45
|
|
|
|
|
|
|
@EXPORT_OK = (); # items exported by request |
46
|
|
|
|
|
|
|
%EXPORT_TAGS = ( # tags for groups of items |
47
|
|
|
|
|
|
|
ALL => [ qw($ECS_CFG $ECS_NODE_TBL $FILEMODE $VERSION |
48
|
|
|
|
|
|
|
load_ecs_config delete_old_files dequote ecs_is_configured |
49
|
|
|
|
|
|
|
log log_debug log_info log_warn log_error log_fatal |
50
|
|
|
|
|
|
|
copy_to_dir move_to_dir read_ecs_message_id |
51
|
|
|
|
|
|
|
send_admin_email send_ecsmsg_email |
52
|
|
|
|
|
|
|
send_email send_encrypted_email format_datetime |
53
|
|
|
|
|
|
|
format_msg_filename openpgp_decrypt openpgp_encrypt |
54
|
|
|
|
|
|
|
pgp2_decrypt pgp2_encrypt check_pid save_pid |
55
|
|
|
|
|
|
|
timelimit_cmd remove_pidfile trim valid_encr_typ EOL |
56
|
|
|
|
|
|
|
is_yes is_no) ] ); |
57
|
|
|
|
|
|
|
Exporter::export_ok_tags('ALL'); # use tag handling fn to define EXPORT_OK |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
BEGIN { |
60
|
6
|
|
|
6
|
|
25
|
$configured = ''; # boolean indicates whether ECS has been configured |
61
|
6
|
|
|
|
|
17
|
@LOG_LEVEL = ('DEBUG', 'INFO', 'WARNING', 'ERROR', 'FATAL'); |
62
|
6
|
|
|
|
|
38412
|
$pid_saved = ''; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
66
|
|
|
|
|
|
|
# Return platform specific end-of-line string |
67
|
|
|
|
|
|
|
sub EOL |
68
|
|
|
|
|
|
|
{ |
69
|
0
|
0
|
|
0
|
0
|
0
|
return "\r\n" if $^O =~ /MSWin32/; |
70
|
0
|
|
|
|
|
0
|
return "\n"; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
74
|
|
|
|
|
|
|
# test for YES or TRUE |
75
|
|
|
|
|
|
|
sub is_yes |
76
|
|
|
|
|
|
|
{ |
77
|
54
|
|
|
54
|
0
|
91
|
my $val = shift; |
78
|
54
|
50
|
|
|
|
95
|
return 0 if not defined $val; |
79
|
54
|
100
|
100
|
|
|
293
|
return 1 if $val =~ /^\s*YES\s*$/io or $val =~ /^\s*TRUE\s*$/io; |
80
|
36
|
|
|
|
|
170
|
return 0; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
84
|
|
|
|
|
|
|
# test for NO or FALSE |
85
|
|
|
|
|
|
|
sub is_no |
86
|
|
|
|
|
|
|
{ |
87
|
22
|
|
|
22
|
0
|
37
|
my $val = shift; |
88
|
22
|
50
|
|
|
|
41
|
return 0 if not defined $val; |
89
|
22
|
100
|
100
|
|
|
159
|
return 1 if $val =~ /^\s*NO\s*$/io or $val =~ /^\s*FALSE\s*$/io; |
90
|
7
|
|
|
|
|
26
|
return 0; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
94
|
|
|
|
|
|
|
# Load ECS configuration into global variables. |
95
|
|
|
|
|
|
|
# returns empty string if successful or error message if error encountered |
96
|
|
|
|
|
|
|
sub load_ecs_config |
97
|
|
|
|
|
|
|
{ |
98
|
0
|
|
|
0
|
0
|
0
|
my $cfg_file = shift; |
99
|
|
|
|
|
|
|
|
100
|
0
|
|
|
|
|
0
|
require EMDIS::ECS::Config; |
101
|
0
|
|
|
|
|
0
|
my $cfg = new EMDIS::ECS::Config($cfg_file); |
102
|
0
|
0
|
|
|
|
0
|
return "Unable to load ECS configuration ($cfg_file): $cfg" |
103
|
|
|
|
|
|
|
unless ref $cfg; |
104
|
|
|
|
|
|
|
|
105
|
0
|
|
|
|
|
0
|
require EMDIS::ECS::LockedHash; |
106
|
0
|
|
|
|
|
0
|
my $node_tbl = new EMDIS::ECS::LockedHash($cfg->NODE_TBL, $cfg->NODE_TBL_LCK); |
107
|
0
|
0
|
|
|
|
0
|
return "Unable to open ECS node_tbl (" . $cfg->NODE_TBL . |
108
|
|
|
|
|
|
|
"): $node_tbl" |
109
|
|
|
|
|
|
|
unless ref $node_tbl; |
110
|
|
|
|
|
|
|
|
111
|
0
|
|
|
|
|
0
|
$pidfile = catfile($cfg->ECS_DAT_DIR, basename($0) . ".pid"); |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# assign values to global config variables |
114
|
0
|
|
|
|
|
0
|
$ECS_CFG = $cfg; |
115
|
0
|
|
|
|
|
0
|
$ECS_NODE_TBL = $node_tbl; |
116
|
0
|
|
|
|
|
0
|
$configured = 1; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# successful |
119
|
0
|
|
|
|
|
0
|
return ''; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
123
|
|
|
|
|
|
|
# delete old files (mtime < cutoff time) from specified directory |
124
|
|
|
|
|
|
|
# no recursion |
125
|
|
|
|
|
|
|
sub delete_old_files |
126
|
|
|
|
|
|
|
{ |
127
|
0
|
|
|
0
|
0
|
0
|
my $dirname = shift; |
128
|
0
|
|
|
|
|
0
|
my $cutoff_time = shift; |
129
|
|
|
|
|
|
|
|
130
|
0
|
0
|
|
|
|
0
|
if(! -d $dirname) |
131
|
|
|
|
|
|
|
{ |
132
|
0
|
|
|
|
|
0
|
warn "Not a directory name: $dirname"; |
133
|
0
|
|
|
|
|
0
|
return; |
134
|
|
|
|
|
|
|
} |
135
|
0
|
0
|
|
|
|
0
|
if($cutoff_time !~ /^\d+$/) |
136
|
|
|
|
|
|
|
{ |
137
|
0
|
|
|
|
|
0
|
warn "Cutoff time not numeric: $cutoff_time"; |
138
|
0
|
|
|
|
|
0
|
return; |
139
|
|
|
|
|
|
|
} |
140
|
0
|
|
|
|
|
0
|
opendir DELDIR, $dirname; |
141
|
0
|
|
|
|
|
0
|
my @names = readdir DELDIR; |
142
|
0
|
|
|
|
|
0
|
closedir DELDIR; |
143
|
0
|
|
|
|
|
0
|
foreach my $name (@names) |
144
|
|
|
|
|
|
|
{ |
145
|
0
|
|
|
|
|
0
|
my $filename = catfile($dirname, $name); |
146
|
0
|
0
|
|
|
|
0
|
next unless -f $filename; |
147
|
|
|
|
|
|
|
# delete file if mtime < $cutoff_time |
148
|
0
|
|
|
|
|
0
|
my @stat = stat $filename; |
149
|
0
|
0
|
|
|
|
0
|
if($stat[9] < $cutoff_time) |
150
|
|
|
|
|
|
|
{ |
151
|
0
|
0
|
|
|
|
0
|
unlink $filename |
152
|
|
|
|
|
|
|
or warn "Unable to delete file: $filename"; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
158
|
|
|
|
|
|
|
# Return string value with enclosing single or double quotes removed. |
159
|
|
|
|
|
|
|
sub dequote { |
160
|
16
|
|
|
16
|
0
|
1219
|
my $str = shift; |
161
|
16
|
50
|
|
|
|
37
|
return if not defined $str; |
162
|
16
|
100
|
|
|
|
63
|
if($str =~ /^"(.*)"$/) { |
|
|
100
|
|
|
|
|
|
163
|
9
|
|
|
|
|
41
|
$str = $1; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
elsif($str =~ /^'(.*)'$/) { |
166
|
1
|
|
|
|
|
2
|
$str = $1; |
167
|
|
|
|
|
|
|
} |
168
|
16
|
|
|
|
|
53
|
return $str; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
172
|
|
|
|
|
|
|
# Return boolean indicating whether ECS has been configured. |
173
|
|
|
|
|
|
|
sub ecs_is_configured { |
174
|
61
|
|
|
61
|
0
|
278
|
return $configured; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
178
|
|
|
|
|
|
|
# Write message to ECS log file. Takes two arguments: a level which is |
179
|
|
|
|
|
|
|
# used to classify logged messages and the text to be logged. |
180
|
|
|
|
|
|
|
# Push an aditional email to admin if the error is encountering |
181
|
|
|
|
|
|
|
# the MAIL_LEVEL. |
182
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
183
|
|
|
|
|
|
|
sub log { |
184
|
6
|
50
|
|
6
|
0
|
10
|
if(not ecs_is_configured()) { |
185
|
6
|
|
|
|
|
9
|
my $warning = "EMDIS::ECS::log(): ECS has not been configured."; |
186
|
6
|
|
|
|
|
59
|
warn "$warning\n"; |
187
|
6
|
|
|
|
|
121
|
return $warning; |
188
|
|
|
|
|
|
|
} |
189
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
190
|
0
|
|
|
|
|
0
|
my $level = shift; |
191
|
0
|
0
|
0
|
|
|
0
|
$level = '1' if (not defined $level) or |
|
|
|
0
|
|
|
|
|
192
|
|
|
|
|
|
|
($level < 0) or ($level > $#LOG_LEVEL); |
193
|
0
|
0
|
0
|
|
|
0
|
return if $level < $cfg->LOG_LEVEL && ! $cfg->ECS_DEBUG; # check log-level |
194
|
0
|
|
|
|
|
0
|
my $text = join("\n ", @_); |
195
|
0
|
0
|
|
|
|
0
|
$text = '' if not defined $text; |
196
|
0
|
|
|
|
|
0
|
my $timestamp = localtime; |
197
|
0
|
|
|
|
|
0
|
my $origin = $0; |
198
|
|
|
|
|
|
|
|
199
|
0
|
|
|
|
|
0
|
my $setmode = not -e $cfg->LOG_FILE; |
200
|
0
|
0
|
|
|
|
0
|
open LOG, ">>" . $cfg->LOG_FILE or do { |
201
|
0
|
|
|
|
|
0
|
warn "Error within ECS library: $! " . $cfg->LOG_FILE; |
202
|
0
|
|
|
|
|
0
|
return; |
203
|
|
|
|
|
|
|
}; |
204
|
0
|
|
|
|
|
0
|
print LOG join("|",$timestamp,$origin,$LOG_LEVEL[$level],$text),"\n"; |
205
|
0
|
|
|
|
|
0
|
close LOG; |
206
|
0
|
0
|
|
|
|
0
|
chmod $FILEMODE, $cfg->LOG_FILE if $setmode; |
207
|
0
|
0
|
|
|
|
0
|
if ( $level >= $cfg->MAIL_LEVEL ) |
208
|
|
|
|
|
|
|
{ |
209
|
0
|
|
|
|
|
0
|
send_admin_email (join("|",$timestamp,$origin,$LOG_LEVEL[$level],$text)); |
210
|
|
|
|
|
|
|
} |
211
|
0
|
|
|
|
|
0
|
return ''; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
# logging subroutines for specific logging levels |
214
|
1
|
|
|
1
|
0
|
3
|
sub log_debug { return &log(0, @_); } |
215
|
1
|
|
|
1
|
0
|
4
|
sub log_info { return &log(1, @_); } |
216
|
1
|
|
|
1
|
0
|
4
|
sub log_warn { return &log(2, @_); } |
217
|
1
|
|
|
1
|
0
|
3
|
sub log_error { return &log(3, @_); } |
218
|
1
|
|
|
1
|
0
|
4
|
sub log_fatal { return &log(4, @_); } |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
221
|
|
|
|
|
|
|
# Copy file to specified directory. If necessary, rename file to avoid |
222
|
|
|
|
|
|
|
# filename collision. |
223
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
224
|
|
|
|
|
|
|
sub copy_to_dir { |
225
|
0
|
|
|
0
|
0
|
0
|
my $filename = shift; |
226
|
0
|
|
|
|
|
0
|
my $targetdir = shift; |
227
|
0
|
|
|
|
|
0
|
my $err; |
228
|
|
|
|
|
|
|
|
229
|
0
|
0
|
|
|
|
0
|
return "file not found: $filename" unless -f $filename; |
230
|
0
|
0
|
|
|
|
0
|
return "directory not found: $targetdir" unless -d $targetdir; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# do some fancy footwork to avoid name collision in target dir, |
233
|
|
|
|
|
|
|
# then copy file |
234
|
0
|
|
|
|
|
0
|
my $basename = basename($filename); |
235
|
0
|
|
|
|
|
0
|
my $template = $basename; |
236
|
0
|
|
|
|
|
0
|
my $suffix = ''; |
237
|
0
|
0
|
|
|
|
0
|
if($basename =~ /^(\d{8}_\d{6}_(.+_)?).{4}(\..{3})$/) { |
238
|
0
|
|
|
|
|
0
|
$template = "$1XXXX"; |
239
|
0
|
|
|
|
|
0
|
$suffix = $3; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
else { |
242
|
0
|
|
|
|
|
0
|
$template .= '_XXXX'; |
243
|
|
|
|
|
|
|
} |
244
|
0
|
|
|
|
|
0
|
my ($fh, $tempfilename) = tempfile($template, |
245
|
|
|
|
|
|
|
DIR => $targetdir, |
246
|
|
|
|
|
|
|
SUFFIX => $suffix); |
247
|
0
|
0
|
|
|
|
0
|
return "unable to open tempfile in directory $targetdir: $!" |
248
|
|
|
|
|
|
|
unless $fh; |
249
|
0
|
0
|
|
|
|
0
|
$err = "unable to copy $filename to $tempfilename: $!" |
250
|
|
|
|
|
|
|
unless copy($filename, $fh); |
251
|
0
|
|
|
|
|
0
|
close $fh; |
252
|
0
|
|
|
|
|
0
|
chmod $FILEMODE, $tempfilename; |
253
|
0
|
|
|
|
|
0
|
return $err; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
257
|
|
|
|
|
|
|
# Move file to specified directory. If necessary, rename file to avoid |
258
|
|
|
|
|
|
|
# filename collision. |
259
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
260
|
|
|
|
|
|
|
sub move_to_dir { |
261
|
0
|
|
|
0
|
0
|
0
|
my $filename = shift; |
262
|
0
|
|
|
|
|
0
|
my $targetdir = shift; |
263
|
|
|
|
|
|
|
|
264
|
0
|
|
|
|
|
0
|
my $err = copy_to_dir($filename, $targetdir); |
265
|
0
|
0
|
|
|
|
0
|
unlink $filename unless $err; |
266
|
0
|
|
|
|
|
0
|
return $err; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
270
|
|
|
|
|
|
|
# Read ECS message id from specified file. File is presumed to be in the |
271
|
|
|
|
|
|
|
# format of an email message; message id is comprised of node_id and seq_num, |
272
|
|
|
|
|
|
|
# with optional $part_num and $num_parts. |
273
|
|
|
|
|
|
|
# Returns empty array if unable to retrieve ECS message id from file. |
274
|
|
|
|
|
|
|
sub read_ecs_message_id |
275
|
|
|
|
|
|
|
{ |
276
|
9
|
|
|
9
|
0
|
1642
|
my $filename = shift; |
277
|
|
|
|
|
|
|
|
278
|
9
|
100
|
|
|
|
19
|
return "EMDIS::ECS::read_ecs_message_id(): ECS has not been configured." |
279
|
|
|
|
|
|
|
unless ecs_is_configured(); |
280
|
8
|
|
|
|
|
50
|
my $mail_mrk = $ECS_CFG->MAIL_MRK; |
281
|
|
|
|
|
|
|
|
282
|
8
|
|
|
|
|
48
|
my $fh = new IO::File; |
283
|
8
|
50
|
|
|
|
245
|
return () unless $fh->open("< $filename"); |
284
|
8
|
|
|
|
|
555
|
while(<$fh>) { |
285
|
10
|
100
|
|
|
|
66
|
/^Subject:.*$mail_mrk:(\S+?):(\d+):(\d+)\/(\d+)\s*$/io and do { |
286
|
1
|
|
|
|
|
34
|
return ($1,$2,$3,$4); |
287
|
|
|
|
|
|
|
}; |
288
|
9
|
100
|
|
|
|
41
|
/^Subject:.*$mail_mrk:(\S+?):(\d+)\s*$/io and do { |
289
|
4
|
|
|
|
|
93
|
return ($1,$2,1,1); |
290
|
|
|
|
|
|
|
}; |
291
|
5
|
100
|
|
|
|
29
|
/^Subject:.*$mail_mrk:(\S+)\s*$/io and do { |
292
|
1
|
|
|
|
|
25
|
return ($1,undef,undef,undef); |
293
|
|
|
|
|
|
|
}; |
294
|
4
|
100
|
|
|
|
16
|
/^$/ and last; # blank line marks end of mail headers |
295
|
|
|
|
|
|
|
} |
296
|
2
|
|
|
|
|
25
|
close $fh; |
297
|
2
|
|
|
|
|
15
|
return (); # return empty array |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
301
|
|
|
|
|
|
|
# Send email to administrator and also archive the email message in the |
302
|
|
|
|
|
|
|
# mboxes/out directory. Takes one or more arguments: the body lines to |
303
|
|
|
|
|
|
|
# be emailed. |
304
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
305
|
|
|
|
|
|
|
# Also logs error if error encountered. |
306
|
|
|
|
|
|
|
sub send_admin_email { |
307
|
|
|
|
|
|
|
|
308
|
1
|
|
|
1
|
0
|
2
|
my $err = ''; |
309
|
1
|
50
|
|
|
|
2
|
$err = "EMDIS::ECS::send_admin_email(): ECS has not been configured." |
310
|
|
|
|
|
|
|
unless ecs_is_configured(); |
311
|
1
|
|
|
|
|
2
|
my $cfg = $ECS_CFG; |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# record message contents in 'out' file |
314
|
1
|
50
|
|
|
|
3
|
if(not $err) { |
315
|
0
|
|
|
|
|
0
|
my $template = format_datetime(time, '%04d%02d%02d_%02d%02d%02d_XXXX'); |
316
|
0
|
|
|
|
|
0
|
my ($fh, $filename) = tempfile($template, |
317
|
|
|
|
|
|
|
DIR => $cfg->ECS_MBX_OUT_DIR, |
318
|
|
|
|
|
|
|
SUFFIX => '.msg'); |
319
|
0
|
0
|
|
|
|
0
|
$err = "EMDIS::ECS::send_admin_email(): unable to create 'out' file" |
320
|
|
|
|
|
|
|
unless $fh; |
321
|
0
|
0
|
|
|
|
0
|
if($fh) { |
322
|
0
|
|
|
|
|
0
|
print $fh @_; |
323
|
0
|
|
|
|
|
0
|
close $fh; |
324
|
0
|
|
|
|
|
0
|
chmod $FILEMODE, $filename; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
1
|
50
|
|
|
|
3
|
if(not $err) |
329
|
|
|
|
|
|
|
{ |
330
|
0
|
|
|
|
|
0
|
my @recipients = split /,/, $cfg->ADM_ADDR; |
331
|
0
|
|
|
|
|
0
|
foreach my $recipient (@recipients) |
332
|
|
|
|
|
|
|
{ |
333
|
0
|
|
|
|
|
0
|
$err = send_email($recipient, '[' . $cfg->MAIL_MRK . '] ECS Error', |
334
|
|
|
|
|
|
|
"Origin: $0\n", @_); |
335
|
|
|
|
|
|
|
|
336
|
0
|
0
|
0
|
|
|
0
|
log_error("Unable to send admin email to $recipient: $err") |
337
|
|
|
|
|
|
|
if $err and $_[$#_] !~ /Unable to send admin email/iso; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
1
|
|
|
|
|
20
|
return $err; |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
345
|
|
|
|
|
|
|
# Send ECS email message. |
346
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
347
|
|
|
|
|
|
|
sub send_ecsmsg_email { |
348
|
1
|
|
|
1
|
0
|
3
|
my $node_id = shift; |
349
|
1
|
|
|
|
|
2
|
my $seq_num = shift; |
350
|
|
|
|
|
|
|
# @_ now contains message body |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
# initialize |
353
|
1
|
50
|
|
|
|
2
|
return "EMDIS::ECS::send_ecsmsg_email(): ECS has not been configured." |
354
|
|
|
|
|
|
|
unless ecs_is_configured(); |
355
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
356
|
0
|
|
|
|
|
0
|
my $node_tbl = $ECS_NODE_TBL; |
357
|
0
|
|
|
|
|
0
|
my $err = ''; |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
# do some validation |
360
|
0
|
|
|
|
|
0
|
my ($hub_rcv, $hub_snd); |
361
|
0
|
0
|
0
|
|
|
0
|
if($seq_num && !$node_id) { |
362
|
|
|
|
|
|
|
# parse FML to determing $node_id: |
363
|
|
|
|
|
|
|
# do some cursory validation, extract HUB_RCV and HUB_SND |
364
|
0
|
|
|
|
|
0
|
my $fml = join('', @_); |
365
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): message does not contain valid FML" |
366
|
|
|
|
|
|
|
unless $fml =~ /^.+:.+;/s; |
367
|
0
|
0
|
|
|
|
0
|
if($fml =~ /HUB_RCV\s*=\s*([^,;]+)/is) { # presumes [^,;] in HUB_RCV |
368
|
0
|
|
|
|
|
0
|
$hub_rcv = dequote(trim($1)); |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
else { |
371
|
0
|
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): message does not specify " . |
372
|
|
|
|
|
|
|
"HUB_RCV"; |
373
|
|
|
|
|
|
|
} |
374
|
0
|
0
|
|
|
|
0
|
if($fml =~ /HUB_SND\s*=\s*([^,;]+)/is) { # presumes [^,;] in HUB_SND |
375
|
0
|
|
|
|
|
0
|
$hub_snd = dequote(trim($1)); |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
else { |
378
|
0
|
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): message does not specify " . |
379
|
|
|
|
|
|
|
"HUB_SND"; |
380
|
|
|
|
|
|
|
} |
381
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): HUB_SND is incorrect: $hub_snd" |
382
|
|
|
|
|
|
|
unless $hub_snd eq $ECS_CFG->THIS_NODE; |
383
|
0
|
0
|
|
|
|
0
|
$node_id = $hub_rcv unless $node_id; |
384
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): node_id ($node_id) and FML " . |
385
|
|
|
|
|
|
|
"HUB_RCV ($hub_rcv) do not match" |
386
|
|
|
|
|
|
|
unless $node_id eq $hub_rcv; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
# look up specified node in node_tbl |
390
|
0
|
|
|
|
|
0
|
my $was_locked = $node_tbl->LOCK; |
391
|
0
|
0
|
|
|
|
0
|
if(not $was_locked) { |
392
|
0
|
0
|
|
|
|
0
|
$node_tbl->lock() # lock node_tbl if needed |
393
|
|
|
|
|
|
|
or return "EMDIS::ECS::send_ecsmsg_email(): unable to lock node_tbl: " . |
394
|
|
|
|
|
|
|
$node_tbl->ERROR; |
395
|
|
|
|
|
|
|
} |
396
|
0
|
|
|
|
|
0
|
my $node = $node_tbl->read($node_id); |
397
|
0
|
0
|
|
|
|
0
|
if(not $node) { |
398
|
0
|
0
|
|
|
|
0
|
$node_tbl->unlock() unless $was_locked; # unlock node_tbl if needed |
399
|
0
|
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): node not found: " . $node_id; |
400
|
|
|
|
|
|
|
} |
401
|
0
|
0
|
|
|
|
0
|
if(not $node->{addr}) { |
402
|
0
|
0
|
|
|
|
0
|
$node_tbl->unlock() unless $was_locked; # unlock node_tbl if needed |
403
|
0
|
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): addr not defined for node: $node_id"; |
404
|
|
|
|
|
|
|
} |
405
|
0
|
0
|
|
|
|
0
|
if($seq_num =~ /auto/i) { |
406
|
|
|
|
|
|
|
# automatically get next sequence number |
407
|
0
|
|
|
|
|
0
|
$node->{out_seq}++; |
408
|
0
|
|
|
|
|
0
|
$seq_num = $node->{out_seq}; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
0
|
|
|
|
|
0
|
my $subject = $cfg->MAIL_MRK . ':' . $cfg->THIS_NODE; |
412
|
0
|
0
|
|
|
|
0
|
$subject .= ":$seq_num" if $seq_num; |
413
|
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
0
|
my $filename; |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
# if not meta-message, copy to mboxes/out_NODE subdirectory |
417
|
0
|
0
|
|
|
|
0
|
if($seq_num) { |
418
|
0
|
|
|
|
|
0
|
$filename = format_msg_filename($node_id,$seq_num); |
419
|
|
|
|
|
|
|
# create directory if it doesn't already exist |
420
|
0
|
|
|
|
|
0
|
my $dirname = dirname($filename); |
421
|
0
|
0
|
|
|
|
0
|
mkdir $dirname unless -e $dirname; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
else { |
424
|
|
|
|
|
|
|
# if meta-message, copy to mboxes/out subdirectory |
425
|
0
|
|
|
|
|
0
|
$filename = sprintf("%s_%s_%s.msg", |
426
|
|
|
|
|
|
|
$cfg->THIS_NODE, $node_id, "META"); |
427
|
0
|
|
|
|
|
0
|
my $dirname = $cfg->ECS_MBX_OUT_DIR; |
428
|
|
|
|
|
|
|
# create directory if it doesn't already exist |
429
|
0
|
0
|
|
|
|
0
|
mkdir $dirname unless -e $dirname; |
430
|
0
|
|
|
|
|
0
|
$filename = catfile($dirname, $filename); |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# don't overwrite $filename file if it already exists |
434
|
0
|
|
|
|
|
0
|
my $fh; |
435
|
0
|
0
|
|
|
|
0
|
if(-e $filename) { |
436
|
0
|
|
|
|
|
0
|
my $template = $filename . "_XXXX"; |
437
|
0
|
|
|
|
|
0
|
($fh, $filename) = tempfile($template); |
438
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): unable to open _XXXX file: " . |
439
|
|
|
|
|
|
|
"$filename" |
440
|
|
|
|
|
|
|
unless $fh; |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
else { |
443
|
0
|
|
|
|
|
0
|
$fh = new IO::File; |
444
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_ecsmsg_email(): unable to open file: " . |
445
|
|
|
|
|
|
|
"$filename" |
446
|
|
|
|
|
|
|
unless $fh->open("> $filename"); |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
|
449
|
0
|
|
|
|
|
0
|
$fh->print("Subject: $subject\n"); |
450
|
0
|
|
|
|
|
0
|
$fh->print("To: $node->{addr}\n"); |
451
|
0
|
|
|
|
|
0
|
$fh->print("From: " . $cfg->SMTP_FROM . "\n\n"); |
452
|
0
|
|
|
|
|
0
|
$fh->print(@_); |
453
|
0
|
|
|
|
|
0
|
$fh->close(); |
454
|
0
|
|
|
|
|
0
|
chmod $FILEMODE, $filename; |
455
|
|
|
|
|
|
|
|
456
|
0
|
0
|
0
|
|
|
0
|
if ( $err ) { |
|
|
0
|
|
|
|
|
|
457
|
0
|
|
|
|
|
0
|
$err = "EMDIS::ECS::send_ecsmsg_email(): unable to update node $node_id: $err"; |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
elsif ( not $seq_num and ($node->{encr_meta} !~ /true/i) ) { |
460
|
|
|
|
|
|
|
# if indicated, don't encrypt meta-message |
461
|
0
|
|
|
|
|
0
|
$err = send_email($node->{addr}, $subject, @_) |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
else { |
464
|
|
|
|
|
|
|
# otherwise, send encrypted message |
465
|
|
|
|
|
|
|
$err = send_encrypted_email( |
466
|
|
|
|
|
|
|
$node->{encr_typ}, |
467
|
|
|
|
|
|
|
$node->{addr_r}, |
468
|
|
|
|
|
|
|
$node->{addr}, |
469
|
|
|
|
|
|
|
$node->{encr_out_keyid}, |
470
|
|
|
|
|
|
|
$node->{encr_out_passphrase}, |
471
|
0
|
|
|
|
|
0
|
$subject, |
472
|
|
|
|
|
|
|
@_); |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
0
|
0
|
|
|
|
0
|
if ( ! $err ) { |
476
|
|
|
|
|
|
|
# update node last_out, possibly out_seq |
477
|
0
|
|
|
|
|
0
|
$node->{last_out} = time(); |
478
|
0
|
0
|
|
|
|
0
|
$err = $node_tbl->ERROR |
479
|
|
|
|
|
|
|
unless $node_tbl->write($node_id, $node); |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
$node_tbl->unlock() # unlock node_tbl |
482
|
0
|
0
|
|
|
|
0
|
unless $was_locked; |
483
|
|
|
|
|
|
|
|
484
|
0
|
|
|
|
|
0
|
return $err; |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
488
|
|
|
|
|
|
|
# Send email message. Takes three or more arguments: the recipient, |
489
|
|
|
|
|
|
|
# subject line, and body lines to be emailed. |
490
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
491
|
|
|
|
|
|
|
sub send_email { |
492
|
1
|
|
|
1
|
0
|
2
|
my $recipient = shift; |
493
|
1
|
|
|
|
|
2
|
my $subject = shift; |
494
|
|
|
|
|
|
|
# @_ now contains message body |
495
|
|
|
|
|
|
|
|
496
|
1
|
50
|
|
|
|
2
|
return "EMDIS::ECS::send_email(): ECS has not been configured." |
497
|
|
|
|
|
|
|
unless ecs_is_configured(); |
498
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
499
|
|
|
|
|
|
|
|
500
|
0
|
|
|
|
|
0
|
my $smtp; |
501
|
0
|
0
|
0
|
|
|
0
|
if(is_yes($cfg->SMTP_USE_SSL) or is_yes($cfg->SMTP_USE_STARTTLS)) { |
502
|
0
|
0
|
|
|
|
0
|
return "To use SSL or TLS please install Net::SMTP with version >= 3.05" |
503
|
|
|
|
|
|
|
if CPAN::Version->vlt($Net::SMTP::VERSION, '3.05'); |
504
|
|
|
|
|
|
|
} |
505
|
0
|
0
|
|
|
|
0
|
if(is_yes($cfg->SMTP_USE_SSL)) { |
506
|
0
|
0
|
|
|
|
0
|
$smtp = Net::SMTP->new($cfg->SMTP_HOST, |
507
|
|
|
|
|
|
|
Hello => $cfg->SMTP_DOMAIN, |
508
|
|
|
|
|
|
|
Timeout => $cfg->SMTP_TIMEOUT, |
509
|
|
|
|
|
|
|
Debug => $cfg->SMTP_DEBUG, |
510
|
|
|
|
|
|
|
Port => $cfg->SMTP_PORT, |
511
|
|
|
|
|
|
|
SSL => 1) |
512
|
|
|
|
|
|
|
or return "Unable to open SMTP connection to " . |
513
|
|
|
|
|
|
|
$cfg->SMTP_HOST . ": $@"; |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
else { |
516
|
0
|
0
|
|
|
|
0
|
$smtp = Net::SMTP->new($cfg->SMTP_HOST, |
517
|
|
|
|
|
|
|
Hello => $cfg->SMTP_DOMAIN, |
518
|
|
|
|
|
|
|
Timeout => $cfg->SMTP_TIMEOUT, |
519
|
|
|
|
|
|
|
Debug => $cfg->SMTP_DEBUG, |
520
|
|
|
|
|
|
|
Port => $cfg->SMTP_PORT) |
521
|
|
|
|
|
|
|
or return "Unable to open SMTP connection to " . |
522
|
|
|
|
|
|
|
$cfg->SMTP_HOST . ": $@"; |
523
|
0
|
0
|
|
|
|
0
|
if(is_yes($cfg->SMTP_USE_STARTTLS)) { |
524
|
0
|
0
|
|
|
|
0
|
if(not $smtp->starttls()) { |
525
|
0
|
|
|
|
|
0
|
my $err = "STARTTLS failed: " . $smtp->message(); |
526
|
0
|
|
|
|
|
0
|
$smtp->quit(); |
527
|
0
|
|
|
|
|
0
|
return $err; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
} |
531
|
0
|
0
|
0
|
|
|
0
|
if($cfg->SMTP_USERNAME and $cfg->SMTP_PASSWORD) { |
532
|
0
|
0
|
|
|
|
0
|
if(not $smtp->auth($cfg->SMTP_USERNAME, $cfg->SMTP_PASSWORD)) { |
533
|
0
|
|
|
|
|
0
|
my $err = "Unable to authenticate with " . $cfg->SMTP_DOMAIN . |
534
|
|
|
|
|
|
|
" SMTP server as user " . $cfg->SMTP_USERNAME . ": " . |
535
|
|
|
|
|
|
|
$smtp->message(); |
536
|
0
|
|
|
|
|
0
|
$smtp->quit(); |
537
|
0
|
|
|
|
|
0
|
return $err; |
538
|
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
|
} |
540
|
0
|
0
|
|
|
|
0
|
$smtp->mail($cfg->SMTP_FROM) |
541
|
|
|
|
|
|
|
or return "Unable to initiate sending of email message."; |
542
|
0
|
0
|
|
|
|
0
|
$smtp->to($recipient) |
543
|
|
|
|
|
|
|
or return "Unable to define email recipient."; |
544
|
0
|
0
|
|
|
|
0
|
$smtp->data() |
545
|
|
|
|
|
|
|
or return "Unable to start sending of email data."; |
546
|
0
|
0
|
|
|
|
0
|
$smtp->datasend("Subject: $subject\n") |
547
|
|
|
|
|
|
|
or return "Unable to send email data."; |
548
|
0
|
0
|
|
|
|
0
|
$smtp->datasend("To: $recipient\n") |
549
|
|
|
|
|
|
|
or return "Unable to send email data."; |
550
|
0
|
0
|
|
|
|
0
|
if($cfg->ADM_ADDR =~ /\b$recipient\b/) { |
551
|
|
|
|
|
|
|
# set reply-to header when sending mail to admin |
552
|
0
|
0
|
|
|
|
0
|
$smtp->datasend("Reply-To: $recipient\n") |
553
|
|
|
|
|
|
|
or return "Unable to send email data."; |
554
|
|
|
|
|
|
|
} |
555
|
0
|
0
|
|
|
|
0
|
$smtp->datasend("MIME-Version: 1.0\n") |
556
|
|
|
|
|
|
|
or return "Unable to send email data."; |
557
|
0
|
0
|
|
|
|
0
|
$smtp->datasend("Content-Type: text/plain\n") |
558
|
|
|
|
|
|
|
or return "Unable to send email data."; |
559
|
0
|
0
|
|
|
|
0
|
$smtp->datasend("Content-Transfer-Encoding: 7bit\n") |
560
|
|
|
|
|
|
|
or return "Unable to send email data."; |
561
|
0
|
0
|
|
|
|
0
|
$smtp->datasend("\n") |
562
|
|
|
|
|
|
|
or return "Unable to send email data."; |
563
|
0
|
0
|
|
|
|
0
|
$smtp->datasend(@_) |
564
|
|
|
|
|
|
|
or return "Unable to send email data."; |
565
|
0
|
0
|
|
|
|
0
|
$smtp->dataend() |
566
|
|
|
|
|
|
|
or return "Unable to end sending of email data."; |
567
|
0
|
0
|
|
|
|
0
|
$smtp->quit() |
568
|
|
|
|
|
|
|
or return "Unable to close the SMTP connection."; |
569
|
0
|
|
|
|
|
0
|
return ''; # successful |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
573
|
|
|
|
|
|
|
# Send encrypted email message. |
574
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
575
|
|
|
|
|
|
|
sub send_encrypted_email |
576
|
|
|
|
|
|
|
{ |
577
|
1
|
|
|
1
|
0
|
2
|
my $encr_typ = shift; |
578
|
1
|
|
|
|
|
2
|
my $encr_recip = shift; |
579
|
1
|
|
|
|
|
1
|
my $recipient = shift; |
580
|
1
|
|
|
|
|
2
|
my $encr_out_keyid = shift; |
581
|
1
|
|
|
|
|
2
|
my $encr_out_passphrase = shift; |
582
|
1
|
|
|
|
|
3
|
my $subject = shift; |
583
|
|
|
|
|
|
|
# @_ now contains message body |
584
|
|
|
|
|
|
|
|
585
|
1
|
50
|
|
|
|
2
|
return "EMDIS::ECS::send_encrypted_email(): ECS has not been configured." |
586
|
|
|
|
|
|
|
unless ecs_is_configured(); |
587
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
# compose template for name of temp file |
590
|
0
|
|
|
|
|
0
|
my $template = format_datetime(time, '%04d%02d%02d_%02d%02d%02d_XXXX'); |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# write message body to temp file |
593
|
0
|
|
|
|
|
0
|
my ($fh, $filename) = tempfile($template, |
594
|
|
|
|
|
|
|
DIR => $cfg->ECS_TMP_DIR, |
595
|
|
|
|
|
|
|
SUFFIX => '.tmp'); |
596
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_encrypted_email(): unable to create temporary file" |
597
|
|
|
|
|
|
|
unless $fh; |
598
|
0
|
|
|
|
|
0
|
print $fh @_; |
599
|
0
|
|
|
|
|
0
|
close $fh; |
600
|
0
|
|
|
|
|
0
|
chmod $FILEMODE, $filename; |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
# create file containing encrypted message |
603
|
0
|
|
|
|
|
0
|
my $encr_filename = "$filename.pgp"; |
604
|
0
|
|
|
|
|
0
|
my $result = ''; |
605
|
0
|
|
|
|
|
0
|
for ($encr_typ) { |
606
|
0
|
0
|
|
|
|
0
|
/PGP2/i and do { |
607
|
0
|
|
|
|
|
0
|
$result = pgp2_encrypt($filename, $encr_filename, $encr_recip, |
608
|
|
|
|
|
|
|
$encr_out_keyid, $encr_out_passphrase); |
609
|
0
|
|
|
|
|
0
|
last; |
610
|
|
|
|
|
|
|
}; |
611
|
0
|
0
|
|
|
|
0
|
/OpenPGP/i and do { |
612
|
0
|
|
|
|
|
0
|
$result = openpgp_encrypt($filename, $encr_filename, $encr_recip, |
613
|
|
|
|
|
|
|
$encr_out_keyid, $encr_out_passphrase); |
614
|
0
|
|
|
|
|
0
|
last; |
615
|
|
|
|
|
|
|
}; |
616
|
0
|
|
|
|
|
0
|
$result = "unrecognized encr_typ: $encr_typ"; |
617
|
|
|
|
|
|
|
} |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# delete first temp file |
620
|
0
|
|
|
|
|
0
|
unlink $filename; |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
# check for error |
623
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_encrypted_email(): $result" if $result; |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
# read contents of encrypted file |
626
|
0
|
|
|
|
|
0
|
$fh = new IO::File; |
627
|
0
|
0
|
|
|
|
0
|
return "EMDIS::ECS::send_encrypted_email(): unable to open file: " . |
628
|
|
|
|
|
|
|
"$encr_filename" |
629
|
|
|
|
|
|
|
unless $fh->open("< $encr_filename"); |
630
|
0
|
|
|
|
|
0
|
my @body = $fh->getlines(); |
631
|
0
|
|
|
|
|
0
|
$fh->close(); |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# delete encrypted (temp) file |
634
|
0
|
|
|
|
|
0
|
unlink $encr_filename; |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
# send email |
637
|
0
|
|
|
|
|
0
|
return send_email($recipient, $subject, @body); |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
641
|
|
|
|
|
|
|
# Format a datetime value |
642
|
|
|
|
|
|
|
sub format_datetime |
643
|
|
|
|
|
|
|
{ |
644
|
2
|
|
|
2
|
0
|
5
|
my $datetime = shift; |
645
|
2
|
|
|
|
|
3
|
my $format = shift; |
646
|
2
|
100
|
|
|
|
5
|
$format = '%04d-%02d-%02d %02d:%02d:%02d' |
647
|
|
|
|
|
|
|
unless defined $format; |
648
|
2
|
|
|
|
|
33
|
my ($seconds, $minutes, $hours, $mday, $month, $year, $wday, $yday, |
649
|
|
|
|
|
|
|
$isdst) = localtime($datetime); |
650
|
2
|
|
|
|
|
26
|
return sprintf($format, $year + 1900, $month + 1, $mday, |
651
|
|
|
|
|
|
|
$hours, $minutes, $seconds); |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
655
|
|
|
|
|
|
|
# Format filename for regular message. |
656
|
|
|
|
|
|
|
sub format_msg_filename |
657
|
|
|
|
|
|
|
{ |
658
|
1
|
50
|
|
1
|
0
|
3
|
return "EMDIS::ECS::format_msg_filename(): ECS has not been configured." |
659
|
|
|
|
|
|
|
unless ecs_is_configured(); |
660
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
661
|
0
|
|
|
|
|
0
|
my $node_id = shift; |
662
|
0
|
|
|
|
|
0
|
my $seq_num = shift; |
663
|
0
|
|
|
|
|
0
|
my $template = sprintf("%s_%s_%010d", |
664
|
|
|
|
|
|
|
$cfg->THIS_NODE, $node_id, $seq_num); |
665
|
0
|
|
|
|
|
0
|
my $dirname = $cfg->ECS_MBX_OUT_DIR . "_$node_id"; |
666
|
0
|
|
|
|
|
0
|
return catfile($dirname, "$template.msg"); |
667
|
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
670
|
|
|
|
|
|
|
# Use OpenPGP (GnuPG) to decrypt a file. |
671
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
672
|
|
|
|
|
|
|
sub openpgp_decrypt |
673
|
|
|
|
|
|
|
{ |
674
|
1
|
|
|
1
|
0
|
3
|
my $input_filename = shift; |
675
|
1
|
|
|
|
|
1
|
my $output_filename = shift; |
676
|
1
|
|
|
|
|
2
|
my $required_signature = shift; |
677
|
1
|
|
|
|
|
2
|
my $encr_out_passphrase = shift; |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
# initialize |
680
|
1
|
50
|
|
|
|
24
|
return "EMDIS::ECS::openpgp_decrypt(): ECS has not been configured." |
681
|
|
|
|
|
|
|
unless ecs_is_configured(); |
682
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
# compose command |
685
|
0
|
|
|
|
|
0
|
my $cmd = $cfg->OPENPGP_CMD_DECRYPT; |
686
|
0
|
|
|
|
|
0
|
$cmd =~ s/__INPUT__/$input_filename/g; |
687
|
0
|
|
|
|
|
0
|
$cmd =~ s/__OUTPUT__/$output_filename/g; |
688
|
0
|
0
|
|
|
|
0
|
print " openpgp_decrypt() command: $cmd\n" |
689
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
# set GNUPGHOME environment variable |
692
|
0
|
|
|
|
|
0
|
$ENV{GNUPGHOME} = $cfg->GPG_HOMEDIR; |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
# attempt to execute command |
695
|
0
|
0
|
0
|
|
|
0
|
my $result = timelimit_cmd($cfg->T_MSG_PROC, $cmd, |
|
|
|
0
|
|
|
|
|
696
|
|
|
|
|
|
|
(defined $encr_out_passphrase and 0 < length $encr_out_passphrase) ? |
697
|
|
|
|
|
|
|
$encr_out_passphrase : |
698
|
|
|
|
|
|
|
(defined $cfg->GPG_PASSPHRASE and 0 < length $cfg->GPG_PASSPHRASE ? |
699
|
|
|
|
|
|
|
$cfg->GPG_PASSPHRASE : undef)); |
700
|
0
|
0
|
|
|
|
0
|
$result = "EMDIS::ECS::openpgp_decrypt(): $result" if $result; |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
# check signature, if indicated |
703
|
0
|
0
|
0
|
|
|
0
|
if(defined($required_signature) and not $result) { |
704
|
0
|
0
|
|
|
|
0
|
if($cmd_output !~ /Good signature from[^\n]+$required_signature/is) { |
705
|
0
|
|
|
|
|
0
|
$result = "EMDIS::ECS::openpgp_decrypt(): required signature not " . |
706
|
|
|
|
|
|
|
"present: $required_signature"; |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
|
710
|
0
|
|
|
|
|
0
|
return $result; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
714
|
|
|
|
|
|
|
# Use OpenPGP (GnuPG) to encrypt a file. |
715
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
716
|
|
|
|
|
|
|
sub openpgp_encrypt |
717
|
|
|
|
|
|
|
{ |
718
|
1
|
|
|
1
|
0
|
3
|
my $input_filename = shift; |
719
|
1
|
|
|
|
|
2
|
my $output_filename = shift; |
720
|
1
|
|
|
|
|
7
|
my $recipient = shift; |
721
|
1
|
|
|
|
|
4
|
my $encr_out_keyid = shift; |
722
|
1
|
|
|
|
|
2
|
my $encr_out_passphrase = shift; |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
# initialize |
725
|
1
|
50
|
|
|
|
3
|
return "EMDIS::ECS::openpgp_encrypt(): ECS has not been configured." |
726
|
|
|
|
|
|
|
unless ecs_is_configured(); |
727
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
# compose command |
730
|
0
|
0
|
0
|
|
|
0
|
my $keyid = (defined $encr_out_keyid and 0 < length $encr_out_keyid) ? |
731
|
|
|
|
|
|
|
$encr_out_keyid : $cfg->GPG_KEYID; |
732
|
0
|
|
|
|
|
0
|
my $cmd = $cfg->OPENPGP_CMD_ENCRYPT; |
733
|
0
|
|
|
|
|
0
|
$cmd =~ s/__INPUT__/$input_filename/g; |
734
|
0
|
|
|
|
|
0
|
$cmd =~ s/__OUTPUT__/$output_filename/g; |
735
|
0
|
|
|
|
|
0
|
$cmd =~ s/__RECIPIENT__/$recipient/g; |
736
|
0
|
|
|
|
|
0
|
$cmd =~ s/__SELF__/$keyid/g; |
737
|
0
|
0
|
|
|
|
0
|
print " openpgp_encrypt() command: $cmd\n" |
738
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
# set GNUPGHOME environment variable |
741
|
0
|
|
|
|
|
0
|
$ENV{GNUPGHOME} = $cfg->GPG_HOMEDIR; |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
# attempt to execute command |
744
|
0
|
0
|
0
|
|
|
0
|
my $result = timelimit_cmd($cfg->T_MSG_PROC, $cmd, |
|
|
|
0
|
|
|
|
|
745
|
|
|
|
|
|
|
(defined $encr_out_passphrase and 0 < length $encr_out_passphrase) ? |
746
|
|
|
|
|
|
|
$encr_out_passphrase : |
747
|
|
|
|
|
|
|
(defined $cfg->GPG_PASSPHRASE and 0 < length $cfg->GPG_PASSPHRASE ? |
748
|
|
|
|
|
|
|
$cfg->GPG_PASSPHRASE : undef)); |
749
|
0
|
0
|
|
|
|
0
|
$result = "EMDIS::ECS::openpgp_encrypt(): $result" if $result; |
750
|
0
|
|
|
|
|
0
|
return $result; |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
754
|
|
|
|
|
|
|
# Use PGP2 (PGP) to decrypt a file. |
755
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
756
|
|
|
|
|
|
|
sub pgp2_decrypt |
757
|
|
|
|
|
|
|
{ |
758
|
1
|
|
|
1
|
0
|
19
|
my $input_filename = shift; |
759
|
1
|
|
|
|
|
4
|
my $output_filename = shift; |
760
|
1
|
|
|
|
|
2
|
my $required_signature = shift; |
761
|
1
|
|
|
|
|
2
|
my $encr_out_passphrase = shift; |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
# initialize |
764
|
1
|
50
|
|
|
|
2
|
return "EMDIS::ECS::pgp2_decrypt(): ECS has not been configured." |
765
|
|
|
|
|
|
|
unless ecs_is_configured(); |
766
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
# compose command |
769
|
0
|
|
|
|
|
0
|
my $cmd = $cfg->PGP2_CMD_DECRYPT; |
770
|
0
|
|
|
|
|
0
|
$cmd =~ s/__INPUT__/$input_filename/g; |
771
|
0
|
|
|
|
|
0
|
$cmd =~ s/__OUTPUT__/$output_filename/g; |
772
|
0
|
0
|
|
|
|
0
|
print " pgp2_decrypt() command: $cmd\n" |
773
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
# set PGPPATH and PGPPASS environment variables |
776
|
0
|
|
|
|
|
0
|
$ENV{PGPPATH} = $cfg->PGP_HOMEDIR; |
777
|
0
|
0
|
0
|
|
|
0
|
$ENV{PGPPASS} = (defined $encr_out_passphrase and 0 < length $encr_out_passphrase) ? |
778
|
|
|
|
|
|
|
$encr_out_passphrase : $cfg->PGP_PASSPHRASE; |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
# attempt to execute command |
781
|
0
|
|
|
|
|
0
|
my $result = timelimit_cmd($cfg->T_MSG_PROC, $cmd); |
782
|
0
|
0
|
|
|
|
0
|
$result = '' if($result =~ /^Status 0x0100/); # ignore exit value = 1 |
783
|
0
|
0
|
|
|
|
0
|
$result = "EMDIS::ECS::pgp2_decrypt(): $result" if $result; |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
# check signature, if indicated |
786
|
0
|
0
|
0
|
|
|
0
|
if(defined($required_signature) and not $result) { |
787
|
0
|
0
|
|
|
|
0
|
if($cmd_output !~ /Good signature from[^\n]+$required_signature/is) { |
788
|
0
|
|
|
|
|
0
|
$result = "EMDIS::ECS::pgp2_decrypt(): required signature not " . |
789
|
|
|
|
|
|
|
"present: $required_signature"; |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
|
|
793
|
0
|
|
|
|
|
0
|
return $result; |
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
797
|
|
|
|
|
|
|
# Use PGP to encrypt a file. |
798
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
799
|
|
|
|
|
|
|
sub pgp2_encrypt |
800
|
|
|
|
|
|
|
{ |
801
|
1
|
|
|
1
|
0
|
3
|
my $input_filename = shift; |
802
|
1
|
|
|
|
|
2
|
my $output_filename = shift; |
803
|
1
|
|
|
|
|
1
|
my $recipient = shift; |
804
|
1
|
|
|
|
|
2
|
my $encr_out_keyid = shift; |
805
|
1
|
|
|
|
|
2
|
my $encr_out_passphrase = shift; |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
# initialize |
808
|
1
|
50
|
|
|
|
3
|
return "EMDIS::ECS::pgp2_encrypt(): ECS has not been configured." |
809
|
|
|
|
|
|
|
unless ecs_is_configured(); |
810
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
# compose command |
813
|
0
|
0
|
0
|
|
|
0
|
my $keyid = (defined $encr_out_keyid and 0 < length $encr_out_keyid) ? |
814
|
|
|
|
|
|
|
$encr_out_keyid : $cfg->PGP_KEYID; |
815
|
0
|
|
|
|
|
0
|
my $cmd = $cfg->PGP2_CMD_ENCRYPT; |
816
|
0
|
|
|
|
|
0
|
$cmd =~ s/__INPUT__/$input_filename/g; |
817
|
0
|
|
|
|
|
0
|
$cmd =~ s/__OUTPUT__/$output_filename/g; |
818
|
0
|
|
|
|
|
0
|
$cmd =~ s/__RECIPIENT__/$recipient/g; |
819
|
0
|
|
|
|
|
0
|
$cmd =~ s/__SELF__/$keyid/g; |
820
|
0
|
0
|
|
|
|
0
|
print " pgp2_encrypt() command: $cmd\n" |
821
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
# set PGPPATH and PGPPASS environment variables |
824
|
0
|
|
|
|
|
0
|
$ENV{PGPPATH} = $cfg->PGP_HOMEDIR; |
825
|
0
|
0
|
0
|
|
|
0
|
$ENV{PGPPASS} = (defined $encr_out_passphrase and 0 < length $encr_out_passphrase) ? |
826
|
|
|
|
|
|
|
$encr_out_passphrase : $cfg->PGP_PASSPHRASE; |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
# attempt to execute command |
829
|
0
|
|
|
|
|
0
|
my $result = timelimit_cmd($cfg->T_MSG_PROC, $cmd); |
830
|
0
|
0
|
|
|
|
0
|
$result = "EMDIS::ECS::pgp2_encrypt(): $result" if $result; |
831
|
0
|
|
|
|
|
0
|
return $result; |
832
|
|
|
|
|
|
|
} |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
835
|
|
|
|
|
|
|
# Check whether another copy of the program is already running. |
836
|
|
|
|
|
|
|
# If so, this one dies. |
837
|
|
|
|
|
|
|
sub check_pid |
838
|
|
|
|
|
|
|
{ |
839
|
0
|
0
|
|
0
|
0
|
0
|
die "EMDIS::ECS::check_pid(): ECS has not been configured." |
840
|
|
|
|
|
|
|
unless ecs_is_configured(); |
841
|
|
|
|
|
|
|
|
842
|
0
|
0
|
|
|
|
0
|
if(open PIDFILE, $pidfile) { |
843
|
0
|
|
|
|
|
0
|
my $pid = ; |
844
|
0
|
|
|
|
|
0
|
$pid =~ s/\s+//g; |
845
|
0
|
0
|
|
|
|
0
|
die "Error: $0 is already running (pid $pid).\n" |
846
|
|
|
|
|
|
|
if kill(0, $pid); |
847
|
0
|
|
|
|
|
0
|
close PIDFILE; |
848
|
|
|
|
|
|
|
} |
849
|
|
|
|
|
|
|
|
850
|
0
|
|
|
|
|
0
|
save_pid(); |
851
|
|
|
|
|
|
|
} |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
854
|
|
|
|
|
|
|
# Update PID file. |
855
|
|
|
|
|
|
|
sub save_pid |
856
|
|
|
|
|
|
|
{ |
857
|
0
|
0
|
|
0
|
0
|
0
|
die "EMDIS::ECS::save_pid(): ECS has not been configured." |
858
|
|
|
|
|
|
|
unless ecs_is_configured(); |
859
|
|
|
|
|
|
|
|
860
|
0
|
|
|
|
|
0
|
open PIDFILE, ">$pidfile"; |
861
|
0
|
|
|
|
|
0
|
print PIDFILE "$$\n"; |
862
|
0
|
|
|
|
|
0
|
close PIDFILE; |
863
|
0
|
|
|
|
|
0
|
chmod $FILEMODE, $pidfile; |
864
|
0
|
|
|
|
|
0
|
$pid_saved = 1; |
865
|
|
|
|
|
|
|
} |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
868
|
|
|
|
|
|
|
# Select the Win32 or Unix version of timelimit_cmd |
869
|
|
|
|
|
|
|
sub timelimit_cmd |
870
|
|
|
|
|
|
|
{ |
871
|
0
|
0
|
|
0
|
0
|
0
|
$^O =~ /MSWin32/ ? timelimit_cmd_win32(@_) : timelimit_cmd_unix(@_); |
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
877
|
|
|
|
|
|
|
sub timelimit_cmd_win32 |
878
|
|
|
|
|
|
|
{ |
879
|
0
|
|
|
0
|
0
|
0
|
my $timelimit = shift; |
880
|
0
|
|
|
|
|
0
|
my $cmd = shift; |
881
|
0
|
|
|
|
|
0
|
my $input_data = shift; |
882
|
0
|
|
|
|
|
0
|
my $cfg = $ECS_CFG; |
883
|
0
|
|
|
|
|
0
|
my @msgs = (); |
884
|
0
|
|
|
|
|
0
|
my $result = ""; |
885
|
0
|
|
|
|
|
0
|
my ($ProcessObj, $rc, $appname, $cmdline); |
886
|
|
|
|
|
|
|
|
887
|
0
|
|
|
|
|
0
|
pipe(READ, WRITE); |
888
|
0
|
|
|
|
|
0
|
select(WRITE); |
889
|
0
|
|
|
|
|
0
|
$| = 1; |
890
|
0
|
|
|
|
|
0
|
select(STDOUT); |
891
|
0
|
0
|
|
|
|
0
|
open(OLDIN, "< &STDIN") || die "Can not save STDIN\n"; |
892
|
0
|
0
|
|
|
|
0
|
open(STDIN, "< &READ") || die "Can not redirect STDIN\n"; |
893
|
|
|
|
|
|
|
|
894
|
0
|
0
|
|
|
|
0
|
open(OLDOUT, ">&STDOUT") || die "Can not save STDOUT\n"; |
895
|
0
|
0
|
|
|
|
0
|
open(STDOUT, ">$$.txt" ) || die( "Unable to redirect STDOUT "); |
896
|
|
|
|
|
|
|
|
897
|
0
|
0
|
|
|
|
0
|
open(OLDERR, ">&STDERR" ) || die "Can not redirect STDERR\n"; |
898
|
0
|
0
|
|
|
|
0
|
open(STDERR, ">&STDOUT" ) || die( "Unable to dup STDOUT to STDERR" ); |
899
|
|
|
|
|
|
|
|
900
|
0
|
|
|
|
|
0
|
select(STDERR); |
901
|
0
|
|
|
|
|
0
|
$| = 1; |
902
|
0
|
|
|
|
|
0
|
select(STDIN); |
903
|
0
|
|
|
|
|
0
|
$| = 1; |
904
|
0
|
|
|
|
|
0
|
select(STDOUT); |
905
|
|
|
|
|
|
|
|
906
|
0
|
0
|
|
|
|
0
|
if(! defined $input_data) { $input_data = ""; } |
|
0
|
|
|
|
|
0
|
|
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
# compute $appname and $cmdline |
909
|
0
|
|
|
|
|
0
|
$cmd =~ /\s*(\S+)\s*(.*)/; |
910
|
0
|
|
|
|
|
0
|
$appname = $1; |
911
|
0
|
|
|
|
|
0
|
$cmdline = "$1 $2"; |
912
|
|
|
|
|
|
|
# if applicable, append .exe or .bat extension to $appname |
913
|
0
|
0
|
|
|
|
0
|
if(-x "$appname.exe") |
|
|
0
|
|
|
|
|
|
914
|
|
|
|
|
|
|
{ |
915
|
0
|
|
|
|
|
0
|
$appname = "$appname.exe"; |
916
|
|
|
|
|
|
|
} |
917
|
|
|
|
|
|
|
elsif(-x "$appname.bat") |
918
|
|
|
|
|
|
|
{ |
919
|
0
|
|
|
|
|
0
|
$appname = "$appname.bat"; |
920
|
|
|
|
|
|
|
} |
921
|
|
|
|
|
|
|
|
922
|
0
|
0
|
|
|
|
0
|
print "\n: Running External Command" . |
923
|
|
|
|
|
|
|
"\nappname=" . $appname . |
924
|
|
|
|
|
|
|
"\ncmdline=" . $cmdline . |
925
|
|
|
|
|
|
|
# "\nSTDIN=" . $input_data . # (don't print out PGP passphrase) |
926
|
|
|
|
|
|
|
"\nTimelimit=" . $timelimit . "\n" |
927
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
928
|
|
|
|
|
|
|
|
929
|
0
|
|
|
|
|
0
|
$rc = Win32::Process::Create( |
930
|
|
|
|
|
|
|
$ProcessObj, |
931
|
|
|
|
|
|
|
$appname, |
932
|
|
|
|
|
|
|
$cmdline, |
933
|
|
|
|
|
|
|
1, |
934
|
|
|
|
|
|
|
Win32::Process::constant('NORMAL_PRIORITY_CLASS'), |
935
|
|
|
|
|
|
|
"."); |
936
|
|
|
|
|
|
|
|
937
|
0
|
0
|
|
|
|
0
|
if ($rc) { |
938
|
0
|
0
|
|
|
|
0
|
print ": PID = " . $ProcessObj->GetProcessID() . "\n" |
939
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
940
|
|
|
|
|
|
|
} |
941
|
|
|
|
|
|
|
else { |
942
|
0
|
|
|
|
|
0
|
my $winMsg = Win32::FormatMessage(Win32::GetLastError()); |
943
|
0
|
0
|
|
|
|
0
|
if (defined $winMsg) { |
944
|
0
|
|
|
|
|
0
|
$result = $winMsg; |
945
|
|
|
|
|
|
|
} else { |
946
|
0
|
0
|
|
|
|
0
|
print ": Windows error\n" |
947
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
948
|
0
|
|
|
|
|
0
|
$result = "Windows error"; |
949
|
|
|
|
|
|
|
} |
950
|
|
|
|
|
|
|
} |
951
|
|
|
|
|
|
|
|
952
|
0
|
0
|
|
|
|
0
|
if($rc) |
953
|
|
|
|
|
|
|
{ |
954
|
0
|
|
|
|
|
0
|
print WRITE "$input_data\n"; |
955
|
0
|
|
|
|
|
0
|
close(WRITE); |
956
|
|
|
|
|
|
|
|
957
|
0
|
0
|
|
|
|
0
|
print ": Waiting\n" |
958
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
959
|
0
|
|
|
|
|
0
|
$rc = $ProcessObj->Wait($timelimit * 1000); |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
# Check for return code |
962
|
0
|
0
|
|
|
|
0
|
if ($rc ) { |
963
|
0
|
|
|
|
|
0
|
my $ret; |
964
|
0
|
|
|
|
|
0
|
$ProcessObj->GetExitCode($ret); |
965
|
0
|
0
|
|
|
|
0
|
print ": Process OK ($ret)\n\n" |
966
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
967
|
|
|
|
|
|
|
} else { |
968
|
0
|
|
|
|
|
0
|
Win32::Process::KillProcess($ProcessObj->GetProcessID(), 0); |
969
|
0
|
0
|
|
|
|
0
|
print ": Process Timeout\n\n" |
970
|
|
|
|
|
|
|
if $cfg->ECS_DEBUG > 0; |
971
|
0
|
|
|
|
|
0
|
$result = "Process Timeout"; |
972
|
|
|
|
|
|
|
} |
973
|
|
|
|
|
|
|
} |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
# Restore STDIN, STDOUT, STDERR |
976
|
0
|
|
|
|
|
0
|
open(STDIN, "<&OLDIN"); |
977
|
0
|
|
|
|
|
0
|
open(STDOUT, ">&OLDOUT" ); |
978
|
0
|
|
|
|
|
0
|
open(STDERR, ">&OLDERR" ); |
979
|
|
|
|
|
|
|
|
980
|
0
|
|
|
|
|
0
|
if(0) |
981
|
|
|
|
|
|
|
{ |
982
|
|
|
|
|
|
|
# just leave these hanging until next time around ... |
983
|
|
|
|
|
|
|
# (avoid potential deadlock waiting for child process to end) |
984
|
|
|
|
|
|
|
close(READ); |
985
|
|
|
|
|
|
|
close(OLDIN); |
986
|
|
|
|
|
|
|
close(OLDOUT); |
987
|
|
|
|
|
|
|
close(OLDERR); |
988
|
|
|
|
|
|
|
} |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
|
991
|
0
|
0
|
|
|
|
0
|
if(open FILETEMP, "< $$.txt") |
992
|
|
|
|
|
|
|
{ |
993
|
0
|
|
|
|
|
0
|
@msgs = ; |
994
|
0
|
|
|
|
|
0
|
close FILETEMP; |
995
|
0
|
|
|
|
|
0
|
unlink "$$.txt"; |
996
|
0
|
|
|
|
|
0
|
print "\n======== EXTERNAL BEGIN =============\n"; |
997
|
0
|
|
|
|
|
0
|
print @msgs; |
998
|
0
|
|
|
|
|
0
|
print "========= EXTERNAL END ==============\n"; |
999
|
|
|
|
|
|
|
} |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
# set module-level variable containing command output |
1002
|
0
|
0
|
|
|
|
0
|
if($#msgs >= 0) { $cmd_output = join('', @msgs); } |
|
0
|
|
|
|
|
0
|
|
1003
|
0
|
|
|
|
|
0
|
else { $cmd_output = ''; } |
1004
|
|
|
|
|
|
|
|
1005
|
0
|
|
|
|
|
0
|
return $result; |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
1010
|
|
|
|
|
|
|
# Unix version |
1011
|
|
|
|
|
|
|
# Execute specified command, with time limit and optional input data. |
1012
|
|
|
|
|
|
|
# Returns empty string if successful or error message if error encountered. |
1013
|
|
|
|
|
|
|
sub timelimit_cmd_unix |
1014
|
|
|
|
|
|
|
{ |
1015
|
0
|
|
|
0
|
0
|
0
|
my $timelimit = shift; |
1016
|
0
|
|
|
|
|
0
|
my $cmd = shift; |
1017
|
0
|
|
|
|
|
0
|
my $input_data = shift; |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
# initialize |
1020
|
0
|
|
|
|
|
0
|
my ($reader, $writer) = (IO::Handle->new, IO::Handle->new); |
1021
|
0
|
|
|
|
|
0
|
my ($pid, @msgs, $status); |
1022
|
0
|
|
|
|
|
0
|
my $result = ''; |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
# set up "local" SIG_PIPE and SIG_ALRM handlers |
1025
|
|
|
|
|
|
|
# (Note: not using "local $SIG{PIPE}" because it ignores die()) |
1026
|
0
|
|
|
|
|
0
|
my $broken_pipe = ''; |
1027
|
0
|
|
|
|
|
0
|
my $oldsigpipe = $SIG{PIPE}; |
1028
|
0
|
|
|
0
|
|
0
|
$SIG{PIPE} = sub { $broken_pipe = 1; }; |
|
0
|
|
|
|
|
0
|
|
1029
|
0
|
|
|
|
|
0
|
my $oldsigalrm = $SIG{ALRM}; |
1030
|
|
|
|
|
|
|
$SIG{ALRM} = sub { |
1031
|
0
|
|
|
0
|
|
0
|
die "timeout - $timelimit second processing time limit exceeded\n"; |
1032
|
0
|
|
|
|
|
0
|
}; |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
# use eval {}; to enforce time limit (see Perl Cookbook, 16.21) |
1035
|
0
|
|
|
|
|
0
|
eval { |
1036
|
0
|
|
|
|
|
0
|
alarm($timelimit); # set time limit |
1037
|
0
|
|
|
|
|
0
|
$broken_pipe = ''; |
1038
|
0
|
|
|
|
|
0
|
$pid = open2($reader, $writer, $cmd); |
1039
|
0
|
0
|
|
|
|
0
|
print $writer $input_data if defined $input_data; |
1040
|
0
|
|
|
|
|
0
|
close $writer; |
1041
|
0
|
|
|
|
|
0
|
@msgs = $reader->getlines(); |
1042
|
0
|
|
|
|
|
0
|
close $reader; |
1043
|
0
|
|
|
|
|
0
|
waitpid $pid, 0; |
1044
|
0
|
|
|
|
|
0
|
$status = $?; |
1045
|
0
|
0
|
|
|
|
0
|
die "broken pipe\n" if $broken_pipe; |
1046
|
0
|
|
|
|
|
0
|
alarm(0); |
1047
|
|
|
|
|
|
|
}; |
1048
|
0
|
0
|
|
|
|
0
|
if($@) { |
|
|
0
|
|
|
|
|
|
1049
|
0
|
|
|
|
|
0
|
alarm(0); |
1050
|
|
|
|
|
|
|
# detect runaway child from open2() fork/exec |
1051
|
0
|
0
|
0
|
|
|
0
|
die "runaway child, probably caused by bad command\n" |
1052
|
|
|
|
|
|
|
if (not defined $pid) and ($@ =~ /^open2/); |
1053
|
|
|
|
|
|
|
# construct error message |
1054
|
0
|
|
|
|
|
0
|
chomp $@; |
1055
|
0
|
|
|
|
|
0
|
$result = "$@: $cmd\n"; |
1056
|
|
|
|
|
|
|
} |
1057
|
|
|
|
|
|
|
elsif ($status) { |
1058
|
0
|
|
|
|
|
0
|
my $exit_value = $status >> 8; |
1059
|
0
|
|
|
|
|
0
|
my $signal_num = $status & 127; |
1060
|
0
|
|
|
|
|
0
|
my $dumped_core = $status & 128; |
1061
|
|
|
|
|
|
|
# construct error message |
1062
|
0
|
0
|
|
|
|
0
|
$result = sprintf("Status 0x%04x (exit %d%s%s)", |
|
|
0
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
$status, $exit_value, |
1064
|
|
|
|
|
|
|
($signal_num ? ", signal $signal_num" : ''), |
1065
|
|
|
|
|
|
|
($dumped_core ? ', core dumped' : '')); |
1066
|
|
|
|
|
|
|
} |
1067
|
0
|
0
|
|
|
|
0
|
$writer->close if $writer->opened; |
1068
|
0
|
0
|
|
|
|
0
|
$reader->close if $reader->opened; |
1069
|
0
|
0
|
|
|
|
0
|
if(defined $oldsigpipe) { $SIG{PIPE} = $oldsigpipe; } |
|
0
|
|
|
|
|
0
|
|
1070
|
0
|
|
|
|
|
0
|
else { delete $SIG{PIPE}; } |
1071
|
0
|
0
|
|
|
|
0
|
if(defined $oldsigalrm) { $SIG{ALRM} = $oldsigalrm; } |
|
0
|
|
|
|
|
0
|
|
1072
|
0
|
|
|
|
|
0
|
else { delete $SIG{ALRM}; } |
1073
|
0
|
0
|
0
|
|
|
0
|
$result .= "\n----------\n" . join("", @msgs) if($result and $#msgs >= 0); |
1074
|
|
|
|
|
|
|
# set module-level variable containing command output |
1075
|
0
|
0
|
|
|
|
0
|
if($#msgs >= 0) { $cmd_output = join('', @msgs); } |
|
0
|
|
|
|
|
0
|
|
1076
|
0
|
|
|
|
|
0
|
else { $cmd_output = ''; } |
1077
|
0
|
|
|
|
|
0
|
return $result; |
1078
|
|
|
|
|
|
|
} |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
1081
|
|
|
|
|
|
|
# Unlink PID file. |
1082
|
|
|
|
|
|
|
sub remove_pidfile |
1083
|
|
|
|
|
|
|
{ |
1084
|
0
|
0
|
|
0
|
0
|
0
|
unlink $pidfile if $pidfile; |
1085
|
|
|
|
|
|
|
} |
1086
|
|
|
|
|
|
|
|
1087
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
1088
|
|
|
|
|
|
|
# Return string value with leading and trailing whitespace trimmed off. |
1089
|
|
|
|
|
|
|
sub trim { |
1090
|
15
|
|
|
15
|
0
|
31
|
my $str = shift; |
1091
|
15
|
50
|
|
|
|
33
|
return if not defined $str; |
1092
|
15
|
|
|
|
|
37
|
$str =~ s/^\s+//; |
1093
|
15
|
|
|
|
|
37
|
$str =~ s/\s+$//; |
1094
|
15
|
|
|
|
|
48
|
return $str; |
1095
|
|
|
|
|
|
|
} |
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
1098
|
|
|
|
|
|
|
# Return boolean indicating whether specified encr_typ is valid. |
1099
|
|
|
|
|
|
|
sub valid_encr_typ |
1100
|
|
|
|
|
|
|
{ |
1101
|
4
|
|
|
4
|
0
|
7
|
my $encr_typ = shift; |
1102
|
4
|
|
|
|
|
8
|
for ($encr_typ) { |
1103
|
4
|
100
|
|
|
|
20
|
/PGP2/i and return 1; |
1104
|
2
|
50
|
|
|
|
13
|
/OpenPGP/i and return 1; |
1105
|
|
|
|
|
|
|
} |
1106
|
0
|
|
|
|
|
|
return ''; |
1107
|
|
|
|
|
|
|
} |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
1; |
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
__DATA__ |