]> scm.dxcluster.org Git - spider.git/blob - perl/DXUtil.pm
7fae63170d015345b5372ab41c234d7d14a538fc
[spider.git] / perl / DXUtil.pm
1 #
2 # various utilities which are exported globally
3 #
4 # Copyright (c) 1998 - Dirk Koopman G1TLH
5 #
6 # $Id$
7 #
8
9 package DXUtil;
10
11 use Date::Parse;
12 use IO::File;
13
14 use Carp;
15
16 require Exporter;
17 @ISA = qw(Exporter);
18 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf 
19                          parray parraypairs shellregex readfilestr
20              print_all_fields cltounix iscallsign
21             );
22
23 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
24 %patmap = (
25                    '*' => '.*',
26                    '?' => '.',
27                    '[' => '[',
28                    ']' => ']'
29 );
30
31 # a full time for logging and other purposes
32 sub atime
33 {
34         my $t = shift;
35         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
36         $year += 1900;
37         my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
38         return $buf;
39 }
40
41 # get a zulu time in cluster format (2300Z)
42 sub ztime
43 {
44         my $t = shift;
45         my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time);
46         $year += 1900;
47         my $buf = sprintf "%02d%02dZ", $hour, $min;
48         return $buf;
49
50 }
51
52 # get a cluster format date (23-Jun-1998)
53 sub cldate
54 {
55         my $t = shift;
56         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
57         $year += 1900;
58         my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
59         return $buf;
60 }
61
62 # return a cluster style date time
63 sub cldatetime
64 {
65         my $t = shift;
66         my $date = cldate($t);
67         my $time = ztime($t);
68         return "$date $time";
69 }
70
71 # return a unix date from a cluster date and time
72 sub cltounix
73 {
74         my $date = shift;
75         my $time = shift;
76         my ($thisyear) = (gmtime)[5] + 1900;
77
78         return 0 unless $date =~ /^\s*(\d+)-(\w\w\w)-([12][90]\d\d)$/;
79         return 0 if $3 > 2036;
80         return 0 unless abs($thisyear-$3) <= 1;
81         $date = "$1 $2 $3";
82         return 0 unless $time =~ /^([012]\d)([012345]\d)Z$/;
83         $time = "$1:$2 +0000";
84         my $r = str2time("$date $time");
85         return $r unless $r;
86         return $r == -1 ? undef : $r;
87 }
88
89 # turn a latitude in degrees into a string
90 sub slat
91 {
92         my $n = shift;
93         my ($deg, $min, $let);
94         $let = $n >= 0 ? 'N' : 'S';
95         $n = abs $n;
96         $deg = int $n;
97         $min = int ((($n - $deg) * 60) + 0.5);
98         return "$deg $min $let";
99 }
100
101 # turn a longitude in degrees into a string
102 sub slong
103 {
104         my $n = shift;
105         my ($deg, $min, $let);
106         $let = $n >= 0 ? 'E' : 'W';
107         $n = abs $n;
108         $deg = int $n;
109         $min = int ((($n - $deg) * 60) + 0.5);
110         return "$deg $min $let";
111 }
112
113 # turn a true into 'yes' and false into 'no'
114 sub yesno
115 {
116         my $n = shift;
117         return $n ? $main::yes : $main::no;
118 }
119
120 # format a prompt with its current value and return it with its privilege
121 sub promptf
122 {
123         my ($line, $value) = @_;
124         my ($priv, $prompt, $action) = split ',', $line;
125
126         # if there is an action treat it as a subroutine and replace $value
127         if ($action) {
128                 my $q = qq{\$value = $action(\$value)};
129                 eval $q;
130         }
131         $prompt = sprintf "%15s: %s", $prompt, $value;
132         return ($priv, $prompt);
133 }
134
135 # take an arg as an array list and print it
136 sub parray
137 {
138         my $ref = shift;
139         return join(', ', @{$ref});
140 }
141
142 # take the arg as an array reference and print as a list of pairs
143 sub parraypairs
144 {
145         my $ref = shift;
146         my $i;
147         my $out;
148   
149         for ($i = 0; $i < @$ref; $i += 2) {
150                 my $r1 = @$ref[$i];
151                 my $r2 = @$ref[$i+1];
152                 $out .= "$r1-$r2, ";
153         }
154         chop $out;                                      # remove last space
155         chop $out;                                      # remove last comma
156         return $out;
157 }
158
159 # print all the fields for a record according to privilege
160 #
161 # The prompt record is of the format '<priv>,<prompt>[,<action>'
162 # and is expanded by promptf above
163 #
164 sub print_all_fields
165 {
166         my $self = shift;                       # is a dxchan
167         my $ref = shift;                        # is a thingy with field_prompt and fields methods defined
168         my @out;
169         my @fields = $ref->fields;
170         my $field;
171
172         foreach $field (sort {$ref->field_prompt($a) cmp $ref->field_prompt($b)} @fields) {
173                 if (defined $ref->{$field}) {
174                         my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
175                         push @out, $ans if ($self->priv >= $priv);
176                 }
177         }
178         return @out;
179 }
180
181 # generate a regex from a shell type expression 
182 # see 'perl cookbook' 6.9
183 sub shellregex
184 {
185         my $in = shift;
186         $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
187         return '^' . $in . "\$";
188 }
189
190 # start an attempt at determining whether this string might be a callsign
191 sub iscallsign
192 {
193         my $call = shift;
194         return 1 if $call =~ /^\w+\d+/;
195         return 1 if $call =~ /^\d+\w+/;
196         return undef;
197 }
198
199 # read in a file into a string and return it. 
200 # the filename can be split into a dir and file and the 
201 # file can be in upper or lower case.
202 # there can also be a suffix
203 sub readfilestr
204 {
205         my ($dir, $file, $suffix) = @_;
206         my $fn;
207         
208         if ($suffix) {
209                 $fn = "$dir/$file.$suffix";
210                 unless (-e $fn) {
211                         my $f = uc $file;
212                         $fn = "$dir/$file.$suffix";
213                 }
214         } elsif ($file) {
215                 $fn = "$dir/$file";
216                 unless (-e $fn) {
217                         my $f = uc $file;
218                         $fn = "$dir/$file";
219                 }
220         } else {
221                 $fn = $dir;
222         }
223         my $fh = new IO::File $fn;
224         my $s = undef;
225         if ($fh) {
226                 local $/ = undef;
227                 $s = <$fh>;
228                 $fh->close;
229         }
230         return $s;
231 }