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

Last change on this file since 9597 was 9597, checked in by wiese, 4 months ago

ADD: Perl utility scripts

  • Property svn:keywords set to Header
File size: 7.5 KB
Line 
1package 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
9use strict;
10use warnings;
11use Exporter;
12use Data::Dumper;
13use Log::Log4perl qw(:easy);
14use File::Temp;
15use File::Basename;
16use File::Spec::Functions;
17
18#$| = 1; # Buffer off (print)
19
20sub 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.
28sub 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#*
55sub 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#*
70sub 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
77sub 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#*
104sub 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#*
187sub 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#*
214sub 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#*
227sub 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#*
240sub 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#*
265sub 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
2781; # End of Common
279
Note: See TracBrowser for help on using the repository browser.