source: ntrip/trunk/BNC/scripts/Common.pm@ 10583

Last change on this file since 10583 was 10513, checked in by wiese, 6 months ago

ADD: replace

  • Property svn:keywords set to Header
File size: 12.0 KB
RevLine 
[9597]1package Common;
2
3#
4# Some common functions
5#
6# Revision: $Header: trunk/BNC/scripts/Common.pm 10513 2024-06-21 08:31:41Z wiese $
7#
8
9use strict;
10use warnings;
11use Exporter;
12use Data::Dumper;
13use Log::Log4perl qw(:easy);
14use File::Temp;
15use File::Basename;
16use File::Spec::Functions;
[10513]17use Fcntl ':flock';
[10512]18use Proc::ProcessTable;
[9597]19
20#$| = 1; # Buffer off (print)
21
22sub trim {
23 my ($text) = @_;
24 $text =~ s/^[\s]*//g;
25 $text =~ s/[\s]*$//g;
26 return $text;
27}
28
29# run a command in the shell.
30sub runCmd {
31 my ($cmd) = shift;
32
33 DEBUG("run cmd: \"$cmd\"");
34
35 my $tmpfh = File::Temp->new( UNLINK => 1, SUFFIX => '.dat' );
36 my $tmpfile = $tmpfh->filename();
37
38 $cmd = "$cmd 2>$tmpfile |";
39 my $PIPE;
40 unless ( open $PIPE, $cmd ) {
41 ERROR("open $cmd | failed ($!)");
42 return ( -1, "", "" );
43 }
44 my $stdout = join '', <$PIPE>;
45 close $PIPE;
46 my $exit_code = $?;
47
48 my $stderr = getContent($tmpfile);
49 return ( $exit_code, $stdout, $stderr );
50}
51
[9747]52sub mkDir {
53 my $dir = shift;
54 return 1 if ( -d $dir );
55
56 eval { mkpath($dir) };
57 if ($@) {
[10099]58 warn ("Could not create path [$dir]: $@");
[9747]59 return 0;
60 }
61 return 1;
62}
63
[9597]64#** @function amInteractiv ()
65# @brief Checks if a program runs interactivly, or e.g. was invoked by cron.
66# @see Perl Cookbook Kap. 15.2
67# @return true if interactive, else false.
68#*
69sub amInteractiv {
70 use POSIX qw(getpgrp tcgetpgrp);
71 my $tty;
72 open ( $tty, "<", "/dev/tty" ) || LOGDIE "Could not open /dev/tty: $!";
73 my $tpgrp = tcgetpgrp( fileno ($tty) ); # get terminal foreground process group
74 my $pgrp = getpgrp (); # get the current process group
75 close $tty;
76 return ( $tpgrp == $pgrp );
77}
78
79#** @function printData ($data)
80# @brief Prints perl data structures. Uses Data::Dumper.
81# @param $data [required] Daten
82# @return -
83#*
84sub printData {
85 my $data = shift;
86 my $d = Data::Dumper->new($data);
87 $d->Indent(3); # pretty print with array indices
88 print $d->Dump;
89}
90
91sub getContent {
92 my ($fileName) = @_;
93 my $errmsg = "";
94 if ( -f $fileName ) {
95 my $readMode = $/;
96 undef $/;
97 open ( FILE, "<", $fileName )
98 or ERROR("Kann Datei nicht zum lesen oeffnen");
99 $errmsg = <FILE>;
100 close (FILE);
101 $/ = $readMode;
102 }
103 return $errmsg;
104}
105
[10512]106# blurt opens a new file, prints the data in $data to it and closes the file.
107# If $options->{append} is set to a true value, data will be appended to the file. Default is false, existing files will be overwritten.
108#
109# If the string is a Unicode string, use the utf8 option: 'blurt( $unicode_string, $file, {utf8 => 1} );'
110sub blurt {
111 my ( $data, $file, $options ) = @_;
112
113 # legacy signature
114 if ( defined $options and ref $options eq "" ) {
115 $options = { append => 1 };
116 }
117
118 $options = {} unless defined $options;
119
120 local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;
121
122 $options->{append} = 0 unless defined $options->{append};
123
124 #_confirm( ( $options->{append} ? "Appending" : "Writing" ) . " " . length ($data) . " bytes to $file" ) or return 1;
125
126 open my $fh, ">" . ( $options->{append} ? ">" : "" ) . $file
127 or LOGCROAK("Cannot open $file for writing ($!)");
128
129 binmode $fh; # Win32 wants that
130
131 if ( $options->{utf8} ) {
132 binmode $fh, ":utf8";
133 }
134
135 print $fh $data
136 or LOGCROAK("Cannot write to $file ($!)");
137 close $fh
138 or LOGCROAK("Cannot close $file ($!)");
139}
140
[9597]141#** @function filePosition ($file, $filePos)
142# @brief Save position of a file in an idxfile.
143#
144# Especially for logfiles. For performance reasons, logfiles should not parsed always from the
145# beginning, the next read access should start at the pos of the last read.
146# Saves the position of the last read in a help-file ".filePos" in
147# the directory of the logfile. If the param $filePos is set, then this position will be saved (Write).
148# Otherwise the current position will be returned (Read).
149# @param $file [required] File of interest
150# @param $filePos [optional] if given, this position ()in Bytes) will be saved, else return current position
151# @return file position in Bytes from beginning of the file
152#*
153sub filePosition {
154 my ( $file, $filePos ) = @_;
155
156 my ( $filName, $filDir ) = fileparse($file);
157 my $idxFil = catfile( $filDir, ".filePos" );
158
159 if ($filePos) {
160
161 # Save this position in idxfile
162 my $newPos = "$filName $filePos";
163 if ( -e $idxFil ) {
164 unless ( replace( $idxFil, "^${filName} \\d+", $newPos ) ) {
165
166 # could not replace -> append
167 blurt( "$newPos\n", $idxFil, { append => 1 } );
[10099]168
169 # my $INP;
170 # if ( !open ( $INP, ">>", $idxFil ) ) {
171 # ERROR("Could not append file [$idxFil]: $!");
172 # return 0;
173 # }
174 # print $INP "$newPos\n";
175 # close ($INP);
[9597]176 }
177 }
178 else {
179 # initial write
180 blurt( "$newPos\n", $idxFil );
[10099]181
[9597]182 #writeTextInFile( $idxFil, "$newPos\n" );
183 }
184 }
185 else {
186
187 # Read current position from idxfile
188 # ----------------------------------
189 if ( !-e $idxFil ) {
190 return 0;
191 }
192 my $line = "";
193 my $idx_fh;
194 if ( !open ( $idx_fh, "<", $idxFil ) ) {
195 ERROR("Could not open for read $idxFil: $!");
196 return 0;
197 }
198 while (<$idx_fh>) {
199 if ( $_ =~ /^$filName (\d+)/ ) { # RegEx problematic with getContentFiltered()
200 $line .= $_;
201 $filePos = $1;
202 last;
203 }
204 }
205 close ($idx_fh);
206
207 if ( $line && !$filePos ) {
208 ERROR("Could not read file position in idxfile $idxFil. Weired line \"$line\"");
209 $filePos = 0;
210 }
211
212 if ($filePos) {
213
214 # If the file was meanwhile newly created, e.g. after restart from BNC
215 my $fileSize = -s $file;
216 if ( $filePos > $fileSize ) {
217 WARN "file $file seams to be newly created";
218 DEBUG("size:$fileSize pos:$filePos");
219 $filePos = 0;
220 }
221 }
222 else {
223 WARN("No position entry found in idxfile for \"$filName\"");
224 $filePos = 0;
225 }
226 }
227
228 return $filePos;
229}
230
[10513]231#** @function replace ($fileName, $pattern, $replacement)
232# @brief Search and replace a string in a file
233# @param $fileName [required] file with full path
234# @param $pattern [required] Search pattern string
235# @param $replacement [required] Replacement string
236# @return true on success, false on error or patter not found
237#*
238sub replace {
239 my ( $fileName, $pattern, $replacement ) = @_;
240
241 # TODO getOptions();
242
243 TRACE "Search and replace string \'$pattern\' in file $fileName";
244
245 my $fileName_tmp = "${fileName}.tmp";
246 my ( $OLD, $NEW );
247 if ( !open ( $OLD, "<", $fileName ) ) {
248 ERROR("Could not open file [$fileName]: $!");
249 return 0;
250 }
251 flock ( $OLD, LOCK_SH ) || ERROR "Could not lock file '$fileName'"; # lock shared (others can read)
252
253 if ( !open ( $NEW, ">", $fileName_tmp ) ) {
254 ERROR("Could not write file [$fileName_tmp]: $!");
255 flock ( $OLD, LOCK_UN ) || ERROR "Could not unlock file '$fileName'";
256 close ($OLD) || ERROR "Could not close file $fileName: $!";
257 return 0;
258 }
259
260 my $numOfReplacements = 0;
261 while (<$OLD>) {
262 if ( $_ =~ /$pattern/ ) {
263 $_ =~ s/$pattern/$replacement/;
264 $numOfReplacements++;
265 }
266 print $NEW $_;
267 }
268 flock ( $OLD, LOCK_UN ) || ERROR "Could not unlock file '$fileName'";
269 close ($OLD) || ( ERROR "Could not close file $fileName: $!" && return 0 );
270 close ($NEW) || ( ERROR "Could not close file $fileName_tmp: $!" && return 0 );
271
272 unless ($numOfReplacements) {
273 WARN "Pattern not found in file";
274 unlink ("$fileName_tmp");
275 return 0; # ist das ein Fehler?
276 }
277 else {
278 TRACE "$numOfReplacements pattern replaced";
279 rename ( $fileName, "${fileName}.orig" ) || ( ERROR "Could not rename file $fileName: $!" && return 0 );
280 rename ( $fileName_tmp, $fileName )
281 || ( ERROR "Could not rename file $fileName_tmp to $fileName: $!" && return 0 );
282 unlink ("${fileName}.orig") || ERROR "Could not remove file ${fileName}.orig";
283 return 1;
284 }
285
286}
287
[9597]288#** @function isAlreadyRunning ()
289# @brief Check if this program is already running.
290# @details Usage: isAlreadyRunning() && die "Same job is already running!\n";@n
291# Purpose: e.g. to avoid a program running twice
292# @see bernese gpsutil::check_job()
293# @return pid of already running job else false
294#*
295sub isAlreadyRunning {
296 my ($scriptName) = fileparse($0);
297
298 use Proc::ProcessTable;
299 my $pt = new Proc::ProcessTable;
300 my $pid_found = 0; # from already running job
301 foreach my $p ( @{ $pt->table } ) {
302 my $cmd = $p->cmndline;
303 if ( $cmd =~ /$scriptName/ && $p->pid != $$ ) {
304 next if ( $p->pid == getppid () ); # when started from cron!
305 DEBUG( "Found: " . $p->pid . ", myself: $$" );
306 $pid_found = $p->pid;
307 DEBUG "Process $cmd is running";
308 last;
309 }
310 }
311
312 return $pid_found;
313}
314
[9627]315# toLineProtocol($rcd)
316# @brief converts $rcd to InfluxDB line protocol
317# @see https://docs.influxdata.com/influxdb/v2.1/reference/syntax/line-protocol/
318sub toLineProtocol {
319 my ($rcd) = @_;
320
321 my $err = 0;
322 my $str = $rcd->{'measurement'} . ',';
323
324 # Tags (sort by key (in lexicographic order) for performance reasons)
325 foreach ( sort { lc ($a) cmp lc ($b) } keys %{ $rcd->{'tags'} } ) {
326 if ( !exists $rcd->{'tags'}->{$_} ) {
327 $err++;
[10099]328
[9627]329 #next; # ?
330 }
331 $str .= $_ . "=" . $rcd->{'tags'}->{$_} . ",";
332 }
333 chop $str;
334 $str .= " ";
335
336 # Fields
[10099]337 foreach ( sort { lc ($a) cmp lc ($b) } keys %{ $rcd->{'fields'} } ) {
338 if ( !exists $rcd->{'fields'}->{$_} ) {
[9627]339 $err++;
[10099]340
341 #next; # ?
[9627]342 }
[10099]343 $str .= $_ . "=" . $rcd->{'fields'}->{$_} . ",";
[9627]344 }
345 chop $str;
346 $str .= " " . $rcd->{'time'}; # prec=s
347 if ($err) {
348 return 0;
349 }
350 return $str;
351}
352
[9597]353#** @function rms ($numbers)
354# @brief Compute the Root mean square.
355# @param $numbers [required] List with your numbers
356# @return RMS value
357# @note use PDL stats() if installed!
358# @see http://rosettacode.org/wiki/Averages/Root_mean_square#Perl
359#*
360sub rms {
361 my $r = 0;
362 $r += $_**2 for @_;
363 return sqrt ( $r / @_ );
364}
365
366#** @function avg ($numbers)
367# @brief Compute the arithmetic mean value.
368# @param $numbers [required] List with your numbers
369# @note use PDL stats() if installed!
370# @return mean value
371# @see http://rosettacode.org/wiki/Average/Arithmetic_mean#Perl
372#*
373sub avg {
374 @_ or return 0;
375 my $sum = 0;
376 $sum += $_ foreach @_;
377 return $sum / @_;
378}
379
380#** @function sigma ($numbers)
381# @brief Compute the STDDEV of the arithmetic mean.
382# @param $numbers [required] List with your numbers
383# @return Sigma value
384# @note use use PDL::Primitive qw(stats) if installed!
385#*
386sub sigma {
387 my $n = scalar (@_);
388
389 if ( $n == 1 ) {
390 WARN "Could not compute sigma for only one sample";
391 return;
392 }
393
394 my $e = 0; # arithm. Mittel
395 $e += $_ for @_;
396 $e = $e / $n;
397
398 my @v = map { $e - $_ } @_;
399 my $vv = 0;
400 $vv += $_**2 for @v;
401 return sqrt ( $vv / ( $n * ( $n - 1 ) ) );
402}
403
404#** @function median (@numbers)
405# @brief Compute the median of a list of numbers.
406# @param @numbers [required] List with your numbers
407# @see https://en.wikipedia.org/wiki/Median
408# @note use PDL stats() if installed!
409# @return median
410#*
411sub median {
412 my $mid = int ( @_ / 2 );
413 my @sorted = sort { $a <=> $b } (@_);
414 if ( @sorted % 2 ) {
415 return $sorted[$mid];
416 }
417 else {
418 return ( $sorted[ $mid - 1 ] + $sorted[$mid] ) / 2;
419 }
420
421 return; # undef
422}
423
4241; # End of Common
425
Note: See TracBrowser for help on using the repository browser.