| 1 | package Common;
|
|---|
| 2 |
|
|---|
| 3 | #
|
|---|
| 4 | # Some common functions
|
|---|
| 5 | #
|
|---|
| 6 | # Revision: $Header: trunk/BNC/scripts/Common.pm 9597 2022-01-10 16:35:57Z 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 | #** @function amInteractiv ()
|
|---|
| 51 | # @brief Checks if a program runs interactivly, or e.g. was invoked by cron.
|
|---|
| 52 | # @see Perl Cookbook Kap. 15.2
|
|---|
| 53 | # @return true if interactive, else false.
|
|---|
| 54 | #*
|
|---|
| 55 | sub amInteractiv {
|
|---|
| 56 | use POSIX qw(getpgrp tcgetpgrp);
|
|---|
| 57 | my $tty;
|
|---|
| 58 | open ( $tty, "<", "/dev/tty" ) || LOGDIE "Could not open /dev/tty: $!";
|
|---|
| 59 | my $tpgrp = tcgetpgrp( fileno ($tty) ); # get terminal foreground process group
|
|---|
| 60 | my $pgrp = getpgrp (); # get the current process group
|
|---|
| 61 | close $tty;
|
|---|
| 62 | return ( $tpgrp == $pgrp );
|
|---|
| 63 | }
|
|---|
| 64 |
|
|---|
| 65 | #** @function printData ($data)
|
|---|
| 66 | # @brief Prints perl data structures. Uses Data::Dumper.
|
|---|
| 67 | # @param $data [required] Daten
|
|---|
| 68 | # @return -
|
|---|
| 69 | #*
|
|---|
| 70 | sub printData {
|
|---|
| 71 | my $data = shift;
|
|---|
| 72 | my $d = Data::Dumper->new($data);
|
|---|
| 73 | $d->Indent(3); # pretty print with array indices
|
|---|
| 74 | print $d->Dump;
|
|---|
| 75 | }
|
|---|
| 76 |
|
|---|
| 77 | sub getContent {
|
|---|
| 78 | my ($fileName) = @_;
|
|---|
| 79 | my $errmsg = "";
|
|---|
| 80 | if ( -f $fileName ) {
|
|---|
| 81 | my $readMode = $/;
|
|---|
| 82 | undef $/;
|
|---|
| 83 | open ( FILE, "<", $fileName )
|
|---|
| 84 | or ERROR("Kann Datei nicht zum lesen oeffnen");
|
|---|
| 85 | $errmsg = <FILE>;
|
|---|
| 86 | close (FILE);
|
|---|
| 87 | $/ = $readMode;
|
|---|
| 88 | }
|
|---|
| 89 | return $errmsg;
|
|---|
| 90 | }
|
|---|
| 91 |
|
|---|
| 92 | #** @function filePosition ($file, $filePos)
|
|---|
| 93 | # @brief Save position of a file in an idxfile.
|
|---|
| 94 | #
|
|---|
| 95 | # Especially for logfiles. For performance reasons, logfiles should not parsed always from the
|
|---|
| 96 | # beginning, the next read access should start at the pos of the last read.
|
|---|
| 97 | # Saves the position of the last read in a help-file ".filePos" in
|
|---|
| 98 | # the directory of the logfile. If the param $filePos is set, then this position will be saved (Write).
|
|---|
| 99 | # Otherwise the current position will be returned (Read).
|
|---|
| 100 | # @param $file [required] File of interest
|
|---|
| 101 | # @param $filePos [optional] if given, this position ()in Bytes) will be saved, else return current position
|
|---|
| 102 | # @return file position in Bytes from beginning of the file
|
|---|
| 103 | #*
|
|---|
| 104 | sub filePosition {
|
|---|
| 105 | my ( $file, $filePos ) = @_;
|
|---|
| 106 |
|
|---|
| 107 | my ( $filName, $filDir ) = fileparse($file);
|
|---|
| 108 | my $idxFil = catfile( $filDir, ".filePos" );
|
|---|
| 109 |
|
|---|
| 110 | if ($filePos) {
|
|---|
| 111 |
|
|---|
| 112 | # Save this position in idxfile
|
|---|
| 113 | my $newPos = "$filName $filePos";
|
|---|
| 114 | if ( -e $idxFil ) {
|
|---|
| 115 | unless ( replace( $idxFil, "^${filName} \\d+", $newPos ) ) {
|
|---|
| 116 |
|
|---|
| 117 | # could not replace -> append
|
|---|
| 118 | blurt( "$newPos\n", $idxFil, { append => 1 } );
|
|---|
| 119 | # my $INP;
|
|---|
| 120 | # if ( !open ( $INP, ">>", $idxFil ) ) {
|
|---|
| 121 | # ERROR("Could not append file [$idxFil]: $!");
|
|---|
| 122 | # return 0;
|
|---|
| 123 | # }
|
|---|
| 124 | # print $INP "$newPos\n";
|
|---|
| 125 | # close ($INP);
|
|---|
| 126 | }
|
|---|
| 127 | }
|
|---|
| 128 | else {
|
|---|
| 129 | # initial write
|
|---|
| 130 | blurt( "$newPos\n", $idxFil );
|
|---|
| 131 | #writeTextInFile( $idxFil, "$newPos\n" );
|
|---|
| 132 | }
|
|---|
| 133 | }
|
|---|
| 134 | else {
|
|---|
| 135 |
|
|---|
| 136 | # Read current position from idxfile
|
|---|
| 137 | # ----------------------------------
|
|---|
| 138 | if ( !-e $idxFil ) {
|
|---|
| 139 | return 0;
|
|---|
| 140 | }
|
|---|
| 141 | my $line = "";
|
|---|
| 142 | my $idx_fh;
|
|---|
| 143 | if ( !open ( $idx_fh, "<", $idxFil ) ) {
|
|---|
| 144 | ERROR("Could not open for read $idxFil: $!");
|
|---|
| 145 | return 0;
|
|---|
| 146 | }
|
|---|
| 147 | while (<$idx_fh>) {
|
|---|
| 148 | if ( $_ =~ /^$filName (\d+)/ ) { # RegEx problematic with getContentFiltered()
|
|---|
| 149 | $line .= $_;
|
|---|
| 150 | $filePos = $1;
|
|---|
| 151 | last;
|
|---|
| 152 | }
|
|---|
| 153 | }
|
|---|
| 154 | close ($idx_fh);
|
|---|
| 155 |
|
|---|
| 156 | if ( $line && !$filePos ) {
|
|---|
| 157 | ERROR("Could not read file position in idxfile $idxFil. Weired line \"$line\"");
|
|---|
| 158 | $filePos = 0;
|
|---|
| 159 | }
|
|---|
| 160 |
|
|---|
| 161 | if ($filePos) {
|
|---|
| 162 |
|
|---|
| 163 | # If the file was meanwhile newly created, e.g. after restart from BNC
|
|---|
| 164 | my $fileSize = -s $file;
|
|---|
| 165 | if ( $filePos > $fileSize ) {
|
|---|
| 166 | WARN "file $file seams to be newly created";
|
|---|
| 167 | DEBUG("size:$fileSize pos:$filePos");
|
|---|
| 168 | $filePos = 0;
|
|---|
| 169 | }
|
|---|
| 170 | }
|
|---|
| 171 | else {
|
|---|
| 172 | WARN("No position entry found in idxfile for \"$filName\"");
|
|---|
| 173 | $filePos = 0;
|
|---|
| 174 | }
|
|---|
| 175 | }
|
|---|
| 176 |
|
|---|
| 177 | return $filePos;
|
|---|
| 178 | }
|
|---|
| 179 |
|
|---|
| 180 | #** @function isAlreadyRunning ()
|
|---|
| 181 | # @brief Check if this program is already running.
|
|---|
| 182 | # @details Usage: isAlreadyRunning() && die "Same job is already running!\n";@n
|
|---|
| 183 | # Purpose: e.g. to avoid a program running twice
|
|---|
| 184 | # @see bernese gpsutil::check_job()
|
|---|
| 185 | # @return pid of already running job else false
|
|---|
| 186 | #*
|
|---|
| 187 | sub isAlreadyRunning {
|
|---|
| 188 | my ($scriptName) = fileparse($0);
|
|---|
| 189 |
|
|---|
| 190 | use Proc::ProcessTable;
|
|---|
| 191 | my $pt = new Proc::ProcessTable;
|
|---|
| 192 | my $pid_found = 0; # from already running job
|
|---|
| 193 | foreach my $p ( @{ $pt->table } ) {
|
|---|
| 194 | my $cmd = $p->cmndline;
|
|---|
| 195 | if ( $cmd =~ /$scriptName/ && $p->pid != $$ ) {
|
|---|
| 196 | next if ( $p->pid == getppid () ); # when started from cron!
|
|---|
| 197 | DEBUG( "Found: " . $p->pid . ", myself: $$" );
|
|---|
| 198 | $pid_found = $p->pid;
|
|---|
| 199 | DEBUG "Process $cmd is running";
|
|---|
| 200 | last;
|
|---|
| 201 | }
|
|---|
| 202 | }
|
|---|
| 203 |
|
|---|
| 204 | return $pid_found;
|
|---|
| 205 | }
|
|---|
| 206 |
|
|---|
| 207 | #** @function rms ($numbers)
|
|---|
| 208 | # @brief Compute the Root mean square.
|
|---|
| 209 | # @param $numbers [required] List with your numbers
|
|---|
| 210 | # @return RMS value
|
|---|
| 211 | # @note use PDL stats() if installed!
|
|---|
| 212 | # @see http://rosettacode.org/wiki/Averages/Root_mean_square#Perl
|
|---|
| 213 | #*
|
|---|
| 214 | sub rms {
|
|---|
| 215 | my $r = 0;
|
|---|
| 216 | $r += $_**2 for @_;
|
|---|
| 217 | return sqrt ( $r / @_ );
|
|---|
| 218 | }
|
|---|
| 219 |
|
|---|
| 220 | #** @function avg ($numbers)
|
|---|
| 221 | # @brief Compute the arithmetic mean value.
|
|---|
| 222 | # @param $numbers [required] List with your numbers
|
|---|
| 223 | # @note use PDL stats() if installed!
|
|---|
| 224 | # @return mean value
|
|---|
| 225 | # @see http://rosettacode.org/wiki/Average/Arithmetic_mean#Perl
|
|---|
| 226 | #*
|
|---|
| 227 | sub avg {
|
|---|
| 228 | @_ or return 0;
|
|---|
| 229 | my $sum = 0;
|
|---|
| 230 | $sum += $_ foreach @_;
|
|---|
| 231 | return $sum / @_;
|
|---|
| 232 | }
|
|---|
| 233 |
|
|---|
| 234 | #** @function sigma ($numbers)
|
|---|
| 235 | # @brief Compute the STDDEV of the arithmetic mean.
|
|---|
| 236 | # @param $numbers [required] List with your numbers
|
|---|
| 237 | # @return Sigma value
|
|---|
| 238 | # @note use use PDL::Primitive qw(stats) if installed!
|
|---|
| 239 | #*
|
|---|
| 240 | sub sigma {
|
|---|
| 241 | my $n = scalar (@_);
|
|---|
| 242 |
|
|---|
| 243 | if ( $n == 1 ) {
|
|---|
| 244 | WARN "Could not compute sigma for only one sample";
|
|---|
| 245 | return;
|
|---|
| 246 | }
|
|---|
| 247 |
|
|---|
| 248 | my $e = 0; # arithm. Mittel
|
|---|
| 249 | $e += $_ for @_;
|
|---|
| 250 | $e = $e / $n;
|
|---|
| 251 |
|
|---|
| 252 | my @v = map { $e - $_ } @_;
|
|---|
| 253 | my $vv = 0;
|
|---|
| 254 | $vv += $_**2 for @v;
|
|---|
| 255 | return sqrt ( $vv / ( $n * ( $n - 1 ) ) );
|
|---|
| 256 | }
|
|---|
| 257 |
|
|---|
| 258 | #** @function median (@numbers)
|
|---|
| 259 | # @brief Compute the median of a list of numbers.
|
|---|
| 260 | # @param @numbers [required] List with your numbers
|
|---|
| 261 | # @see https://en.wikipedia.org/wiki/Median
|
|---|
| 262 | # @note use PDL stats() if installed!
|
|---|
| 263 | # @return median
|
|---|
| 264 | #*
|
|---|
| 265 | sub median {
|
|---|
| 266 | my $mid = int ( @_ / 2 );
|
|---|
| 267 | my @sorted = sort { $a <=> $b } (@_);
|
|---|
| 268 | if ( @sorted % 2 ) {
|
|---|
| 269 | return $sorted[$mid];
|
|---|
| 270 | }
|
|---|
| 271 | else {
|
|---|
| 272 | return ( $sorted[ $mid - 1 ] + $sorted[$mid] ) / 2;
|
|---|
| 273 | }
|
|---|
| 274 |
|
|---|
| 275 | return; # undef
|
|---|
| 276 | }
|
|---|
| 277 |
|
|---|
| 278 | 1; # End of Common
|
|---|
| 279 |
|
|---|
