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