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