]> scm.dxcluster.org Git - spider.git/blob - perl/DXUtil.pm
done more work on directory now really quite ak1a compatible
[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 Carp;
13
14 require Exporter;
15 @ISA = qw(Exporter);
16 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf 
17                          parray parraypairs shellregex
18              print_all_fields cltounix 
19             );
20
21 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
22 %patmap = (
23                    '*' => '.*',
24                    '?' => '.',
25                    '[' => '[',
26                    ']' => ']'
27 );
28
29 # a full time for logging and other purposes
30 sub atime
31 {
32         my $t = shift;
33         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
34         $year += 1900;
35         my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
36         return $buf;
37 }
38
39 # get a zulu time in cluster format (2300Z)
40 sub ztime
41 {
42         my $t = shift;
43         my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time);
44         $year += 1900;
45         my $buf = sprintf "%02d%02dZ", $hour, $min;
46         return $buf;
47
48 }
49
50 # get a cluster format date (23-Jun-1998)
51 sub cldate
52 {
53         my $t = shift;
54         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
55         $year += 1900;
56         my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
57         return $buf;
58 }
59
60 # return a cluster style date time
61 sub cldatetime
62 {
63         my $t = shift;
64         my $date = cldate($t);
65         my $time = ztime($t);
66         return "$date $time";
67 }
68
69 # return a unix date from a cluster date and time
70 sub cltounix
71 {
72         my $date = shift;
73         my $time = shift;
74         my ($thisyear) = (gmtime)[5] + 1900;
75
76         return 0 unless $date =~ /^\s*(\d+)-(\w\w\w)-([12][90]\d\d)$/;
77         return 0 if $3 > 2036;
78         return 0 unless abs($thisyear-$3) <= 1;
79         $date = "$1 $2 $3";
80         return 0 unless $time =~ /^([012]\d)([012345]\d)Z$/;
81         $time = "$1:$2 +0000";
82         my $r = str2time("$date $time");
83         return $r == -1 ? undef : $r;
84 }
85
86 # turn a latitude in degrees into a string
87 sub slat
88 {
89         my $n = shift;
90         my ($deg, $min, $let);
91         $let = $n >= 0 ? 'N' : 'S';
92         $n = abs $n;
93         $deg = int $n;
94         $min = int ((($n - $deg) * 60) + 0.5);
95         return "$deg $min $let";
96 }
97
98 # turn a longitude in degrees into a string
99 sub slong
100 {
101         my $n = shift;
102         my ($deg, $min, $let);
103         $let = $n >= 0 ? 'E' : 'W';
104         $n = abs $n;
105         $deg = int $n;
106         $min = int ((($n - $deg) * 60) + 0.5);
107         return "$deg $min $let";
108 }
109
110 # turn a true into 'yes' and false into 'no'
111 sub yesno
112 {
113         my $n = shift;
114         return $n ? $main::yes : $main::no;
115 }
116
117 # format a prompt with its current value and return it with its privilege
118 sub promptf
119 {
120         my ($line, $value) = @_;
121         my ($priv, $prompt, $action) = split ',', $line;
122
123         # if there is an action treat it as a subroutine and replace $value
124         if ($action) {
125                 my $q = qq{\$value = $action(\$value)};
126                 eval $q;
127         }
128         $prompt = sprintf "%15s: %s", $prompt, $value;
129         return ($priv, $prompt);
130 }
131
132 # take an arg as an array list and print it
133 sub parray
134 {
135         my $ref = shift;
136         return join(', ', @{$ref});
137 }
138
139 # take the arg as an array reference and print as a list of pairs
140 sub parraypairs
141 {
142         my $ref = shift;
143         my $i;
144         my $out;
145   
146         for ($i = 0; $i < @$ref; $i += 2) {
147                 my $r1 = @$ref[$i];
148                 my $r2 = @$ref[$i+1];
149                 $out .= "$r1-$r2, ";
150         }
151         chop $out;                                      # remove last space
152         chop $out;                                      # remove last comma
153         return $out;
154 }
155
156 # print all the fields for a record according to privilege
157 #
158 # The prompt record is of the format '<priv>,<prompt>[,<action>'
159 # and is expanded by promptf above
160 #
161 sub print_all_fields
162 {
163         my $self = shift;                       # is a dxchan
164         my $ref = shift;                        # is a thingy with field_prompt and fields methods defined
165         my @out;
166         my @fields = $ref->fields;
167         my $field;
168
169         foreach $field (sort @fields) {
170                 if (defined $ref->{$field}) {
171                         my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
172                         push @out, $ans if ($self->priv >= $priv);
173                 }
174         }
175         return @out;
176 }
177
178 # generate a regex from a shell type expression 
179 # see 'perl cookbook' 6.9
180 sub shellregex
181 {
182         my $in = shift;
183         $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
184         return '^' . $in . '$';
185 }