| 1 | package 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 |
|
|---|
| 9 | use strict;
|
|---|
| 10 | use warnings;
|
|---|
| 11 | use Exporter;
|
|---|
| 12 | use Data::Dumper;
|
|---|
| 13 | use Log::Log4perl qw(:easy);
|
|---|
| 14 | use File::Temp;
|
|---|
| 15 | use File::Basename;
|
|---|
| 16 | use File::Spec::Functions;
|
|---|
| 17 | use Fcntl ':flock';
|
|---|
| 18 | use Proc::ProcessTable;
|
|---|
| 19 |
|
|---|
| 20 | #$| = 1; # Buffer off (print)
|
|---|
| 21 |
|
|---|
| 22 | sub 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.
|
|---|
| 30 | sub 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 |
|
|---|
| 52 | sub mkDir {
|
|---|
| 53 | my $dir = shift;
|
|---|
| 54 | return 1 if ( -d $dir );
|
|---|
| 55 |
|
|---|
| 56 | eval { mkpath($dir) };
|
|---|
| 57 | if ($@) {
|
|---|
| 58 | warn ("Could not create path [$dir]: $@");
|
|---|
| 59 | return 0;
|
|---|
| 60 | }
|
|---|
| 61 | return 1;
|
|---|
| 62 | }
|
|---|
| 63 |
|
|---|
| 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 | #*
|
|---|
| 69 | sub 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 | #*
|
|---|
| 84 | sub 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 |
|
|---|
| 91 | sub 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 |
|
|---|
| 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} );'
|
|---|
| 110 | sub 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 |
|
|---|
| 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 | #*
|
|---|
| 153 | sub 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 } );
|
|---|
| 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);
|
|---|
| 176 | }
|
|---|
| 177 | }
|
|---|
| 178 | else {
|
|---|
| 179 | # initial write
|
|---|
| 180 | blurt( "$newPos\n", $idxFil );
|
|---|
| 181 |
|
|---|
| 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 |
|
|---|
| 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 | #*
|
|---|
| 238 | sub 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 |
|
|---|
| 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 | #*
|
|---|
| 295 | sub 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 |
|
|---|
| 315 | # toLineProtocol($rcd)
|
|---|
| 316 | # @brief converts $rcd to InfluxDB line protocol
|
|---|
| 317 | # @see https://docs.influxdata.com/influxdb/v2.1/reference/syntax/line-protocol/
|
|---|
| 318 | sub 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++;
|
|---|
| 328 |
|
|---|
| 329 | #next; # ?
|
|---|
| 330 | }
|
|---|
| 331 | $str .= $_ . "=" . $rcd->{'tags'}->{$_} . ",";
|
|---|
| 332 | }
|
|---|
| 333 | chop $str;
|
|---|
| 334 | $str .= " ";
|
|---|
| 335 |
|
|---|
| 336 | # Fields
|
|---|
| 337 | foreach ( sort { lc ($a) cmp lc ($b) } keys %{ $rcd->{'fields'} } ) {
|
|---|
| 338 | if ( !exists $rcd->{'fields'}->{$_} ) {
|
|---|
| 339 | $err++;
|
|---|
| 340 |
|
|---|
| 341 | #next; # ?
|
|---|
| 342 | }
|
|---|
| 343 | $str .= $_ . "=" . $rcd->{'fields'}->{$_} . ",";
|
|---|
| 344 | }
|
|---|
| 345 | chop $str;
|
|---|
| 346 | $str .= " " . $rcd->{'time'}; # prec=s
|
|---|
| 347 | if ($err) {
|
|---|
| 348 | return 0;
|
|---|
| 349 | }
|
|---|
| 350 | return $str;
|
|---|
| 351 | }
|
|---|
| 352 |
|
|---|
| 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 | #*
|
|---|
| 360 | sub 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 | #*
|
|---|
| 373 | sub 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 | #*
|
|---|
| 386 | sub 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 | #*
|
|---|
| 411 | sub 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 |
|
|---|
| 424 | 1; # End of Common
|
|---|
| 425 |
|
|---|
