From f45e96e9c3f4ba4f8a201e670cb8ea07a07c63a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Fri, 24 Jan 2025 12:55:06 +0100 Subject: [PATCH 01/68] update index.md for new release 2.7.2 --- index.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/index.md b/index.md index dfb75402..64c8bd01 100644 --- a/index.md +++ b/index.md @@ -12,9 +12,9 @@ WebObs is presently fully functional and used in a dozen observatories (see the ## Download the latest release -- [WebObs-2.7.1.tar.gz](https://github.com/IPGP/webobs/releases/download/v2.7.1/WebObs-2.7.1.tar.gz) (102 Mb) updated December 23, 2024 -- [Release notes](https://github.com/IPGP/webobs/blob/v2.7.1/release-notes.md) (see also the [What's new?](#whatsnew) section below) -- [User manual](https://github.com/IPGP/webobs/releases/download/v2.7.1/WebObs_Manual.pdf) (in progress) +- [WebObs-2.7.2.tar.gz](https://github.com/IPGP/webobs/releases/download/v2.7.2/WebObs-2.7.2.tar.gz) (103 Mb) updated January 24, 2024 +- [Release notes](https://github.com/IPGP/webobs/blob/v2.7.2/release-notes.md) (see also the [What's new?](#whatsnew) section below) +- [User manual](https://github.com/IPGP/webobs/releases/download/v2.7.2/WebObs_Manual.pdf) (in progress) - And, for a first install: - Mandatory (license free): **Matlab runtime** for [Linux 64bit](http://www.ipgp.fr/~beaudu/webobs/MCR_Runtime/MCR_R2011b_glnxa64_installer.zip) (386 Mb) or [Linux 32bit](http://www.ipgp.fr/~beaudu/webobs/MCR_Runtime/MCR_R2011b_glnx86_installer.zip) (389 Mb) - Recommanded: **ETOPO1** (see [below](#srtm1) for download and install) From 68d0f9849c4b6d5b859876d0fc123aeefb3de995 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Tue, 4 Feb 2025 15:27:30 +0100 Subject: [PATCH 02/68] update GSE and JSON event files and BCSF trigger content --- CODE/cgi-bin/mailB3.pl | 107 +++++++++++++-------------- CODE/matlab/superprocs/tremblemaps.m | 9 ++- 2 files changed, 58 insertions(+), 58 deletions(-) diff --git a/CODE/cgi-bin/mailB3.pl b/CODE/cgi-bin/mailB3.pl index 32c247cc..eda7ca85 100755 --- a/CODE/cgi-bin/mailB3.pl +++ b/CODE/cgi-bin/mailB3.pl @@ -48,21 +48,21 @@ =head1 Query string parameters my $g = $q->param('g'); my $b3 = "$WEBOBS{'ROOT_OUTG'}/$grid/$ts/$g"; if ( -l "$b3.png") { - my $b3png = readlink("$b3.png"); - $b3png =~ s/\.png$//g; - $b3 =~ s/b3/$b3png/g; - $g =~ s/b3/$b3png/g; + my $b3png = readlink("$b3.png"); + $b3png =~ s/\.png$//g; + $b3 =~ s/b3/$b3png/g; + $g =~ s/b3/$b3png/g; } my ($GRIDType, $GRIDName) = split(/\./,$grid); # before continuing, verify consistancy and authorization if (not (clientHasAdm(type=>"authprocs",name=>"$GRIDName"))) { - print_head(); - print("

$__{'Unauthorized action'}

\n"); - print_secondary("Sorry, you cannot use this script on $grid. Please contact your administrator."); - print_foot(); - exit(0); + print_head(); + print("

$__{'Unauthorized action'}

\n"); + print_secondary("Sorry, you cannot use this script on $grid. Please contact your administrator."); + print_foot(); + exit(0); } my $submit_url = $q->url(); @@ -75,7 +75,7 @@ =head1 Query string parameters ##---- Script functions sub print_head { - print <<__EOD__; + print <<__EOD__; Content-type: text/html @@ -124,13 +124,13 @@ sub print_head { border-color: #d6d8db; } - \n"; diff --git a/CODE/cgi-bin/Welcome.pl b/CODE/cgi-bin/Welcome.pl index 82702bb7..154fc317 100755 --- a/CODE/cgi-bin/Welcome.pl +++ b/CODE/cgi-bin/Welcome.pl @@ -68,7 +68,7 @@ =head1 {WELCOME_CONF} format # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $today = new Time::Piece; @@ -78,8 +78,8 @@ =head1 {WELCOME_CONF} format # ---- our configuration my %APARMS; if (defined($WEBOBS{WELCOME_CONF})) { - %APARMS = readCfg("$WEBOBS{WELCOME_CONF}"); - if (!%APARMS) { die "Couldn't read $WEBOBS{WELCOME_CONF}" } + %APARMS = readCfg("$WEBOBS{WELCOME_CONF}"); + if (!%APARMS) { die "Couldn't read $WEBOBS{WELCOME_CONF}" } } else { die "No WELCOME-PAGE configuration defined $WEBOBS{WELCOME_CONF}" } my $DN = $APARMS{DAYNIGHT} // "NO"; my $HW = $APARMS{HELLOWORLD} // $__{'Hello World'}; @@ -91,33 +91,33 @@ =head1 {WELCOME_CONF} format my @DNcolors = ( "#FF0000", "#00FF00" , "#0000FF", "#FFFF00" ,"#00FFFF", "#FF00FF"); my $DNc = 0; for (sort keys(%fuseaux_horaires)) { - $ENV{TZ} = $_; - my $bullet = "• "; - if (isok($DN)) { - push(@liste_heures,sprintf("
%s%s,
    %s
", - ($DNc%2)?"#EAE4CE":"transparent", - $bullet, - $fuseaux_horaires{$_}, - l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); - } else { - push(@liste_heures,sprintf("%s, %s
",$fuseaux_horaires{$_},l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); - } - my @ztab = split(/\t/, qx(grep $_ /usr/share/zoneinfo/zone.tab)); # code \t LatLon \t TZname - if (@ztab) { - my ($junk,$lats,$lat,$longs,$long) = split(/([+-])/, $ztab[1]); # either +-DDMM+-DDDMM or +-DDMMSS+-DDDMMSS - if (length($lat) == 4) { - $lat = substr($lat,0,2)+substr($lat,2,2)/60; - $long = substr($long,0,3)+substr($long,3,2)/60; - } else { - $lat = substr($lat,0,2)+substr($lat,2,2)/60+substr($lat,4,2)/3600; - $long = substr($long,0,3)+substr($long,3,2)/60+substr($long,5,2)/3600; - } - $lat =~ s/,/./; $long =~ s/,/./; - push(@liste_coords,"[".$lats.$lat.",".$longs.$long.",'".$DNcolors[$DNc]."']"); - $DNc++; $DNc = 0 if ($DNc > $#DNcolors); - } - $DNcoords = "[".join(",",@liste_coords)."]"; - $ENV{TZ} = $tz_old; + $ENV{TZ} = $_; + my $bullet = "• "; + if (isok($DN)) { + push(@liste_heures,sprintf("
%s%s,
    %s
", + ($DNc%2)?"#EAE4CE":"transparent", + $bullet, + $fuseaux_horaires{$_}, + l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); + } else { + push(@liste_heures,sprintf("%s, %s
",$fuseaux_horaires{$_},l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); + } + my @ztab = split(/\t/, qx(grep $_ /usr/share/zoneinfo/zone.tab)); # code \t LatLon \t TZname + if (@ztab) { + my ($junk,$lats,$lat,$longs,$long) = split(/([+-])/, $ztab[1]); # either +-DDMM+-DDDMM or +-DDMMSS+-DDDMMSS + if (length($lat) == 4) { + $lat = substr($lat,0,2)+substr($lat,2,2)/60; + $long = substr($long,0,3)+substr($long,3,2)/60; + } else { + $lat = substr($lat,0,2)+substr($lat,2,2)/60+substr($lat,4,2)/3600; + $long = substr($long,0,3)+substr($long,3,2)/60+substr($long,5,2)/3600; + } + $lat =~ s/,/./; $long =~ s/,/./; + push(@liste_coords,"[".$lats.$lat.",".$longs.$long.",'".$DNcolors[$DNc]."']"); + $DNc++; $DNc = 0 if ($DNc > $#DNcolors); + } + $DNcoords = "[".join(",",@liste_coords)."]"; + $ENV{TZ} = $tz_old; } my $displayListeHeures = ""; $displayListeHeures .= ""; @@ -136,9 +136,9 @@ =head1 {WELCOME_CONF} format my @holidaysdef; my $wodp_holidays = "[]"; if (open(FILE, "<$WEBOBS{FILE_DAYSOFF}")) { - while() { push(@holidaysdef,l2u($_)) if ($_ !~/^(#|$)/); }; close(FILE); - chomp(@holidaysdef); - $wodp_holidays = "[".join(',',map { my ($d,$t)=split(/\|/,$_); "{d: \"$d\", t:\"$t\"}" } @holidaysdef)."]"; + while() { push(@holidaysdef,l2u($_)) if ($_ !~/^(#|$)/); }; close(FILE); + chomp(@holidaysdef); + $wodp_holidays = "[".join(',',map { my ($d,$t)=split(/\|/,$_); "{d: \"$d\", t:\"$t\"}" } @holidaysdef)."]"; } my $calendar = ""; @@ -159,19 +159,19 @@ =head1 {WELCOME_CONF} format print "Content-type: text/html\n\n"; print '', "\n"; print "$titrePage\n", - "", - "", - ""; + "", + "", + ""; if ($APARMS{AUTOREFRESH_SECONDS} gt 0) { - print ""; + print ""; } print "\n\n\n", - "
", - "", - "", - "", - "", - ""; + "
", + "", + "", + "", + "", + ""; if (isok($DN)) { print ""; } print <<"FIN"; \n"; + print "\n"; } else { - print $cgi->h3("Error occured !"); + print $cgi->h3("Error occured !"); } print $cgi->end_html(); - # --- Send the new event to TCP socket print STDERR "** newSC3 = $newSC3 **\n"; print STDERR "** PeerHost => $MC3{WO2SC3_HOSTNAME}, PeerPort => $MC3{WO2SC3_PORT} **\n"; if ($newSC3 > 0) { - # flush after every write - $| = 1; - - my ($socket,$client_socket); - - # creating object interface of IO::Socket::INET modules which internally creates - # socket, binds and connects to the TCP server running on the specific port. - $socket = new IO::Socket::INET ( - PeerHost => $MC3{WO2SC3_HOSTNAME}, - PeerPort => $MC3{WO2SC3_PORT}, - Proto => 'tcp', - ) or print STDERR "ERROR in Socket Creation : $!\n"; - - #print "TCP Connection Success.\n"; - - # read the socket data sent by server. - #$data = <$socket>; - # we can also read from socket through recv() in IO::Socket::INET - # $socket->recv($data,1024); - #print "Received from Server : $data\n"; - - # write on the socket to server. - #print $socket "$newQML\n"; - # we can also send the data through IO::Socket::INET module, - if ($socket) { - $socket->send($newQML); - #sleep (10); - $socket->close(); - } + + # flush after every write + $| = 1; + + my ($socket,$client_socket); + +# creating object interface of IO::Socket::INET modules which internally creates +# socket, binds and connects to the TCP server running on the specific port. + $socket = new IO::Socket::INET ( + PeerHost => $MC3{WO2SC3_HOSTNAME}, + PeerPort => $MC3{WO2SC3_PORT}, + Proto => 'tcp', + ) or print STDERR "ERROR in Socket Creation : $!\n"; + + #print "TCP Connection Success.\n"; + + # read the socket data sent by server. + #$data = <$socket>; + # we can also read from socket through recv() in IO::Socket::INET + # $socket->recv($data,1024); + #print "Received from Server : $data\n"; + + # write on the socket to server. + #print $socket "$newQML\n"; + # we can also send the data through IO::Socket::INET module, + if ($socket) { + $socket->send($newQML); + + #sleep (10); + $socket->close(); + } } # --------------------------------------------------------------------- sub Quit { - if (-e $_[0]) { - unlink $_[0]; - } - die "WEBOBS: $_[1]"; + if (-e $_[0]) { + unlink $_[0]; + } + die "WEBOBS: $_[1]"; } __END__ diff --git a/CODE/cgi-bin/fedit.pl b/CODE/cgi-bin/fedit.pl index ad402955..39a7a918 100755 --- a/CODE/cgi-bin/fedit.pl +++ b/CODE/cgi-bin/fedit.pl @@ -88,24 +88,24 @@ =head1 CONFIGURATION VARIABLES # Return information when OK # (Reminder: we use text/plain as this is an ajax action) sub htmlMsgOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "$_[0] successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "$_[0] successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); } # Return information when not OK # (Reminder: we use text/plain as this is an ajax action) sub htmlMsgNotOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "Update FAILED !\n $_[0] \n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "Update FAILED !\n $_[0] \n"; } # Open an SQLite connection to the forms database sub connectDbForms { - return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; + return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; } sub count_inputs { @@ -145,11 +145,11 @@ sub count_inputs { # Read the list of all nodes opendir my $nodeDH, $NODES{PATH_NODES} - or die "Problem opening node list from '$NODES{PATH_NODES}': $!\n"; + or die "Problem opening node list from '$NODES{PATH_NODES}': $!\n"; my @ALL_NODES = sort grep(!/^\./ && -d "$NODES{PATH_NODES}/$_", - readdir($nodeDH)); + readdir($nodeDH)); closedir($nodeDH) - or die "Problem closing node list from '$NODES{PATH_NODES}': $!\n"; + or die "Problem closing node list from '$NODES{PATH_NODES}': $!\n"; # codemirror configuration my $CM_edit_theme = $WEBOBS{JS_EDITOR_EDIT_THEME} // "default"; @@ -169,165 +169,171 @@ sub count_inputs { $formConfFile = "$formdir$FORMName.conf"; my @db_columns0 = ("id integer PRIMARY KEY AUTOINCREMENT", "trash boolean DEFAULT FALSE", "node text NOT NULL", - "edate datetime", "edate_min datetime", - "sdate datetime NOT NULL", "sdate_min datetime", - "operators text NOT NULL"); + "edate datetime", "edate_min datetime", + "sdate datetime NOT NULL", "sdate_min datetime", + "operators text NOT NULL"); my @db_columns1 = ("comment text", "tsupd text NOT NULL", "userupd text NOT NULL"); # ---- action is 'save' # if ($action eq 'save') { - if (! -e $formConfFile) { - # --- Form creation (config file does not exist) - - if (! -d $formdir and !mkdir($formdir)) { - htmlMsgNotOK("fedit: error while creating directory $formdir: $!"); - exit; - } - if (open(FILE,">", $formConfFile) ) { - print FILE u2l($text); - close(FILE); - } else { - htmlMsgNotOK("fedit: error creating $formConfFile: $!"); - exit; - } - - # --- connecting to the database in order to create a table with the name of the FORM - my $dbh = connectDbForms(); - - # --- checking if the table we want to edit exists - my $tbl = lc($FORMName); - - my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - - if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB - # --- creation of the DB table - my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); - - my @db_columns = @db_columns0; - push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); - push(@db_columns, @db_columns1); - - my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; - #htmlMsgOK($stmt); - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - } else { - htmlMsgNotOK("Can't create the table !"); - exit; - } - - htmlMsgOK("fedit: $FORMName created."); - exit; - } else { - # --- Form delete or update (config file already exists) - - # --- Delete the form! - if ($delete == 1) { - # delete the dir/file first - my $rmtree_errors; - rmtree($formdir, {'safe' => 1, 'error' => \$rmtree_errors}); - if ($rmtree_errors && @$rmtree_errors) { - htmlMsgNotOK("fedit couldn't delete directory $formdir"); - print STDERR "fedit.pl: unable to delete directory $formdir: " - .join(", ", @$rmtree_errors)."\n"; - exit; - } - htmlMsgOK("$FORMName deleted"); - exit; - } - - # --- connecting to the database in order to create a table with the name of the FORM - my $dbh = connectDbForms(); - - # --- checking if the table we want to edit exists - my $tbl = lc($FORMName); - - my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - - if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB - # --- creation of the DB table - my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); - - my @db_columns = @db_columns0; - push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); - push(@db_columns, @db_columns1); - - my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - } - - # now we know if the table exists - # we want to look at the modification of $text - my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); - my $newKeys = $#inputs; - my $oldKeys = count_inputs(readCfg($formConfFile)); - - my $msg; - if ($newKeys + 1 > $oldKeys) { - $msg = "A new INPUT has been added to the FORM !"; - - # --- connecting to the database in order to add the new INPUT to the DB - my @db_columns = @db_columns0; - push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); - push(@db_columns, @db_columns1); - - my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - } elsif ($newKeys + 1 < $oldKeys) { - $msg = "You can't remove an INPUT !"; - htmlMsgNotOK($msg); - exit; - } - - if ($TS0 != (stat("$formConfFile"))[9]) { - htmlMsgNotOK("$FORMName $__{'has been modified while you were editing'}"); - exit; - } - if ( sysopen(FILE, "$formConfFile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $FORMName..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $formConfFile $formConfFile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - $text =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@rawfile,u2l($text)); - print FILE @rawfile ; - close(FILE); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $FORMName"); - } - } else { htmlMsgNotOK("$me opening $FORMName - $!") } - htmlMsgOK($msg); - exit; - } + if (! -e $formConfFile) { + + # --- Form creation (config file does not exist) + + if (! -d $formdir and !mkdir($formdir)) { + htmlMsgNotOK("fedit: error while creating directory $formdir: $!"); + exit; + } + if (open(FILE,">", $formConfFile) ) { + print FILE u2l($text); + close(FILE); + } else { + htmlMsgNotOK("fedit: error creating $formConfFile: $!"); + exit; + } + +# --- connecting to the database in order to create a table with the name of the FORM + my $dbh = connectDbForms(); + + # --- checking if the table we want to edit exists + my $tbl = lc($FORMName); + + my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + + if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB + + # --- creation of the DB table + my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); + + my @db_columns = @db_columns0; + push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); + push(@db_columns, @db_columns1); + + my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; + + #htmlMsgOK($stmt); + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + } else { + htmlMsgNotOK("Can't create the table !"); + exit; + } + + htmlMsgOK("fedit: $FORMName created."); + exit; + } else { + + # --- Form delete or update (config file already exists) + + # --- Delete the form! + if ($delete == 1) { + + # delete the dir/file first + my $rmtree_errors; + rmtree($formdir, {'safe' => 1, 'error' => \$rmtree_errors}); + if ($rmtree_errors && @$rmtree_errors) { + htmlMsgNotOK("fedit couldn't delete directory $formdir"); + print STDERR "fedit.pl: unable to delete directory $formdir: " + .join(", ", @$rmtree_errors)."\n"; + exit; + } + htmlMsgOK("$FORMName deleted"); + exit; + } + +# --- connecting to the database in order to create a table with the name of the FORM + my $dbh = connectDbForms(); + + # --- checking if the table we want to edit exists + my $tbl = lc($FORMName); + + my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + + if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB + + # --- creation of the DB table + my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); + + my @db_columns = @db_columns0; + push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); + push(@db_columns, @db_columns1); + + my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + } + + # now we know if the table exists + # we want to look at the modification of $text + my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); + my $newKeys = $#inputs; + my $oldKeys = count_inputs(readCfg($formConfFile)); + + my $msg; + if ($newKeys + 1 > $oldKeys) { + $msg = "A new INPUT has been added to the FORM !"; + + # --- connecting to the database in order to add the new INPUT to the DB + my @db_columns = @db_columns0; + push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); + push(@db_columns, @db_columns1); + + my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + } elsif ($newKeys + 1 < $oldKeys) { + $msg = "You can't remove an INPUT !"; + htmlMsgNotOK($msg); + exit; + } + + if ($TS0 != (stat("$formConfFile"))[9]) { + htmlMsgNotOK("$FORMName $__{'has been modified while you were editing'}"); + exit; + } + if ( sysopen(FILE, "$formConfFile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $FORMName..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $formConfFile $formConfFile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + $text =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@rawfile,u2l($text)); + print FILE @rawfile ; + close(FILE); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $FORMName"); + } + } else { htmlMsgNotOK("$me opening $FORMName - $!") } + htmlMsgOK($msg); + exit; + } } # ---- action is 'edit' (default) # if ( -e "$formConfFile" ) { # looking if the FORM already exists - if ($editOK) { - @rawfile = readFile($formConfFile); - $TS0 = (stat($formConfFile))[9] ; - } + if ($editOK) { + @rawfile = readFile($formConfFile); + $TS0 = (stat($formConfFile))[9] ; + } } else { # we are creating a new FORM - if ($admOK) { - $formConfFile = "$WEBOBS{ROOT_CODE}/tplates/$template"; - @rawfile = readFile($formConfFile); - $TS0 = (stat($formConfFile))[9] ; - $newF = 1; - } + if ($admOK) { + $formConfFile = "$WEBOBS{ROOT_CODE}/tplates/$template"; + @rawfile = readFile($formConfFile); + $TS0 = (stat($formConfFile))[9] ; + $newF = 1; + } } # start building page @@ -350,10 +356,10 @@ sub count_inputs { _EOD_ if ($CM_edit_theme != "default") { - print " \n"; + print " \n"; } if ($CM_browsing_theme != "default" && $CM_edit_theme != $CM_browsing_theme) { - print " \n"; + print " \n"; } print <<_EOD_; @@ -422,15 +428,17 @@ sub count_inputs { _EOD_ print "

$titrePage $FORMName"; + # delete an existing form is only for the WO Owner! if ($newF == 0 && $USERS{$CLIENT}{UID} eq "!") { - print " "; + print " "; } print "

\n"; # ---- Display file contents into a "textarea" so that it can be edited print "
\n"; print ""; print ""; print ""; print "); + } + print qq(); + if (clientHasAdm(type=>"authforms",name=>"SOILSOLUTION")) { + print qq(); + } + print qq(
); } print qq(
\n"; + #print "
\n"; print "\n"; print "
$FORMName
\n"; @@ -439,26 +447,28 @@ sub count_inputs { # ---- Lists my @lists = grep {/_TYPE\|list:/} split(/\n/, $txt); -@lists = uniq(map {s/^.*\|list:\s*(.*)$/$1/g; $_} @lists); +@lists = uniq(map {s/^.*\|list:\s*(.*)$/$1/g; $_} @lists); print "
Lists\n
    "; foreach (@lists) { - $_ = trim($_); - my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; - my $fdir = "$WEBOBS{PATH_FORMS}/$FORMName"; - if (! -d $fdir and !mkdir($fdir)) { - print "fedit: error while creating directory $fdir: $!"; - } - my $file = "$fdir/$_"; - if ((! -e $file) && -e "$tdir/$_") { - # if the file exists only in the template directory, copy it - qx(cp $tdir/$_ $file 2>&1); - } elsif (! -e $file) { - # if the file does not exist anywhere, copy the generic FORM_list - qx(cp $tdir/FORM_list.conf $file 2>&1); - } - print "
  • $_
    • \n"; + $_ = trim($_); + my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; + my $fdir = "$WEBOBS{PATH_FORMS}/$FORMName"; + if (! -d $fdir and !mkdir($fdir)) { + print "fedit: error while creating directory $fdir: $!"; + } + my $file = "$fdir/$_"; + if ((! -e $file) && -e "$tdir/$_") { + + # if the file exists only in the template directory, copy it + qx(cp $tdir/$_ $file 2>&1); + } elsif (! -e $file) { + + # if the file does not exist anywhere, copy the generic FORM_list + qx(cp $tdir/FORM_list.conf $file 2>&1); + } + print "
  • $_
    • \n"; } print "
\n"; diff --git a/CODE/cgi-bin/formBOJAP.pl b/CODE/cgi-bin/formBOJAP.pl index c64911a7..a0060e8d 100755 --- a/CODE/cgi-bin/formBOJAP.pl +++ b/CODE/cgi-bin/formBOJAP.pl @@ -58,11 +58,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -87,6 +87,7 @@ =head1 Query string parameter my $affiche; my $s; my @codesListe; + #my @types = readCfgFile("$FORMPATH/$FORM{FILE_TYPE}"); my @rapports = readCfgFile($FORM->path."/".$FORM->conf('FILE_RAPPORTS')); @@ -209,31 +210,31 @@ =head1 Query string parameter my ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val); $id=$date1=$hr1=$date2=$hr2=$site=$cCl=$cCO2=$cSO4=$m1=$m2=$m3=$m4=$h2o=$koh=$rem=$val=""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee1,$sel_mois1,$sel_jour1) = split (/-/,$date1); - ($sel_hr1,$sel_mn1) = split (/:/,$hr1); - ($sel_annee2,$sel_mois2,$sel_jour2) = split (/-/,$date2); - ($sel_hr2,$sel_mn2) = split (/:/,$hr2); - $sel_site = $site; - $sel_cCl = $cCl; - $sel_cCO2 = $cCO2; - $sel_cSO4 = $cSO4; - $sel_h2o = $h2o; - $sel_koh = $koh; - $sel_m1 = $m1; - $sel_m2 = $m2; - $sel_m3 = $m3; - $sel_m4 = $m4; - $sel_rem = $rem; - $sel_rem =~ s/"/"/g; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = ""; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee1,$sel_mois1,$sel_jour1) = split (/-/,$date1); + ($sel_hr1,$sel_mn1) = split (/:/,$hr1); + ($sel_annee2,$sel_mois2,$sel_jour2) = split (/-/,$date2); + ($sel_hr2,$sel_mn2) = split (/:/,$hr2); + $sel_site = $site; + $sel_cCl = $cCl; + $sel_cCO2 = $cCO2; + $sel_cSO4 = $cSO4; + $sel_h2o = $h2o; + $sel_koh = $koh; + $sel_m1 = $m1; + $sel_m2 = $m2; + $sel_m3 = $m3; + $sel_m4 = $m4; + $sel_rem = $rem; + $sel_rem =~ s/"/"/g; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = ""; } + } else { $QryParm->{id} = ""; $val = "" ;} } print "\n"; if ($QryParm->{id} ne "") { - print "{id}\">"; - print ""; + } + print ""; + if (clientHasAdm(type=>"authforms",name=>"RIVERS")) { + print ""; + } + print "
"; } print "
@@ -243,7 +244,7 @@ =head1 Query string parameter print "
"; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; @@ -251,119 +252,119 @@ =head1 Query string parameter print ""; print ""; print ""; print ""; print ""; print ""; print "); + } + print qq(); + if (clientHasAdm(type=>"authforms",name=>"RAINWATER")) { + print qq(); + } + print qq(
); } print qq(
"; print "
Date et lieu du prélèvement"; - print "

+print "

Date début: "; - print " "; - print " "; - print "  Heure: "; - print "
"; +for (@anneeListe) { + if ($_ == $sel_annee1) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; +print "  Heure: "; +print "
"; - print "Date fin: "; - print " "; - print " "; - print "  Heure: "; - print "
"; - - print "Site:

"; +print "Date fin: "; +print " "; +print " "; +print "  Heure: "; +print "
"; + +print "Site:

"; print "
\n"; print "
Solution initiale"; - print "

"; - print "Volume H2O (en ml) =
\n +print "

"; +print "Volume H2O (en ml) =
\n Concentration KOH (en mol/l) =
\n"; - print "

"; +print "

"; print "
\n"; print "		"; print "
Masse recueillie\n"; - print ""; - print ""; - print "
"; - print "

"; - print "M1 (en g) =
\n"; - print "M2 (en g) =
\n"; - print "M3 (en g) =
\n"; - print "M4 (en g) =
\n"; - print "
"; - print "Masse totale (g) =

"; +print ""; +print ""; +print "
"; +print "

"; +print "M1 (en g) =
\n"; +print "M2 (en g) =
\n"; +print "M3 (en g) =
\n"; +print "M4 (en g) =
\n"; +print "
"; +print "Masse totale (g) =

"; print "
\n"; print "
Concentrations\n"; - print "
"; - print "

Attention: valeurs en ppm = mg/l

\n"; - print "

"; - print "Cl (mg/l) =
\n"; - print "CO2 (mg/l) =
\n"; - print "SO4 mg/l) =
\n"; - print "

"; +print "
"; +print "

Attention: valeurs en ppm = mg/l

\n"; +print "

"; +print "Cl (mg/l) =
\n"; +print "CO2 (mg/l) =
\n"; +print "SO4 mg/l) =
\n"; +print "

"; print "
\n"; print "
"; - print "

", - "Observations :

"; - if ($val ne "") { - print "Information de saisie: $val +print "

", + "Observations :

"; +if ($val ne "") { + print "Information de saisie: $val

"; - } +} print "
"; print "

"; diff --git a/CODE/cgi-bin/formCLB.pl b/CODE/cgi-bin/formCLB.pl index 6463b64b..b195364e 100755 --- a/CODE/cgi-bin/formCLB.pl +++ b/CODE/cgi-bin/formCLB.pl @@ -47,13 +47,14 @@ =head1 Query string parameters # --- subroutine sub sort_clb_lines { - my %data = shift(@_); - # Sort the list of lines of the calibration file by date, time, - # and channel number, using a numerical sort for the latter. - $data{$a}{'DATE'} cmp $data{$b}{'DATE'} or - $data{$a}{'TIME'} cmp $data{$b}{'TIME'} or - $data{$a}{'nv'} <=> $data{$b}{'nv'} or - $a cmp $b; # final comparison to make sure the ordering is always well defined + my %data = shift(@_); + + # Sort the list of lines of the calibration file by date, time, + # and channel number, using a numerical sort for the latter. + $data{$a}{'DATE'} cmp $data{$b}{'DATE'} or + $data{$a}{'TIME'} cmp $data{$b}{'TIME'} or + $data{$a}{'nv'} <=> $data{$b}{'nv'} or + $a cmp $b; # final comparison to make sure the ordering is always well defined } # ---- inits and checkings @@ -74,28 +75,27 @@ sub sort_clb_lines { ($GRIDType, $GRIDName, $NODEName) = split(/[\.\/]/, trim($QryParm->{'node'})); if ( $GRIDType eq "PROC" && $GRIDName ne "" ) { - if ( !clientHasEdit(type=>"authprocs",name=>"$GRIDName")) { - die "$__{'Not authorized'} (edit) $GRIDType.$GRIDName.$NODEName"; - } - if ($NODEName ne "") { - my %S = readNode($NODEName); - %NODE = %{$S{$NODEName}}; - if (%NODE) { - %CLBS = readCfg("$WEBOBS{ROOT_CODE}/etc/clb.conf"); - @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); - %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); - %data = readCLB("$GRIDType.$GRIDName.$NODEName"); - } else { - die "$__{'Could not read'} $QryParm->{'node'} $__{'node configuration'}"; - } - } else { - die "$__{'No node requested'}"; - } + if ( !clientHasEdit(type=>"authprocs",name=>"$GRIDName")) { + die "$__{'Not authorized'} (edit) $GRIDType.$GRIDName.$NODEName"; + } + if ($NODEName ne "") { + my %S = readNode($NODEName); + %NODE = %{$S{$NODEName}}; + if (%NODE) { + %CLBS = readCfg("$WEBOBS{ROOT_CODE}/etc/clb.conf"); + @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); + %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); + %data = readCLB("$GRIDType.$GRIDName.$NODEName"); + } else { + die "$__{'Could not read'} $QryParm->{'node'} $__{'node configuration'}"; + } + } else { + die "$__{'No node requested'}"; + } } else { - die ("$__{'You cannot edit a NODE calibration file outside of PROC context'}"); + die ("$__{'You cannot edit a NODE calibration file outside of PROC context'}"); } - # ---- OK, passed all above checks my $titre2 = "$NODE{ALIAS}: $NODE{NAME} [$QryParm->{'node'}]"; @@ -106,7 +106,7 @@ sub sort_clb_lines { my $today = strftime('%F',@tod); my $firstyear = $WEBOBS{BIG_BANG}; if ($NODE{INSTALL_DATE} and $NODE{INSTALL_DATE} =~ /\d{4}-\d{2}-\d{2}/) { - $firstyear = substr($NODE{INSTALL_DATE},0,4); + $firstyear = substr($NODE{INSTALL_DATE},0,4); } my @yearList = ($firstyear..$todayyear); @@ -140,7 +140,7 @@ sub sort_clb_lines { my @params; foreach my $k (sort { $fieldCLB{$a}{'_SO_'} <=> $fieldCLB{$b}{'_SO_'} } keys %fieldCLB) { - push(@params, $k); + push(@params, $k); } #foreach my $k (keys %{$fieldCLB{"DATE"}}) { @@ -233,16 +233,17 @@ sub sort_clb_lines { my $c = ""; print "

@clbNote

\n"; + #djl-was: print ""; print ""; print "{'node'}\">", - "\n\n", - "", - ""; - foreach my $k ( @params ) { - if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } - print "",$fieldCLB{$k}{'Name'}.""; - } + "\n\n", + "
", + ""; +foreach my $k ( @params ) { + if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } + print "",$fieldCLB{$k}{'Name'}.""; +} print "\n"; my $i = 0; @@ -250,64 +251,64 @@ sub sort_clb_lines { my $line; foreach my $id (sort sort_clb_lines keys %data) { - $i++; - my %line = %{$data{$id}}; - print ""; - - my @date = split(/-/, $line{'DATE'}); - my @heure = split(/:/, $line{'TIME'}); - print "\n"; - print "\n"; - print ""; + + my @date = split(/-/, $line{'DATE'}); + my @heure = split(/:/, $line{'TIME'}); + print "\n"; + print "\n"; + print "\n"; - } - } + if ($line{'nv'} > $nbc) { + $nbc = $line{'nv'}; + } + my $ki = 2; + foreach my $k ( @params ) { + if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } + if (not $k ~~ ["DATE", "TIME", "nv"]) { + print "\n"; + } + } } print " \n"; my $txt = "Number of channels for the node:
    " - ."
  • increase to add channels;" - ."
  • decrease to remove all lines of channels with a greater number." - ."
"; + ."
  • increase to add channels;" + ."
  • decrease to remove all lines of channels with a greater number." + .""; print "
    • "; print "
    + $i++; + my %line = %{$data{$id}}; + print "
    "; - if ($line{'nv'} > $nbc) { - $nbc = $line{'nv'}; - } - my $ki = 2; - foreach my $k ( @params ) { - if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } - if (not $k ~~ ["DATE", "TIME", "nv"]) { - print "

    Fix number of channels = procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -69,8 +69,8 @@ =head1 Query string parameter # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = strftime('%H',@tod); @@ -155,9 +155,9 @@ =head1 Query string parameter var n = 0; var v = 0; var dd;"; - + for ('01'..'20') { - print "if (formulaire.d$_.value != \"\") { + print "if (formulaire.d$_.value != \"\") { dd = 0; v = formulaire.D0.value*1 + formulaire.d$_.value/1000; if ((formulaire.d$_.value - formulaire.d01.value) < -500) { v += 1; } @@ -213,33 +213,33 @@ =head1 Query string parameter my ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$D0,$d01,$d02,$d03,$d04,$d05,$d06,$d07,$d08,$d09,$d10,$d11,$d12,$d13,$d14,$d15,$d16,$d17,$d18,$d19,$d20,$rem,$val); $id=$date=$heure=$site=$aemd=$pAtm=$tAir=$HR=$nebul=$vitre=$D0=$d01=$d02=$d03=$d04=$d05=$d06=$d07=$d08=$d09=$d10=$d11=$d12=$d13=$d14=$d15=$d16=$d17=$d18=$d19=$d20=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$D0,$d01,$d02,$d03,$d04,$d05,$d06,$d07,$d08,$d09,$d10,$d11,$d12,$d13,$d14,$d15,$d16,$d17,$d18,$d19,$d20,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - $sel_annee = substr($date,0,4); - $sel_mois = substr($date,5,2); - $sel_jour = substr($date,8,2); - $sel_hr = substr($heure,0,2); - $sel_mn = substr($heure,3,2); - $sel_site = $site; - $sel_aemd = $aemd; - $sel_pAtm = $pAtm; - $sel_tAir = $tAir; - $sel_HR = $HR; - $sel_nebul = $nebul; - $sel_vitre = $vitre; - $sel_D0 = $D0; - for (@donneeListe) { - eval("\$sel_d$_ = \$d$_;"); - } - $sel_rem = $rem; - $sel_rem =~ s/"/"/g; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$D0,$d01,$d02,$d03,$d04,$d05,$d06,$d07,$d08,$d09,$d10,$d11,$d12,$d13,$d14,$d15,$d16,$d17,$d18,$d19,$d20,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + $sel_annee = substr($date,0,4); + $sel_mois = substr($date,5,2); + $sel_jour = substr($date,8,2); + $sel_hr = substr($heure,0,2); + $sel_mn = substr($heure,3,2); + $sel_site = $site; + $sel_aemd = $aemd; + $sel_pAtm = $pAtm; + $sel_tAir = $tAir; + $sel_HR = $HR; + $sel_nebul = $nebul; + $sel_vitre = $vitre; + $sel_D0 = $D0; + for (@donneeListe) { + eval("\$sel_d$_ = \$d$_;"); + } + $sel_rem = $rem; + $sel_rem =~ s/"/"/g; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print "\n"; # end left column - print "\n"; # end left column +print "
    @@ -249,113 +249,113 @@ =head1 Query string parameter print ""; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; print "\n"; print "\n"; +print "\n"; +print "\n"; print "\n"; -print "\n"; print "); + } + print qq(); + if (clientHasAdm(type=>"authforms",name=>"EAUX")) { + print qq(); + } + print qq(
    ); } print qq(
    "; - print "
    Date et site visé +print "
    Date et site visé

    Date: "; - print " "; - print " "; - - print "  Heure: "; - print "
    "; - print "Site:

    \n"; - print "
    "; - - print "
    Mesures et paramètres météo +for (@anneeListe) { + if ($_ == $sel_annee) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; + +print "  Heure: "; +print "
    "; +print "Site:

    \n"; +print "
    "; + +print "
    Mesures et paramètres météo

    Pression atmosphérique (en mmHg) =
    \n Température de l'air (en °C) =
    \n H.R. (en %) =
    Nébulosité sur le trajet:

    \n"; - print "
    \n"; +for (@meteo) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($cle[0] eq $sel_nebul) { $sel = "selected"; } + print "\n"; +} +print "

    \n"; +print "
    \n"; print "    		"; print "
    Mesures de distance (m)

    Type d'appareil:
    +for (@types) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($cle[0] eq $sel_aemd) { $sel = "selected"; } + print "\n"; +} +print "
    Vitre:

    "; - print "

    +for (@vitres) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($_ eq $sel_vitre) { $sel = "checked"; } + print ""; +} +print "

    "; +print "

    Distance initiale: (en m)

    \n"; - print "

    Fractions: (en mm)
    "; - for (@donneeListe) { - print "Fractions: (en mm)
    "; +for (@donneeListe) { + print ""; - } - print "

    \n"; +} +print "

    \n"; - print "

    Moyenne (m) = +print "

    Moyenne (m) = 2 × Écart-type (m) =

    \n"; - print "
    \n"; - print "
    "; +print "
    "; print "
    Observations"; - print "

    "; - print "
    +print "

    "; +print "
    Information de saisie: $val -

    "; - print "
    \n"; +

    "; +print "\n"; print "
    "; diff --git a/CODE/cgi-bin/formEAUX.pl b/CODE/cgi-bin/formEAUX.pl index 8d726cf4..cbed5779 100755 --- a/CODE/cgi-bin/formEAUX.pl +++ b/CODE/cgi-bin/formEAUX.pl @@ -56,11 +56,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -229,8 +229,6 @@ =head1 Query string parameter ]; - - # ---- read data file # my $message = "Saisie de nouvelles données"; @@ -240,42 +238,42 @@ =head1 Query string parameter my ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val); $id=$date=$heure=$site=$type=$tAir=$tSource=$pH=$debit=$cond=$niveau=$cLi=$cNa=$cK=$cMg=$cCa=$cF=$cCl=$cBr=$cNO3=$cSO4=$cHCO3=$cI=$cSiO2=$d13C=$d18O=$dD=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) >= 1) { - chomp(@ligne); - ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - ($sel_hr,$sel_mn) = split (/:/,$heure); - $sel_site = $site; - $sel_type = $type; - $sel_tAir = $tAir; - $sel_tSource = $tSource; - $sel_pH = $pH; - $sel_debit = $debit; - $sel_cond = $cond; - $sel_niveau = $niveau; - $sel_cLi = $cLi; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cF = $cF; - $sel_cCl = $cCl; - $sel_cBr = $cBr; - $sel_cNO3 = $cNO3; - $sel_cSO4 = $cSO4; - $sel_cHCO3 = $cHCO3; - $sel_cI = $cI; - $sel_cSiO2 = $cSiO2; - $sel_d13C = $d13C; - $sel_d18O = $d18O; - $sel_dD = $dD; - $sel_rem = $rem; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) >= 1) { + chomp(@ligne); + ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + ($sel_hr,$sel_mn) = split (/:/,$heure); + $sel_site = $site; + $sel_type = $type; + $sel_tAir = $tAir; + $sel_tSource = $tSource; + $sel_pH = $pH; + $sel_debit = $debit; + $sel_cond = $cond; + $sel_niveau = $niveau; + $sel_cLi = $cLi; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cF = $cF; + $sel_cCl = $cCl; + $sel_cBr = $cBr; + $sel_cNO3 = $cNO3; + $sel_cSO4 = $cSO4; + $sel_cHCO3 = $cHCO3; + $sel_cI = $cI; + $sel_cSiO2 = $cSiO2; + $sel_d13C = $d13C; + $sel_d18O = $d18O; + $sel_dD = $dD; + $sel_rem = $rem; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print qq( @@ -292,17 +290,17 @@ =head1 Query string parameter ); if ($QryParm->{id} ne "") { - print qq(); - print qq(
    ); - if ($val ne "") { - print qq(

    Information de saisie: $val + print qq(); + print qq(

    ); + if ($val ne "") { + print qq(

    Information de saisie: $val

    ); - } - print qq(); - if (clientHasAdm(type=>"authforms",name=>"EAUX")) { - print qq(); - } - print qq(
    @@ -316,73 +314,73 @@ =head1 Query string parameter ); - print qq(); - print qq( "; - - print qq(  Heure: ); - print qq(
    +for (@anneeListe) { + if ($_ == $sel_annee) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  Heure: ); +print qq(
    Site:
    +for (@NODESSelList) { + my @cle = split(/\|/,$_); + if ($cle[0] eq $sel_site) { + print qq(); + } else { + print qq(); + } +} +print qq(
    Type:

    diff --git a/CODE/cgi-bin/formEXTENSO.pl b/CODE/cgi-bin/formEXTENSO.pl index d84740fd..b0c3fd94 100755 --- a/CODE/cgi-bin/formEXTENSO.pl +++ b/CODE/cgi-bin/formEXTENSO.pl @@ -56,19 +56,19 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits defaults --------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = strftime('%H',@tod); @@ -97,31 +97,33 @@ =head1 Query string parameter my @heureListe = ('','00'..'23'); my @minuteListe= ('','00'..'59'); - # ---- Read the data file to retrieve most recent measurements # my ($lignes, $dataTS) = $FORM->data; @$lignes = reverse sort tri_date_avec_id @$lignes; + # most recent measurements from last data line in file my (@lastData) = split(/\|/, @$lignes[$#$lignes -1 ]); # -1 because of header after reverse + # last measurements for each site (stations) my @lastMeasure; my $i = 0; for my $st (keys(%Ns)) { - #djl-was: my @tmp = grep(/\|$stations[$i]\|/,@$lignes); - my @tmp = grep(/\|$st\|/,@$lignes); - my @ddd = split(/\|/,$tmp[$#tmp]); - my $moy = 0; - my $n = 0; - for (@donneeListe) { - if ($ddd[($_-1)*3+8] ne "") { - $moy += $ddd[($_-1)*3+9] + $ddd[($_-1)*3+10]; - $n++; - } - } - if ($n != 0) { $moy /= $n; } - $lastMeasure[$i] = sprintf("%1.2f mm (%s)",$ddd[7]+$ddd[8]+$moy,$ddd[1]); - $i++; + + #djl-was: my @tmp = grep(/\|$stations[$i]\|/,@$lignes); + my @tmp = grep(/\|$st\|/,@$lignes); + my @ddd = split(/\|/,$tmp[$#tmp]); + my $moy = 0; + my $n = 0; + for (@donneeListe) { + if ($ddd[($_-1)*3+8] ne "") { + $moy += $ddd[($_-1)*3+9] + $ddd[($_-1)*3+10]; + $n++; + } + } + if ($n != 0) { $moy /= $n; } + $lastMeasure[$i] = sprintf("%1.2f mm (%s)",$ddd[7]+$ddd[8]+$moy,$ddd[1]); + $i++; } # ---- init some other defaults --------------------------- @@ -129,53 +131,54 @@ =head1 Query string parameter my $sel_offset = $lastData[8]; my @sel_oper = $USERS{$CLIENT}{UID}; my $sel_site = my $sel_temp = my $sel_ruban = ""; -my @sel_d = my @sel_v ="" ; +my @sel_d = my @sel_v ="" ; my $sel_rem = my $sel = ""; my ($id,$date,$heure,$site,$ope,$temp,$meteo,$ruban,$offset,$rem,$val); - $id=$date=$heure=$site=$ope=$temp=$meteo=$ruban=$offset=$rem=$val = ""; +$id=$date=$heure=$site=$ope=$temp=$meteo=$ruban=$offset=$rem=$val = ""; my @d; # ---- date and staff (oper) in querystring may override defaults (resp. today & client) if ( defined($QryParm->{date}) && length($QryParm->{date}) == 10 ) { - $sel_annee = substr($QryParm->{date},0,4); - $sel_mois = substr($QryParm->{date},5,2); - $sel_jour = substr($QryParm->{date},8,2); + $sel_annee = substr($QryParm->{date},0,4); + $sel_mois = substr($QryParm->{date},5,2); + $sel_jour = substr($QryParm->{date},8,2); } if (defined($QryParm->{oper})) { - @sel_oper = split(/\ /,$QryParm->{oper}); # note: GET replaces '+' with a space + @sel_oper = split(/\ /,$QryParm->{oper}); # note: GET replaces '+' with a space } # ---- if an id is passed in querystring, override defaults with data file for this id if (defined($QryParm->{id})) { - my @ligneId = grep(/^$QryParm->{id}\|/,@$lignes); - if (@ligneId ne "") { - ($id,$date,$heure,$site,$ope,$temp,$meteo,$ruban,$offset,$d[0][0],$d[0][1],$d[0][2],$d[1][0],$d[1][1],$d[1][2],$d[2][0],$d[2][1],$d[2][2],$d[3][0],$d[3][1],$d[3][2],$d[4][0],$d[4][1],$d[4][2],$d[5][0],$d[5][1],$d[5][2],$d[6][0],$d[6][1],$d[6][2],$d[7][0],$d[7][1],$d[7][2],$d[8][0],$d[8][1],$d[8][2],$rem,$val) = split (/\|/,$ligneId[0]); - $sel_annee = substr($date,0,4); - $sel_mois = substr($date,5,2); - $sel_jour = substr($date,8,2); - $sel_hr = substr($heure,0,2); - $sel_mn = substr($heure,3,2); - $sel_site = $site; - $sel_meteo = lc($meteo); - $sel_temp = $temp; - $sel_ruban = $ruban; - $sel_offset= $offset; - @sel_oper = split(/\+/,$ope); - # each of the 9 measurements in file is a 3-tuple (fenetre,cadran,vent). - # for input (& matching new equipments) we show/accept the 2-tuple (fenetre,cadran) - # as a single input field (representing fenetre+cadran). - # following loop builds input fields from these 3-tuples, - # ATT: null 2-tuple ARE null input (not zero) - for ($i = 0; $i<9; $i++) { - if (!($d[$i][0] eq "" && $d[$i][1] eq "")) { - $sel_d[$i] = $d[$i][0] + $d[$i][1]; - $sel_d[$i] =~ tr/,/./; - } else { $sel_d[$i] = "" } - $sel_v[$i] = $d[$i][2]; - } - $sel_rem = l2u($rem); - chomp($val); - } + my @ligneId = grep(/^$QryParm->{id}\|/,@$lignes); + if (@ligneId ne "") { + ($id,$date,$heure,$site,$ope,$temp,$meteo,$ruban,$offset,$d[0][0],$d[0][1],$d[0][2],$d[1][0],$d[1][1],$d[1][2],$d[2][0],$d[2][1],$d[2][2],$d[3][0],$d[3][1],$d[3][2],$d[4][0],$d[4][1],$d[4][2],$d[5][0],$d[5][1],$d[5][2],$d[6][0],$d[6][1],$d[6][2],$d[7][0],$d[7][1],$d[7][2],$d[8][0],$d[8][1],$d[8][2],$rem,$val) = split (/\|/,$ligneId[0]); + $sel_annee = substr($date,0,4); + $sel_mois = substr($date,5,2); + $sel_jour = substr($date,8,2); + $sel_hr = substr($heure,0,2); + $sel_mn = substr($heure,3,2); + $sel_site = $site; + $sel_meteo = lc($meteo); + $sel_temp = $temp; + $sel_ruban = $ruban; + $sel_offset= $offset; + @sel_oper = split(/\+/,$ope); + +# each of the 9 measurements in file is a 3-tuple (fenetre,cadran,vent). +# for input (& matching new equipments) we show/accept the 2-tuple (fenetre,cadran) +# as a single input field (representing fenetre+cadran). +# following loop builds input fields from these 3-tuples, +# ATT: null 2-tuple ARE null input (not zero) + for ($i = 0; $i<9; $i++) { + if (!($d[$i][0] eq "" && $d[$i][1] eq "")) { + $sel_d[$i] = $d[$i][0] + $d[$i][1]; + $sel_d[$i] =~ tr/,/./; + } else { $sel_d[$i] = "" } + $sel_v[$i] = $d[$i][2]; + } + $sel_rem = l2u($rem); + chomp($val); + } } # ---- Begin HTML display @@ -205,8 +208,8 @@ =head1 Query string parameter \n"; - -print "

    ".$FORM->conf('TITLE')."

    \n

    $titre2

    "; + +print "

    ".$FORM->conf('TITLE')."

    \n

    $titre2

    "; print " "; - print "  "; - print "  "; - print "  "; - print "  
    "; - print ""; - } - print "
    "; - # --- INSPIRE THEME - print ""; - print "
    "; - # --- TOPIC CATEGORIES - print ""; - #print ""; - print "
    "; - # --- Lineage - print ""; - print "  
    "; - print ""; - print ""; - - print "    		"; # right column - - # --- 'node' position (latitude, longitude & altitude) - print "
    $__{'Geographic location'}"; - print ""; - print ""; - print ""; - print < "auth".lc($GRIDType)."s", name => "*")) { +# print "

    $__{'Edit the node-features-nodes associations list'}

    "; +#} +print ""; + +# --- Grids +print "
    $__{'Associated Grids'}\n"; + +# --- (additional) GRIDS: VIEWs and PROCs +# --- list only PROCs and VIEWs that client has AUTHEDIT to ... +my @GL; + +# ... all views and procs +#FB-was: my @Lprocs = map("PROC.".basename($_), qx(ls -d $WEBOBS{PATH_PROCS}/*)); chomp(@Lprocs); +#FB-was: my @Lviews = map("VIEW.".basename($_), qx(ls -d $WEBOBS{PATH_VIEWS}/*)); chomp(@Lviews); +my @Lprocs = map("PROC.".basename($_), qx(find $WEBOBS{PATH_PROCS}/* -type d)); chomp(@Lprocs); +my @Lviews = map("VIEW.".basename($_), qx(find $WEBOBS{PATH_VIEWS}/* -type d)); chomp(@Lviews); + +# ... set client-and-its-groups where clause element, then query DB +my $cid = "$USERS{$CLIENT}{UID}"; +my $wc = " uid in (SELECT GID from $WEBOBS{SQL_TABLE_GROUPS} WHERE UID=\"$cid\") OR uid = \"$cid\" "; +my @Aprocs = qx(sqlite3 -separator '.' $WEBOBS{SQL_DB_USERS} 'select "PROC",resource from $WEBOBS{SQL_TABLE_AUTHPROCS} where auth >= 2 and $wc'); +my @Aviews = qx(sqlite3 -separator '.' $WEBOBS{SQL_DB_USERS} 'select "VIEW",resource from $WEBOBS{SQL_TABLE_AUTHVIEWS} where auth >= 2 and $wc'); +chomp(@Aviews); chomp(@Aprocs); + +# ... merge client-allowed-to VIEWS and PROCS into @GL +if ( ('VIEW.*') ~~ @Aviews ) { @GL = @Lviews } +else { map { push(@GL,$_) if (($_) ~~ @Aviews) } @Lviews } +if ( ('PROC.*') ~~ @Aprocs ) { @GL = (@GL,@Lprocs) } +else { map { push(@GL,$_) if (($_) ~~ @Aprocs) } @Lprocs } +print "
    "; - print "
    "; - print "    		"; - print " 
    "; - print ""; - print "° "; - print "' "; - print "\" "; - print "
    \n"; - print ""; - print "° "; - print "' "; - print "\" "; - print "
    \n"; - print ""; - print "
    \n"; - # --- positioning date - print " "; - print " "; - print "
    "; - # --- Positioning type (unknown, map, GPS or auto) - print " " - ."
    "; - print "
    " - ." " - ."
    "; - - # --- Importation of shpfile - # --- First we check if a geojson already exists in the NODE dir +print "    		"; # left column - if (-e $geojsonFile) { - open(FH, '<', $geojsonFile); - while(){ - $json = "$_"; - } - close(FH); - } +print "
    $__{'Name and Description'}"; + +# --- Codes, Name, Alias, Type +print "$GRIDType.$GRIDName."; +if ($newnode) { + print ""; + print ""; + print ""; +} else { + print "
    "; + print ""; + print ""; +} +print ""; +print "{'node'}\">"; +print "{'node'}\">"; +print "
    "; - print ""; - print ""; - print ""; - print " " - ."
    "; +# --- Nom complet/TITLE +print ""; +print "
    "; + +# --- ALIAS +print ""; +print "  
    "; + +# --- TYPE +print ""; +print "  
    "; +print "
    "; + +print "
    $__{'Lifetime and Events Time Zone'}"; + +# --- Dates debut et fin +print ""; +print ""; +print ""; +print ""; +print ""; +print ""; +print "
    "; +print "
    "; +print "$__{'Start date'}: "; +print " "; +print "
    "; +print "$__{'End date'}: "; +print " "; +print " "; +print "
    		"; + +# --- ALIAS +print ""; +print ""; +print "
    \n"; +print "
    "; + +# --- Features +print "
    $__{'Features'}"; +print "" + ." 

    "; +for (@feat) { + print ""; + my $pat = qr/^$NODEName\|$_\|/; + my @fnlist = grep(/$pat/,@n2n); + my $fn = join(',',@fnlist); + $fn =~ s/$NODEName\|$_\|//g; + print "
    "; +} - print "
    "; +print ""; +print ""; +print ""; +print ""; +print "
    "; +print ""; +print ">\" style=\"width:100px\" onClick=\"SelectMoveRows(document.form.INs,document.form.SELs)\">
    "; +print "
    "; +print ""; +print "    		"; +print "
    "; +print "
    "; + +# --- Procs metadata +print "
    $__{'Procs Metadata'}"; + +# --- DESCRIPTION +print ""; +print "  
    "; + +# --- show THEIA fields ? +print "
     

    "; +print "
    "; + +# --- PRODUCER +print ""; +print "  
    "; + +# --- CREATOR +print ""; +print ""; +print ""; +print ""; +print "

    "; +print "
    "; +print "  "; +print "  "; +print "  "; +print "  
    "; +print "
    "; +for (my $i = 1; $i <= $#usrRole; $i++) { + my $cnt = $i+1; + print "
    "; + print ""; + print "  "; + print "  "; + print "  "; + print "  
    "; + print "
    "; +} +print "

    "; + +# --- INSPIRE THEME +print ""; +print "
    "; + +# --- TOPIC CATEGORIES +print ""; + +#print ""; +print "
    "; + +# --- Lineage +print ""; +print "  
    "; +print "
    "; +print "
    "; + +print "    		"; # right column + +# --- 'node' position (latitude, longitude & altitude) +print "
    $__{'Geographic location'}"; +print ""; +print ""; +print ""; +print < const checked = document.getElementById("theiaChecked"); const auth = $theiaAuth; @@ -1226,172 +1256,183 @@ =head1 Query string parameters } FIN - print "
    "; +print "
    "; +print "    		"; +print " 
    "; +print ""; +print "° "; +print "' "; +print "\" "; +print "
    \n"; +print ""; +print "° "; +print "' "; +print "\" "; +print "
    \n"; +print ""; +print "
    \n"; + +# --- positioning date +print " "; +print " "; +print "
    "; + +# --- Positioning type (unknown, map, GPS or auto) +print " " + ."
    "; +print "
    " + ." " + ."
    "; + +# --- Importation of shpfile +# --- First we check if a geojson already exists in the NODE dir + +if (-e $geojsonFile) { + open(FH, '<', $geojsonFile); + while(){ + $json = "$_"; + } + close(FH); +} + +print ""; +print ""; +print ""; +print " " + ."
    "; + +print "
    "; - print "
    \n"; - - # --- GNSS-specific information - - my $m3g_url_edit = $WEBOBS{'M3G_URL'}."/".$usrGnss9char; - print "
    $__{'GNSS-specific information'}"; - print ""; - print ""; - print "
    "; - print ""; - print ""; - print "";# NB: use save button to store this code the first time, before updating metadata "; - print "
    \n"; - print "
    \n"; - ###### get and edit features - #### Edit GeodesyML on M3G - print "Edit sitelog on M3G (requires prior M3G login)"; - print "
    \n"; - #### get geodesyML from M3G - #print "
    \n"; - print "
    \n"; - - print ""; - if ( $m3g_check ) { - print ""; - } else { - print ""; - } - print "
    \n"; - - print "
    "; - print "
    "; - - # --- Transmission - print "
    $__{'Transmission'}"; - print ""; - print ""; - print ""; - print "
    "; - print ""; - print "\n"; - print ""; - # Transmission path (acquisition + repeater list) - print "
    "; - print "
    "; - print "
    "; - print "
    "; - - # --- Procs parameters - if (uc($GRIDType) eq "PROC") { - print "
    $__{'Procs Parameters'}"; - print "\n"; - # --- CHANNEL_LIST - print "\n"; - # --- DATA (FID) - print "\n
    "; - print ""; - print "$GRID{NAME} (".(defined($GRID{NODESLIST}) ? scalar(@{$GRID{NODESLIST}}):"0")." nodes)

    \n"; - # --- RAWFORMAT list - print "
    \n"; - # --- RAWDATA - print "
    "; - # --- FDSN Network Code - print ""; - print "
    \n"; - print "    		"; - print ""; - my %carCLB = readCfg("$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"); - if (%carCLB) { - my @select = split(/,/,$usrCHAN); - # make a list of available channels and label them with last Chan. + Loc. codes - my %chan; - foreach my $k (keys %carCLB) { - $chan{$k} = "$carCLB{$k}{'nm'} ($carCLB{$k}{'cd'} $carCLB{$k}{'lc'})"; - } - print ""; - } else { - print "no calibration file."; - } - print "
    "; - print ""; - print "
    \n"; - # --- DATA (FID_x) - # first displays any user defined FID_x (that are NOT in the rawformats list) - my @usrFIDshort = map {$_ =~ s/^$GRIDType\.$GRIDName\.//g; $_} @usrFID; - for (sort @usrFID) { - my $short = $_; - $short =~ s/^$GRIDType\.$GRIDName\.//g; - if (!grep(/^$short$/,@fmtfid)) { - my $long = "$GRIDType.$GRIDName.$short"; - print "
    \n"; - } - } - # second adds all possible FID_x: visible for active RAWFORMAT, hidden for others - print "
    \n"; - for (keys(%rawFormats)) { - my $key = $_; - for (split(/,/,$rawFormats{$key}{FID})) { - my $fid = "FID_$_"; - my $long = "$GRIDType.$GRIDName.$fid"; - my $disp = ($key eq $usrRAWFORMAT ? "block":"none"); - print "

    \n"; - } - } - print "
    		"; - print "
    "; - print "
    "; - print "
    "; - print "

    \n"; - } - # --- Propagates any other Proc's parameters (hidden) - # PROC.*.* = other proc's parameters - # ^* = list of selected parameters formerly associated with all proc): they have been used at the begining of this script - # to fill the default values in form, but will be also propagated to all other associated procs (see postNODE.pl) - for (keys(%NODE)) { - if ( !($_ =~ /^$GRIDType\.$GRIDName\./) - && $_ =~ /^VIEW\.|^PROC\.|^FDSN_NETWORK_CODE$|^UTC_DATA$|^ACQ_RATE$|^RAWFORMAT$|^RAWDATA$|^CHANNEL_LIST$|^FID/ ) { - print ""; - } - } +print "
    "; +print "\n"; + +# --- GNSS-specific information + +my $m3g_url_edit = $WEBOBS{'M3G_URL'}."/".$usrGnss9char; +print "

    $__{'GNSS-specific information'}"; +print ""; +print ""; +print "
    "; +print ""; +print ""; +print "";# NB: use save button to store this code the first time, before updating metadata "; +print "
    \n"; +print "
    \n"; +###### get and edit features +#### Edit GeodesyML on M3G +print "Edit sitelog on M3G (requires prior M3G login)"; +print "
    \n"; +#### get geodesyML from M3G +#print "
    \n"; +print "
    \n"; + +print ""; +if ( $m3g_check ) { + print ""; +} else { + print ""; +} +print "
    \n"; + +print "
    "; +print "
    "; + +# --- Transmission +print "
    $__{'Transmission'}"; +print ""; +print ""; +print ""; +print "
    "; +print ""; +print "\n"; +print ""; + +# Transmission path (acquisition + repeater list) +print "
    "; +print "
    "; +print "
    "; +print "
    "; + +# --- Procs parameters +if (uc($GRIDType) eq "PROC") { + print "
    $__{'Procs Parameters'}"; + print "\n"; + + # --- CHANNEL_LIST + print "\n"; + + # --- DATA (FID) + print "\n
    "; + print ""; + print "$GRID{NAME} (".(defined($GRID{NODESLIST}) ? scalar(@{$GRID{NODESLIST}}):"0")." nodes)

    \n"; + + # --- RAWFORMAT list + print "
    \n"; - ## # --- "Validity" - ## if ( clientHasAdm(type=>"authmisc",name=>"NODES")) { - ## print "

    " - ## ."$__{'Valid Node'}

    \n"; - ## } else { - ## print ""; - ## } + # --- RAWDATA + print "
    "; + + # --- FDSN Network Code + print ""; + print "
    \n"; + print "    		"; + print ""; + my %carCLB = readCfg("$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"); + if (%carCLB) { + my @select = split(/,/,$usrCHAN); + + # make a list of available channels and label them with last Chan. + Loc. codes + my %chan; + foreach my $k (keys %carCLB) { + $chan{$k} = "$carCLB{$k}{'nm'} ($carCLB{$k}{'cd'} $carCLB{$k}{'lc'})"; + } + print ""; + } else { + print "no calibration file."; + } + print "
    "; + print ""; + print "
    \n"; + + # --- DATA (FID_x) + # first displays any user defined FID_x (that are NOT in the rawformats list) + my @usrFIDshort = map {$_ =~ s/^$GRIDType\.$GRIDName\.//g; $_} @usrFID; + for (sort @usrFID) { + my $short = $_; + $short =~ s/^$GRIDType\.$GRIDName\.//g; + if (!grep(/^$short$/,@fmtfid)) { + my $long = "$GRIDType.$GRIDName.$short"; + print "
    \n"; + } + } + +# second adds all possible FID_x: visible for active RAWFORMAT, hidden for others + print "
    \n"; + for (keys(%rawFormats)) { + my $key = $_; + for (split(/,/,$rawFormats{$key}{FID})) { + my $fid = "FID_$_"; + my $long = "$GRIDType.$GRIDName.$fid"; + my $disp = ($key eq $usrRAWFORMAT ? "block":"none"); + print "

    \n"; + } + } + print "
    		"; + print "
    "; + print "
    "; + print "
    "; + print "

    \n"; +} + +# --- Propagates any other Proc's parameters (hidden) +# PROC.*.* = other proc's parameters +# ^* = list of selected parameters formerly associated with all proc): they have been used at the begining of this script +# to fill the default values in form, but will be also propagated to all other associated procs (see postNODE.pl) +for (keys(%NODE)) { + if ( !($_ =~ /^$GRIDType\.$GRIDName\./) + && $_ =~ /^VIEW\.|^PROC\.|^FDSN_NETWORK_CODE$|^UTC_DATA$|^ACQ_RATE$|^RAWFORMAT$|^RAWDATA$|^CHANNEL_LIST$|^FID/ ) { + print ""; + } +} + +## # --- "Validity" +## if ( clientHasAdm(type=>"authmisc",name=>"NODES")) { +## print "

    " +## ."$__{'Valid Node'}

    \n"; +## } else { +## print ""; +## } print "
    "; + # --- buttons zone if ($newnode==2) { - print "

    $__{'Copy'}: "; - print "$__{'Features content'} "; - print "$__{'Calibration file'} "; - print "$__{'Photos & documents'} "; + print "

    $__{'Copy'}: "; + print "$__{'Features content'} "; + print "$__{'Calibration file'} "; + print "$__{'Photos & documents'} "; } print "

    "; print ""; diff --git a/CODE/cgi-bin/formNOVAC.pl b/CODE/cgi-bin/formNOVAC.pl index afd0f7a0..22306ed3 100755 --- a/CODE/cgi-bin/formNOVAC.pl +++ b/CODE/cgi-bin/formNOVAC.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formNOVAC.pl @@ -57,11 +58,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Edit - ".$FORM->conf('TITLE'); @@ -71,8 +72,8 @@ =head1 Query string parameter # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $today = strftime('%F',@tod); @@ -87,6 +88,7 @@ =head1 Query string parameter # loads the source of a value (user defined, calculated, etc.) my @sources = readCfgFile($FORM->path."/".$FORM->conf('SOURCES')); + # loads the pre-selected cone angles (60 degrees, 90 degrees, etc.) my @coneangles = readCfgFile($FORM->path."/".$FORM->conf('CONEANGLES')); @@ -182,6 +184,7 @@ =head1 Query string parameter \n \n \n"; + # ------------------------------------------------------------ # ---- end of specific NOVAC javascript form validation ------ # ------------------------------------------------------------ @@ -208,44 +211,46 @@ =head1 Query string parameter my @ligne; my $ptr=''; my $fts-1; + # ------------------------------------------------------------ # ---- start of specific NOVAC form code --------------------- # ------------------------------------------------------------ my ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split(/\|/,$_); if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - $sel_site = $site; - $sel_flux1 = $flux1; - $sel_flux2 = $flux2; - $sel_windSpeed = $windSpeed; - $sel_windSpeedSource = $windSpeedSource; - $sel_windDirection = $windDirection; - $sel_windDirectionSource = $windDirectionSource; - $sel_compassDirection = $compassDirection; - $sel_coneAngle = $coneAngle; - $sel_tilt = $tilt; - $sel_plumeHeight = $plumeHeight; - $sel_plumeHeightSource = $plumeHeightSource; - $sel_offset = $offset; - $sel_plumeCentre = $plumeCentre; - $sel_plumeEdge1 = $plumeEdge1; - $sel_plumeEdge2 = $plumeEdge2; - $sel_plumeCompleteness = $plumeCompleteness; - $sel_geomError = $geomError; - $sel_spectrometerError = $spectrometerError; - $sel_scatteringError = $scatteringError; - $sel_windError = $windError; - $sel_nbValidScans = $nbValidScans; - $message = "Changing entry $QryParm->{id}"; + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + $sel_site = $site; + $sel_flux1 = $flux1; + $sel_flux2 = $flux2; + $sel_windSpeed = $windSpeed; + $sel_windSpeedSource = $windSpeedSource; + $sel_windDirection = $windDirection; + $sel_windDirectionSource = $windDirectionSource; + $sel_compassDirection = $compassDirection; + $sel_coneAngle = $coneAngle; + $sel_tilt = $tilt; + $sel_plumeHeight = $plumeHeight; + $sel_plumeHeightSource = $plumeHeightSource; + $sel_offset = $offset; + $sel_plumeCentre = $plumeCentre; + $sel_plumeEdge1 = $plumeEdge1; + $sel_plumeEdge2 = $plumeEdge2; + $sel_plumeCompleteness = $plumeCompleteness; + $sel_geomError = $geomError; + $sel_spectrometerError = $spectrometerError; + $sel_scatteringError = $scatteringError; + $sel_windError = $windError; + $sel_nbValidScans = $nbValidScans; + $message = "Changing entry $QryParm->{id}"; + } else { $QryParm->{id} = ""; } } else { $QryParm->{id} = ""; } - } else { $QryParm->{id} = ""; } } + # ------------------------------------------------------------ # ---- end of specific NOVAC form code ----------------------- # ------------------------------------------------------------ @@ -261,7 +266,7 @@ =head1 Query string parameter

    \n "; if ($QryParm->{id} ne "") { - print "\n + print "\n {id}\"/>"; } print "\n @@ -275,37 +280,37 @@ =head1 Query string parameter Date: \n \n \n
    \n @@ -314,15 +319,16 @@ =head1 Query string parameter "; for (@sources) { - my @cle = split(/\|/,$_); - print "\n + my @cle = split(/\|/,$_); + print "\n $cle[1]"; + if ($cle[0] eq $sel_windSpeedSource) { + print " selected"; + } + print " value=$cle[0]>$cle[1]"; } print "\n
    \n @@ -363,13 +369,13 @@ =head1 Query string parameter Wind direction source: \n
    \n @@ -385,13 +391,13 @@ =head1 Query string parameter Cone angle: \n deg
    \n @@ -410,13 +416,13 @@ =head1 Query string parameter Plume height source: \n
    \n @@ -468,6 +474,7 @@ =head1 Query string parameter \n \n \n"; + # ------------------------------------------------------------ # ---- end of specific NOVAC HTML form code ------------------ # ------------------------------------------------------------ diff --git a/CODE/cgi-bin/formPLUVIO.pl b/CODE/cgi-bin/formPLUVIO.pl index 3e19ac7b..9e5913ea 100755 --- a/CODE/cgi-bin/formPLUVIO.pl +++ b/CODE/cgi-bin/formPLUVIO.pl @@ -57,11 +57,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -124,7 +124,7 @@ =head1 Query string parameter {"; for ("01".."31") { - print "if (formulaire.d$_.value == \"\" && formulaire.d$_.disabled == false) { formulaire.d$_.value = 0; }\n"; + print "if (formulaire.d$_.value == \"\" && formulaire.d$_.disabled == false) { formulaire.d$_.value = 0; }\n"; } print "} @@ -236,22 +236,22 @@ =head1 Query string parameter my ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val); $id=$aa=$mm=$site=$d01=$v01=$d02=$v02=$d03=$v03=$d04=$v04=$d05=$v05=$d06=$v06=$d07=$v07=$d08=$v08=$d09=$v09=$d10=$v10=$d11=$v11=$d12=$v12=$d13=$v13=$d14=$v14=$d15=$v15=$d16=$v16=$d17=$v17=$d18=$v18=$d19=$v19=$d20=$v20=$d21=$v21=$d22=$v22=$d23=$v23=$d24=$v24=$d25=$v25=$d26=$v26=$d27=$v27=$d28=$v28=$d29=$v29=$d30=$v30=$d31=$v31=$val; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - $sel_annee = $aa; - $sel_mois = $mm; - $sel_site = $site; - for (@jourListe) { - eval("\$sel_d$_ = \$d$_;"); - eval("\$sel_v$_ = \$v$_;"); - } - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = ""; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + $sel_annee = $aa; + $sel_mois = $mm; + $sel_site = $site; + for (@jourListe) { + eval("\$sel_d$_ = \$d$_;"); + eval("\$sel_v$_ = \$v$_;"); + } + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = ""; } + } else { $QryParm->{id} = ""; $val = "" ;} } print "\n"; print "\n"; +print "
    @@ -261,7 +261,7 @@ =head1 Query string parameter print "
    "; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; @@ -271,59 +271,59 @@ =head1 Query string parameter
    Mois et Site

    Année: "; - print " Mois: \n"; - print "   +for (@anneeListe) { + $sel = ""; + if ($_ == $sel_annee) { $sel = "selected"; } + print "\n"; +} +print ""; +print " Mois: \n"; +print "   Site: "; - print "

    "; +for (@NODESSelList) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($cle[0] eq $sel_site) { $sel = "selected"; } + print "\n"; +} +print ""; +print ""; print "
    Pluviométrie journalière (mm)\n"; - print ""; - print ""; - print ""; +print "\n"; - print " + print " 
    "; + if (($_ eq "10") || ($_ eq "20")) { print "\n"; +print "\n"; - print "\n"; - print "
    "; - for (@jourListe) { - print "$_. "; +print "
    "; +for (@jourListe) { + print "$_. "; - print " 
    "; - if (($_ eq "10") || ($_ eq "20")) { print "    		"; } - } - print "
    Cumul 1ère décade "; } +} +print "
    Cumul 1ère décade Cumul 2ème décade Cumul 3ème décade
    Cumul mensuel (mm) =

    "; - print "
    "; +print "
    Cumul mensuel (mm) =

    "; +print ""; print "

    Information de saisie: $val diff --git a/CODE/cgi-bin/formRAINWATER.pl b/CODE/cgi-bin/formRAINWATER.pl index ad0f88b5..3aaf178d 100755 --- a/CODE/cgi-bin/formRAINWATER.pl +++ b/CODE/cgi-bin/formRAINWATER.pl @@ -56,11 +56,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -71,9 +71,9 @@ =head1 Query string parameter @$lines = reverse sort tri_date_avec_id @$lines; my %lastData; for my $id (keys(%Ns)) { - my @tmp = grep(/\|$id\|/,@$lines); - chomp(@tmp); - $lastData{$id} = $tmp[$#tmp]; + my @tmp = grep(/\|$id\|/,@$lines); + chomp(@tmp); + $lastData{$id} = $tmp[$#tmp]; } # --- DateTime inits ------------------------------------- @@ -273,8 +273,6 @@ =head1 Query string parameter ]; - - # ---- read data file # my $message = $__{'Enter a new data'}; @@ -284,34 +282,34 @@ =head1 Query string parameter my ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val); $id=$date2=$time2=$site=$date1=$time1=$volume=$diameter=$pH=$cond=$cNa=$cK=$cMg=$cCa=$cHCO3=$cCl=$cSO4=$dD=$d18O=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @line = @$ptr; - if (scalar(@line) >= 1) { - chomp(@line); - ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,l2u($line[0])); - if ($QryParm->{id} eq $id) { - ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); - ($sel_hr1,$sel_mn1) = split (/:/,$time1); - ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); - ($sel_hr2,$sel_mn2) = split (/:/,$time2); - $sel_site = $site; - $sel_volume = $volume; - $sel_diameter = $diameter; - $sel_pH = $pH; - $sel_cond = $cond; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cHCO3 = $cHCO3; - $sel_cCl = $cCl; - $sel_cSO4 = $cSO4; - $sel_dD = $dD; - $sel_d18O = $d18O; - $sel_rem = $rem; - $message = $__{"Edit existing data n° $QryParm->{id}"}; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @line = @$ptr; + if (scalar(@line) >= 1) { + chomp(@line); + ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,l2u($line[0])); + if ($QryParm->{id} eq $id) { + ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); + ($sel_hr1,$sel_mn1) = split (/:/,$time1); + ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); + ($sel_hr2,$sel_mn2) = split (/:/,$time2); + $sel_site = $site; + $sel_volume = $volume; + $sel_diameter = $diameter; + $sel_pH = $pH; + $sel_cond = $cond; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cHCO3 = $cHCO3; + $sel_cCl = $cCl; + $sel_cSO4 = $cSO4; + $sel_dD = $dD; + $sel_d18O = $d18O; + $sel_rem = $rem; + $message = $__{"Edit existing data n° $QryParm->{id}"}; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print qq( @@ -328,17 +326,17 @@ =head1 Query string parameter ); if ($QryParm->{id} ne "") { - print qq(); - print qq(

    ); - if ($val ne "") { - print qq(

    $__{'Input Information'}: $val + print qq(); + print qq(

    ); + if ($val ne "") { + print qq(

    $__{'Input Information'}: $val

    ); - } - print qq(); - if (clientHasAdm(type=>"authforms",name=>"RAINWATER")) { - print qq(); - } - print qq(
    @@ -351,114 +349,114 @@ =head1 Query string parameter $__{'Site'}:
    +print qq() if ($QryParm->{id} eq ""); + +for (@NODESSelList) { + my @cle = split(/\|/,$_); + if ($cle[0] eq $sel_site) { + print qq(); + } elsif ($QryParm->{id} eq "") { + print qq(); + } +} +print qq(
    $__{'Start Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(
    +for (@yearList) { + if ($_ == $sel_y1) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(
    $__{'End Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(

    diff --git a/CODE/cgi-bin/formREQ.pl b/CODE/cgi-bin/formREQ.pl index aaf1d1e3..1b27474e 100755 --- a/CODE/cgi-bin/formREQ.pl +++ b/CODE/cgi-bin/formREQ.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formREQ.pl @@ -135,9 +136,9 @@ =head1 DATE SPAN AND PARAMETERS map (push(@procavailable,basename($_,".conf")), qx(grep -l '^SUBMIT_COMMAND|.*' $WEBOBS{PATH_PROCS}/*/*.conf )); chomp(@procavailable); if (scalar(@procavailable)>0) { - foreach (@procavailable) { - push(@proclist,$_) if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$_")); - } + foreach (@procavailable) { + push(@proclist,$_) if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$_")); + } } else { die "$__{'No PROCS eligible for requests submission.'}" } if (scalar(@proclist)==0) { die "$__{'No PROC eligible for this user. Please ask an administrator.'}" } @@ -146,7 +147,7 @@ =head1 DATE SPAN AND PARAMETERS my @REQEXCL; my $reqexcl = "$WEBOBS{ROOT_CODE}/etc/request-excluded-keylist"; if (-e $reqexcl ) { - @REQEXCL = readFile($reqexcl); + @REQEXCL = readFile($reqexcl); } # ---- read in default values for initializing @@ -154,7 +155,7 @@ =head1 DATE SPAN AND PARAMETERS my %REQDFLT; my $reqdflt = "$WEBOBS{ROOT_CODE}/tplates/request-template"; if (-e $reqdflt ) { - %REQDFLT = readCfg($reqdflt); + %REQDFLT = readCfg($reqdflt); } # ---- retrieve the last requests for current user @@ -163,13 +164,13 @@ =head1 DATE SPAN AND PARAMETERS map (push(@reqlist,$_), qx(find $WEBOBS{ROOT_OUTR} -type d -mindepth 1 -maxdepth 1 -name "*_$CLIENT")); chomp(@reqlist); for (@reqlist) { - my $date1 = qx(grep "^DATE1|" $_/REQUEST.rc | sed -e "s/DATE1|//"); - my $date2 = qx(grep "^DATE2|" $_/REQUEST.rc | sed -e "s/DATE2|//"); - chomp($date1); - chomp($date2); - my $date12 = $date1."_".$date2; - $date12 =~ s/[-: ]//g; - $reqdates{$date12} = "$date1 to $date2"; + my $date1 = qx(grep "^DATE1|" $_/REQUEST.rc | sed -e "s/DATE1|//"); + my $date2 = qx(grep "^DATE2|" $_/REQUEST.rc | sed -e "s/DATE2|//"); + chomp($date1); + chomp($date2); + my $date12 = $date1."_".$date2; + $date12 =~ s/[-: ]//g; + $reqdates{$date12} = "$date1 to $date2"; } # ---- passed all checkings above ... @@ -297,136 +298,150 @@ =head1 DATE SPAN AND PARAMETERS print ""; print ""; - print "\n"; # end left column - - print "\n"; # end right column +print "\n"; # end left column + +print "\n"; # end right column print "
    "; # left column - - # ---- Display list of PROCS that are eligible for requests - print "
    $__{'Available PROCS'}"; - print "
    "; - for my $p (@proclist) { - %P = readProc($p,'novsub','escape'); # reads the proc conf without modifying content (no variable substitution, keep escaped char) - my $nn = scalar(@{$P{$p}{NODESLIST}}); - print " {$p}: $P{$p}{NAME} ($nn node".($nn>1?"s":"").")
    \n"; - print pkeys($p,\%P); - } - print "
    "; - print "
    		"; # right column - - print "
    $__{'Date and time span (UT)'}"; - # DATE1| DATE2| - print ""; - print ""; - print ""; - print ""; - print ""; - print ""; - print "
    "; - print "
    "; - print "$__{'Start date'}: "; - print " "; - print " "; - print "    "; - print "
    "; - print "$__{'End date'}: "; - print " "; - print " "; - print "    "; - print " "; - print "
    		$__{'Preset dates'}
    \n"; - print "
    "; - - my %datestr = readCfg("$WEBOBS{ROOT_CODE}/etc/dateformats.conf"); - my @ppis = split(',',$WEBOBS{REQ_PPI_LIST} //= '75,100,150,300,600'); - my @marks = split(',',$WEBOBS{REQ_MARKERSIZE_LIST} //= '1,2,4,6,10,15,20'); - my @linew = split(',',$WEBOBS{REQ_LINEWIDTH_LIST} //= '0.1,0.25,0.5,1,1.5,2,3'); - - print "
    $__{'Output parameters'}"; - print ""; - print ""; - print ""; - - print ""; - print "
    "; - # TZ| - print ""; - print "
     
    "; - # DATESTR| - print ""; - print "
     
    "; - # CUMULATE| - print ""; - print " $__{'days'}
     
    "; - # DECIMATE| - print ""; - print "1/
     
    "; - # MARKERSIZE| - print ""; - print "
     
    "; - # LINEWIDTH| - print ""; - print "
     
    "; - # PLOTGRID| - print ""; - print "
     
    "; - print "    		"; - # PPI| - print ""; - print "
     
    "; - # PDFOUTPUT| - print ""; - print "
     
    "; - # SVGOUTPUT| - print ""; - print "
     
    "; - # EXPORTS| - print ""; - print "
     
    "; - # ANONYMOUS| - print ""; - print "
     
    "; - # DEBUG| - print ""; - print "
     
    "; - print "
    \n"; - print "
    "; - print "    		"; # left column + +# ---- Display list of PROCS that are eligible for requests +print "
    $__{'Available PROCS'}"; +print "
    "; +for my $p (@proclist) { + %P = readProc($p,'novsub','escape'); # reads the proc conf without modifying content (no variable substitution, keep escaped char) + my $nn = scalar(@{$P{$p}{NODESLIST}}); + print " {$p}: $P{$p}{NAME} ($nn node".($nn>1?"s":"").")
    \n"; + print pkeys($p,\%P); +} +print "
    "; +print "
    		"; # right column + +print "
    $__{'Date and time span (UT)'}"; + +# DATE1| DATE2| +print ""; +print ""; +print ""; +print ""; +print ""; +print ""; +print "
    "; +print "
    "; +print "$__{'Start date'}: "; +print " "; +print " "; +print "    "; +print "
    "; +print "$__{'End date'}: "; +print " "; +print " "; +print "    "; +print " "; +print "
    		$__{'Preset dates'}
    \n"; +print "
    "; + +my %datestr = readCfg("$WEBOBS{ROOT_CODE}/etc/dateformats.conf"); +my @ppis = split(',',$WEBOBS{REQ_PPI_LIST} //= '75,100,150,300,600'); +my @marks = split(',',$WEBOBS{REQ_MARKERSIZE_LIST} //= '1,2,4,6,10,15,20'); +my @linew = split(',',$WEBOBS{REQ_LINEWIDTH_LIST} //= '0.1,0.25,0.5,1,1.5,2,3'); + +print "
    $__{'Output parameters'}"; +print ""; +print ""; +print ""; + +print ""; +print "
    "; + +# TZ| +print ""; +print "
     
    "; + +# DATESTR| +print ""; +print "
     
    "; + +# CUMULATE| +print ""; +print " $__{'days'}
     
    "; + +# DECIMATE| +print ""; +print "1/
     
    "; + +# MARKERSIZE| +print ""; +print "
     
    "; + +# LINEWIDTH| +print ""; +print "
     
    "; + +# PLOTGRID| +print ""; +print "
     
    "; +print "    		"; + +# PPI| +print ""; +print "
     
    "; + +# PDFOUTPUT| +print ""; +print "
     
    "; + +# SVGOUTPUT| +print ""; +print "
     
    "; + +# EXPORTS| +print ""; +print "
     
    "; + +# ANONYMOUS| +print ""; +print "
     
    "; + +# DEBUG| +print ""; +print "
     
    "; +print "
    \n"; +print "
    "; +print "
    \n"; print "

    "; @@ -444,23 +459,23 @@ =head1 DATE SPAN AND PARAMETERS # ---- build a div for a proc's keylist input fields # (args: procName, \%procConf) sub pkeys { - my ($pn,$PP) = @_; - if (defined($pn)) { - my $div = "

    "; - return $div; - } - return "" ; # no request_keylist + my ($pn,$PP) = @_; + if (defined($pn)) { + my $div = ""; + return $div; + } + return "" ; # no request_keylist } __END__ diff --git a/CODE/cgi-bin/formRIVERS.pl b/CODE/cgi-bin/formRIVERS.pl index 21276cc6..f58babe4 100755 --- a/CODE/cgi-bin/formRIVERS.pl +++ b/CODE/cgi-bin/formRIVERS.pl @@ -56,19 +56,19 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = ""; @@ -226,8 +226,6 @@ =head1 Query string parameter FIN - - # ---- read data file # my $message = "Saisie de nouvelles données"; @@ -237,38 +235,38 @@ =head1 Query string parameter my ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val); $id=$date=$heure=$site=$level=$type=$flacon=$tRiver=$suspendedLoad=$pH=$cond25=$cond=$cNa=$cK=$cMg=$cCa=$cHCO3=$cCl=$cSO4=$cSiO2=$cDOC=$cPOC=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) >= 1) { - chomp(@ligne); - ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - ($sel_hr,$sel_mn) = split (/:/,$heure); - $sel_site = $site; - $sel_level = $level; - $sel_type = $type; - $sel_flacon = $flacon; - $sel_tRiver = $tRiver; - $sel_suspendedLoad = $suspendedLoad; - $sel_pH = $pH; - $sel_cond25 = $cond25; - $sel_cond = $cond; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cHCO3 = $cHCO3; - $sel_cCl = $cCl; - $sel_cSO4 = $cSO4; - $sel_cSiO2 = $cSiO2; - $sel_cDOC = $cDOC; - $sel_cPOC = $cPOC; - $sel_rem = $rem; - $sel_rem =~ s/"/"/g; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) >= 1) { + chomp(@ligne); + ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + ($sel_hr,$sel_mn) = split (/:/,$heure); + $sel_site = $site; + $sel_level = $level; + $sel_type = $type; + $sel_flacon = $flacon; + $sel_tRiver = $tRiver; + $sel_suspendedLoad = $suspendedLoad; + $sel_pH = $pH; + $sel_cond25 = $cond25; + $sel_cond = $cond; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cHCO3 = $cHCO3; + $sel_cCl = $cCl; + $sel_cSO4 = $cSO4; + $sel_cSiO2 = $cSiO2; + $sel_cDOC = $cDOC; + $sel_cPOC = $cPOC; + $sel_rem = $rem; + $sel_rem =~ s/"/"/g; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print ""; @@ -280,17 +278,17 @@ =head1 Query string parameter

    $message

    "; - if ($val ne "") { - print "

    Information de saisie: $val + print "{id}\">"; + print "

    "; + if ($val ne "") { + print "

    Information de saisie: $val

    "; - } - print ""; - if (clientHasAdm(type=>"authforms",name=>"RIVERS")) { - print ""; - } - print "
    "; @@ -301,117 +299,118 @@ =head1 Query string parameter
    Date et lieu du prélèvement

    Date: "; - print " "; - print " "; - - print "  Heure: "; - print "
    "; - - print "Site:
    \n"; +for (@anneeListe) { + if ($_ == $sel_annee) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; - print "Type:
    \n"; +print "  Heure: "; +print "
    "; + +print "Site:
    \n"; - print "Flacon:
    \n"; - print "

    "; - print "
    "; - - print "
    Mesures sur site"; - print "

    "; - print "Niveau d'eau (en cm) =
    "; - print "Température du liquide (en °C) =
    "; - print "pH =
    "; - print "Conductivité (en µS/cm) =
    "; - print "

    "; - print "
    "; - - print "
    Concentration en autres éléments"; - print "
    "; - print "

    "; - print "SiO2 (en ppm) =
    \n"; - print "Concentration en suspension solide (en mg/L) =
    "; - print "

    "; - print "
    "; +print "Type:
    \n"; + +print "Flacon:
    \n"; +print "

    "; +print ""; + +print "
    Mesures sur site"; +print "

    "; +print "Niveau d'eau (en cm) =
    "; +print "Température du liquide (en °C) =
    "; +print "pH =
    "; +print "Conductivité (en µS/cm) =
    "; +print "

    "; +print "
    "; + +print "
    Concentration en autres éléments"; +print "
    "; +print "

    "; +print "SiO2 (en ppm) =
    \n"; +print "Concentration en suspension solide (en mg/L) =
    "; +print "

    "; +print "
    "; print "    		"; - print "
    Concentrations en cations et anions\n"; - print "

    Attention: valeurs en ppm = mg/l

    \n"; - #djl-was: print "
    "; - print ""; - print ""; - print "
    "; - print "

    "; - print "Na+ (en ppm) =
    \n"; - print "K+ (en ppm) =
    \n"; - print "Mg++ (en ppm) =
    \n"; - print "Ca++ (en ppm) =
    \n"; - print "H+ (en ppm) =
    \n"; - print "

    		"; - print "

    "; - print "HCO3- (en ppm) =
    \n"; - print "Cl- (en ppm) =
    \n"; - print "SO4-- (en ppm) =
    \n"; - print "

    NICB (%) = "; - print "
    "; - print ""; - - print "
    Concentrations organiques"; - print "
    "; - print "

    "; - print "DOC (en ppm) =
    \n"; - print "POC (en ppm) =
    \n"; - print "

    "; - print "
    "; - - print "
    Mesures en laboratoire"; - print "

    "; - print "Conductivité à 25°C (en µS/cm) =
    "; - print "

    "; - print "
    "; +print "
    Concentrations en cations et anions\n"; +print "

    Attention: valeurs en ppm = mg/l

    \n"; + +#djl-was: print "
    "; +print ""; +print ""; +print "
    "; +print "

    "; +print "Na+ (en ppm) =
    \n"; +print "K+ (en ppm) =
    \n"; +print "Mg++ (en ppm) =
    \n"; +print "Ca++ (en ppm) =
    \n"; +print "H+ (en ppm) =
    \n"; +print "

    		"; +print "

    "; +print "HCO3- (en ppm) =
    \n"; +print "Cl- (en ppm) =
    \n"; +print "SO4-- (en ppm) =
    \n"; +print "

    NICB (%) = "; +print "
    "; +print ""; + +print "
    Concentrations organiques"; +print "
    "; +print "

    "; +print "DOC (en ppm) =
    \n"; +print "POC (en ppm) =
    \n"; +print "

    "; +print "
    "; + +print "
    Mesures en laboratoire"; +print "

    "; +print "Conductivité à 25°C (en µS/cm) =
    "; +print "

    "; +print "
    "; print "
    "; - print "Observations :

    "; +print "Observations :

    "; print "
    "; print "

    "; diff --git a/CODE/cgi-bin/formSOILSOLUTION.pl b/CODE/cgi-bin/formSOILSOLUTION.pl index cbb0a284..82d08d30 100755 --- a/CODE/cgi-bin/formSOILSOLUTION.pl +++ b/CODE/cgi-bin/formSOILSOLUTION.pl @@ -56,11 +56,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -72,11 +72,11 @@ =head1 Query string parameter @$lines = reverse sort tri_date_avec_id @$lines; my %lastData; for my $id (keys(%Ns)) { - for my $d (@depth) { - my @tmp = grep(/\|$id\|$d\|/,@$lines); - chomp(@tmp); - $lastData{$id."_".$d} = $tmp[$#tmp]; - } + for my $d (@depth) { + my @tmp = grep(/\|$id\|$d\|/,@$lines); + chomp(@tmp); + $lastData{$id."_".$d} = $tmp[$#tmp]; + } } # --- DateTime inits ------------------------------------- @@ -136,10 +136,10 @@ =head1 Query string parameter var lastData = {}; ]; foreach my $id (keys(%Ns)) { - foreach my $d (@depth) { - my $key = $id."_".$d; - print qq[ lastData["$key"] = "$lastData{$key}";\n]; - } + foreach my $d (@depth) { + my $key = $id."_".$d; + print qq[ lastData["$key"] = "$lastData{$key}";\n]; + } } print qq[ var form = document.formulaire; @@ -265,8 +265,6 @@ =head1 Query string parameter ]; - - # ---- read data file # my $message = $__{'Enter a new data'}; @@ -276,35 +274,35 @@ =head1 Query string parameter my ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val); $id=$date2=$time2=$site=$date1=$time1=$depth=$level=$pH=$cond=$cNa=$cK=$cMg=$cCa=$cHCO3=$cCl=$cNO3=$cSO4=$cSiO2=$cDOC=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @line = @$ptr; - if (scalar(@line) >= 1) { - chomp(@line); - ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,l2u($line[0])); - if ($QryParm->{id} eq $id) { - ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); - ($sel_hr1,$sel_mn1) = split (/:/,$time1); - ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); - ($sel_hr2,$sel_mn2) = split (/:/,$time2); - $sel_site = $site; - $sel_depth = $depth; - $sel_level = $level; - $sel_pH = $pH; - $sel_cond = $cond; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cHCO3 = $cHCO3; - $sel_cCl = $cCl; - $sel_cNO3 = $cNO3; - $sel_cSO4 = $cSO4; - $sel_cSiO2 = $cSiO2; - $sel_cDOC = $cDOC; - $sel_rem = $rem; - $message = $__{"Edit existing data n° $QryParm->{id}"}; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @line = @$ptr; + if (scalar(@line) >= 1) { + chomp(@line); + ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,l2u($line[0])); + if ($QryParm->{id} eq $id) { + ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); + ($sel_hr1,$sel_mn1) = split (/:/,$time1); + ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); + ($sel_hr2,$sel_mn2) = split (/:/,$time2); + $sel_site = $site; + $sel_depth = $depth; + $sel_level = $level; + $sel_pH = $pH; + $sel_cond = $cond; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cHCO3 = $cHCO3; + $sel_cCl = $cCl; + $sel_cNO3 = $cNO3; + $sel_cSO4 = $cSO4; + $sel_cSiO2 = $cSiO2; + $sel_cDOC = $cDOC; + $sel_rem = $rem; + $message = $__{"Edit existing data n° $QryParm->{id}"}; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print qq( @@ -321,17 +319,17 @@ =head1 Query string parameter ); if ($QryParm->{id} ne "") { - print qq(); - print qq(

    ); - if ($val ne "") { - print qq(

    $__{'Input Information'}: $val + print qq(); + print qq(

    ); + if ($val ne "") { + print qq(

    $__{'Input Information'}: $val

    ); - } - print qq(); - if (clientHasAdm(type=>"authforms",name=>"SOILSOLUTION")) { - print qq(); - } - print qq(
    @@ -344,133 +342,133 @@ =head1 Query string parameter $__{'Site'}:
    +print qq() if ($QryParm->{id} eq ""); + +for (@NODESSelList) { + my @cle = split(/\|/,$_); + if ($cle[0] eq $sel_site) { + print qq(); + } elsif ($QryParm->{id} eq "") { + print qq(); + } +} +print qq(
    $__{'Start Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(
    +for (@yearList) { + if ($_ == $sel_y1) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(
    $__{'End Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(

    +for (@yearList) { + if ($_ == $sel_y2) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(

    $__{'Lysimeter'}

    $__{'Sampling Depth'} (cm) =
    $__{'Water Level'} (filled) =
    + .qq( onMouseOut="nd()" onmouseover="overlib('$__{help_soilsolution_level}')">

    diff --git a/CODE/cgi-bin/formUPLOAD.pl b/CODE/cgi-bin/formUPLOAD.pl index 1e7286e3..21edc89b 100755 --- a/CODE/cgi-bin/formUPLOAD.pl +++ b/CODE/cgi-bin/formUPLOAD.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formUPLOAD.pl @@ -55,7 +56,7 @@ =head1 QUERY-STRING # ---- calling stuff # -my @tod = localtime(); +my @tod = localtime(); my $QryParm = $cgi->Vars; my $typeDoc = $QryParm->{'doc'} // ""; my $object = $QryParm->{'object'} // ""; @@ -75,19 +76,19 @@ =head1 QUERY-STRING @NID = split(/[\.\/]/, trim($object)); ($GRIDType, $GRIDName, $NODEName) = @NID; if (defined($GRIDType) || defined($GRIDName)) { - $editOK = 1 if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); - die "$__{'Not authorized'}" if ($editOK == 0); + $editOK = 1 if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); + die "$__{'Not authorized'}" if ($editOK == 0); } else { die "$__{'Invalid object'} '$object'" } # ---- find out wether object is a grid or a node # if (scalar(@NID) == 3) { - $pobj = \%NODES; - $pathTarget = "$pobj->{PATH_NODES}/$NODEName"; + $pobj = \%NODES; + $pathTarget = "$pobj->{PATH_NODES}/$NODEName"; } if (scalar(@NID) == 2) { - $pobj = \%GRIDS; - $pathTarget = "$pobj->{PATH_GRIDS}/$GRIDType/$GRIDName"; + $pobj = \%GRIDS; + $pathTarget = "$pobj->{PATH_GRIDS}/$GRIDType/$GRIDName"; } # ---- more checkings on type of document to be uploaded @@ -96,10 +97,10 @@ =head1 QUERY-STRING die "$__{'Cannot upload to'} $typeDoc" if ( "@allowed" !~ /\b$typeDoc\b/ ); if ($typeDoc ne "SPATH_INTERVENTIONS") { - $pathTarget .= "/$pobj->{$typeDoc}"; + $pathTarget .= "/$pobj->{$typeDoc}"; } else { - die "$__{'intervention event not specified'}" if ($event eq ""); - $pathTarget .= "/$pobj->{$typeDoc}/$event/PHOTOS"; + die "$__{'intervention event not specified'}" if ($event eq ""); + $pathTarget .= "/$pobj->{$typeDoc}/$event/PHOTOS"; } # ---- at that point $pathTarget is where uploaded documents will be sent to @@ -115,7 +116,7 @@ =head1 QUERY-STRING my $titrePage = "Manage $pobj->{$typeDoc}"; print $cgi->header(-charset=>"utf-8"), -$cgi->start_html("$titrePage"); + $cgi->start_html("$titrePage"); print ""; print <<"FIN"; @@ -185,48 +186,49 @@ =head1 QUERY-STRING
    "; - print "\n

    $titrePage

    "; +print "\n

    $titrePage

    "; print "

    $__{'for'} [$object] $event

    \n"; + #was:print "

    [$NODEName] ".getNodeString(node=>$NODEName,style=>'short')."

    "; #debug: print "target= $pathTarget
    "; print ""; - print "
    \n"; - print ""; - my $i = 0; - foreach (@listeTarget) { - $i++; - my ( $name, $path, $extension ) = fileparse ( $_, '\..*' ); - my $urn = "$urnTarget/$name$extension"; - my $turn = "$urnTarget/$thumbnailsPath/$name$extension"; - my $file = "$pathTarget/$name$extension"; - print ""; - } - print "
    "; - print ""; - my $th = makeThumbnail( $file, "x$NODES{THUMBNAILS_PIXV}", "$pathTarget/$thumbnailsPath","$NODES{THUMBNAILS_EXT}"); - if ( $th ne "" ) { - (my $turn = $th) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - print ""; - } - print ""; - print "

    $name$extension
    "; - print " $__{'Delete'}

    "; - print "
    "; - - print "
    $__{'Upload new file(s)'} Note: $__{'Avoid special characters and spaces in filename'} +print "
    \n"; +print ""; +my $i = 0; +foreach (@listeTarget) { + $i++; + my ( $name, $path, $extension ) = fileparse ( $_, '\..*' ); + my $urn = "$urnTarget/$name$extension"; + my $turn = "$urnTarget/$thumbnailsPath/$name$extension"; + my $file = "$pathTarget/$name$extension"; + print ""; +} +print "
    "; + print ""; + my $th = makeThumbnail( $file, "x$NODES{THUMBNAILS_PIXV}", "$pathTarget/$thumbnailsPath","$NODES{THUMBNAILS_EXT}"); + if ( $th ne "" ) { + (my $turn = $th) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + print ""; + } + print ""; + print "

    $name$extension
    "; + print " $__{'Delete'}

    "; +print "
    "; + +print "
    $__{'Upload new file(s)'} Note: $__{'Avoid special characters and spaces in filename'}

    "; - print "
    "; +print "
    "; - print ""; - print ""; - print ""; - print ""; +print ""; +print ""; +print ""; +print ""; - print "

    "; - print ""; - print "

    "; +print "

    "; +print ""; +print "

    "; print "
     
    "; # ---- We're done with the page diff --git a/CODE/cgi-bin/formVEHICLES.pl b/CODE/cgi-bin/formVEHICLES.pl index 73755bf4..981d6cd8 100755 --- a/CODE/cgi-bin/formVEHICLES.pl +++ b/CODE/cgi-bin/formVEHICLES.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formVEHICLES.pl @@ -57,11 +58,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -70,8 +71,8 @@ =head1 Query string parameter # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = ""; @@ -167,23 +168,23 @@ =head1 Query string parameter my $fts-1; my ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split(/\|/,$_); if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - ($sel_hr,$sel_mn) = split (/:/,$heure); - $sel_vehicle = $vehicle; - $sel_mileage = $mileage; - $sel_type = $type; - $sel_site = $site; - $sel_driver = $driver; - $sel_oil = $oil; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; } - } else { $QryParm->{id} = ""; } + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + ($sel_hr,$sel_mn) = split (/:/,$heure); + $sel_vehicle = $vehicle; + $sel_mileage = $mileage; + $sel_type = $type; + $sel_site = $site; + $sel_driver = $driver; + $sel_oil = $oil; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; } + } else { $QryParm->{id} = ""; } } print ""; + #print ""; #print ""; if ($editOK) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."" - ."" - ."\n" - ."" + ."\n" + ."" } $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$d0,$d[0],$d[1],$d[2],$d[3],$d[4],$d[5],$d[6],$d[7],$d[8],$d[9],$d[10],$d[11],$d[12],$d[13],$d[14],$d[15],$d[16],$d[17],$d[18],$d[19],$rem,$val) = split(/\|/,$_); - # trie les données pour mettre les champs vides à la fin... - @d = sort { ($a eq "") <=> ($b eq "") } @d; - my $DM = ""; - my $DS = ""; - my $n = 0; - if ($i eq 0) { - push(@csv,u2l("$date;$heure;Code Site;$site;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;Dist. Moy (m);2*Sigma (m);\"$rem\";$val")); - } - elsif (($_ ne "") - && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { - - for $j(@nd) { - if ($d[$j] ne "") { - my $dd = 0; - if (($d[$j] - $d[0]) > 500) { $dd = -1; } - if (($d[$j] - $d[0]) < -500) { $dd = 1; } - $DM += $d0 + $d[$j]/1000 + $dd; # $DM = momentanément somme des x - $DS += ($d0 + $d[$j]/1000 + $dd)**2; # $DS = momentanément somme des x² - $n++; - } - } - if ($n > 0) { - $DM = $DM/$n; # $DM = moyenne - $DS = 2 * sqrt($DS/$n - $DM*$DM); # $DS = 2 * écart-type - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($editOK) { - $texte = $texte.""; - } - $texte = $texte."" - ."" - .""; - for (@nd) { - $texte = $texte.""; - } - $texte = $texte.""; - if (($DS > 0.1) || ($DS == 0)) { - $texte .= "\n"; - $txt = $txt."\"$rem\"\n"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$d0,$d[0],$d[1],$d[2],$d[3],$d[4],$d[5],$d[6],$d[7],$d[8],$d[9],$d[10],$d[11],$d[12],$d[13],$d[14],$d[15],$d[16],$d[17],$d[18],$d[19],$rem,$val) = split(/\|/,$_); + + # trie les données pour mettre les champs vides à la fin... + @d = sort { ($a eq "") <=> ($b eq "") } @d; + my $DM = ""; + my $DS = ""; + my $n = 0; + if ($i eq 0) { + push(@csv,u2l("$date;$heure;Code Site;$site;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;Dist. Moy (m);2*Sigma (m);\"$rem\";$val")); + } + elsif (($_ ne "") + && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { + + for $j(@nd) { + if ($d[$j] ne "") { + my $dd = 0; + if (($d[$j] - $d[0]) > 500) { $dd = -1; } + if (($d[$j] - $d[0]) < -500) { $dd = 1; } + $DM += $d0 + $d[$j]/1000 + $dd; # $DM = momentanément somme des x + $DS += ($d0 + $d[$j]/1000 + $dd)**2; # $DS = momentanément somme des x² + $n++; + } + } + if ($n > 0) { + $DM = $DM/$n; # $DM = moyenne + $DS = 2 * sqrt($DS/$n - $DM*$DM); # $DS = 2 * écart-type + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($editOK) { + $texte = $texte.""; + } + $texte = $texte."" + ."" + .""; + for (@nd) { + $texte = $texte.""; + } + $texte = $texte.""; + if (($DS > 0.1) || ($DS == 0)) { + $texte .= "\n"; + $txt = $txt."\"$rem\"\n"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

    \n", - "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

    \n"); + "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"
    @@ -193,7 +194,7 @@ =head1 Query string parameter print "
    "; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; @@ -204,70 +205,72 @@ =head1 Query string parameter
    Date et lieu du déplacement

    Date: "; - print " "; - print " "; - - print "  Heure: "; - print "
    "; - - print "Véhicule:
    \n"; - - print "Lieu:
    \n"; - print "

    "; - print "
    "; - - print "
    Informations sur le déplacement\n +for (@anneeListe) { + if ($_ == $sel_annee) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; + +print "  Heure: "; +print "
    "; + +print "Véhicule:
    \n"; + +print "Lieu:
    \n"; +print "

    "; +print "
    "; + +print "
    Informations sur le déplacement\n

    "; - print "Type de déplacement:
    "; - print " Conducteur:
    \n +print "Type de déplacement:
    "; +print " Conducteur:
    \n Kilomètre au compteur = km
    \n Carburant = €
    \n"; + # print "Débit (qualitatif) = \n"; - print "

    "; +print ""; print "
    "; # print "Observations :

    "; diff --git a/CODE/cgi-bin/gedit.pl b/CODE/cgi-bin/gedit.pl index 34531454..2bd3753d 100755 --- a/CODE/cgi-bin/gedit.pl +++ b/CODE/cgi-bin/gedit.pl @@ -76,7 +76,7 @@ =head1 Markitup customization # my @lignes; -my $me = $ENV{SCRIPT_NAME}; +my $me = $ENV{SCRIPT_NAME}; my $QryParm = $cgi->Vars; my $grid = $QryParm->{'grid'} // ""; my $file = $QryParm->{'file'} // ""; @@ -99,53 +99,53 @@ =head1 Markitup customization # ---- see what file has to be edited, and corresponding authorization for client # ---- new file (create) initialization # -if (scalar(@GID) == 2) { - if ($file ne "") { - $absfile = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDType.$GRIDName$file"; - if ($GRIDType eq 'DOMAIN' || $GRIDType eq 'GRIDS') { - $editOK = (clientHasEdit(type=>"authviews",name=>"*") && clientHasEdit(type=>"authprocs",name=>"*")); - $admOK = (clientHasAdm(type=>"authviews",name=>"*") && clientHasAdm(type=>"authprocs",name=>"*")); - } else { - $editOK = clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); - $admOK = clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); - } - unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } - if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } - if ( (!$editOK) && (!-e $absfile) ) { die "$name $__{'not found'} or $__{'not authorized'}" } - } else { die "$__{'No filename specified'}" } +if (scalar(@GID) == 2) { + if ($file ne "") { + $absfile = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDType.$GRIDName$file"; + if ($GRIDType eq 'DOMAIN' || $GRIDType eq 'GRIDS') { + $editOK = (clientHasEdit(type=>"authviews",name=>"*") && clientHasEdit(type=>"authprocs",name=>"*")); + $admOK = (clientHasAdm(type=>"authviews",name=>"*") && clientHasAdm(type=>"authprocs",name=>"*")); + } else { + $editOK = clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); + $admOK = clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); + } + unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } + if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } + if ( (!$editOK) && (!-e $absfile) ) { die "$name $__{'not found'} or $__{'not authorized'}" } + } else { die "$__{'No filename specified'}" } } else { die "$__{'Not a valid GRID requested (NOT gridtype.gridname)'}" } # ---- action is 'save' # if ($action eq 'save') { - if ($TS0 != (stat("$absfile"))[9]) { - htmlMsgNotOK("$name $_{'has been modified while you were editing'}"); - exit; - } - if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $name..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $absfile $absfile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - if ($conv eq "1") { - $txt = WebObs::Wiki::wiki2MMD($txt); - $txt = "WebObs: converted with wiki2MMD\n\n$txt"; - } - $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lignes,$txt); - print FILE @lignes ; - close(FILE); - htmlMsgOK($name); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $name"); - } - } else { htmlMsgNotOK("$me opening $name - $!") } - exit; + if ($TS0 != (stat("$absfile"))[9]) { + htmlMsgNotOK("$name $_{'has been modified while you were editing'}"); + exit; + } + if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $name..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $absfile $absfile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + if ($conv eq "1") { + $txt = WebObs::Wiki::wiki2MMD($txt); + $txt = "WebObs: converted with wiki2MMD\n\n$txt"; + } + $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lignes,$txt); + print FILE @lignes ; + close(FILE); + htmlMsgOK($name); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $name"); + } + } else { htmlMsgNotOK("$me opening $name - $!") } + exit; } # ---- action is 'edit' (default) @@ -154,6 +154,7 @@ =head1 Markitup customization @lignes = readFile($absfile); $TS0 = (stat($absfile))[9] ; chomp(@lignes); + # file contents as a string and determine markup type (WO or MMD) $txt = join("\n",@lignes); ($txt, my $meta) = WebObs::Wiki::stripMDmetadata($txt); @@ -190,12 +191,12 @@ =head1 Markitup customization -"; +"; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print " FIN -if (defined($QryParm->{'iref'})) { print "iref set" } +if (defined($QryParm->{'iref'})) { print "iref set" } if (defined($svg)) { - #djl-TBD: remove all attributes 'style=' so that FF can apply css rules .... - #djl-TBD: fontsize only used here (ie. at svg build time) as it participate in nodes' polygon sizes! - print "

    $GRIDType.$GRIDName

    \n"; - print "
    "; - print "$GRIDType.$GRIDName root nodes are those valid and active today
    "; - print "$legend"; - print "

    \n"; - print "
    "; - print $svg; - print "
    "; + +#djl-TBD: remove all attributes 'style=' so that FF can apply css rules .... +#djl-TBD: fontsize only used here (ie. at svg build time) as it participate in nodes' polygon sizes! + print "

    $GRIDType.$GRIDName

    \n"; + print "
    "; + print "$GRIDType.$GRIDName root nodes are those valid and active today
    "; + print "$legend"; + print "

    \n"; + print "
    "; + print $svg; + print "
    "; } else {die "Unable to create svg for ".$GRIDType.$GRIDName} -if ($dbg) { - open(WRT, ">$WEBOBS{PATH_TMP_APACHE}/gv"); - print(WRT $dbg); - close(WRT); +if ($dbg) { + open(WRT, ">$WEBOBS{PATH_TMP_APACHE}/gv"); + print(WRT $dbg); + close(WRT); } print "
    \n\n\n"; diff --git a/CODE/cgi-bin/index.pl b/CODE/cgi-bin/index.pl index ddc91c44..654ca8a8 100755 --- a/CODE/cgi-bin/index.pl +++ b/CODE/cgi-bin/index.pl @@ -79,13 +79,12 @@ =head1 NAVIGATION FILE .html FORMAT use WebObs::i18n; use Locale::TextDomain('webobs'); - # if the client is not a valid user, ends here !! if (!WebObs::Users::clientIsValid) { - print $cgi->header(-type=>'text/html', -charset=>'utf-8'); - print "

    $WEBOBS{WEBOBS_ID}: $WEBOBS{VERSION}

    " - ."Sorry, user '$USERS{$CLIENT}{LOGIN}' is not valid or is waiting for validation by an administrator..."; - exit(1); + print $cgi->header(-type=>'text/html', -charset=>'utf-8'); + print "

    $WEBOBS{WEBOBS_ID}: $WEBOBS{VERSION}

    " + ."Sorry, user '$USERS{$CLIENT}{LOGIN}' is not valid or is waiting for validation by an administrator..."; + exit(1); } # ---- reads in configuration options ------------------ @@ -93,9 +92,9 @@ =head1 NAVIGATION FILE .html FORMAT my $logout = "login: $USERS{$CLIENT}{FULLNAME}"; my $lo = ""; if ($MENU{CLEAR_AUTHENTICATION_CACHE} ne "") { - $lo = CGI->new->url(); - $lo =~ s/:\/\//:\/\/$MENU{CLEAR_AUTHENTICATION_CACHE}@/; - $logout = "login: $USERS{$CLIENT}{FULLNAME}"; + $lo = CGI->new->url(); + $lo =~ s/:\/\//:\/\/$MENU{CLEAR_AUTHENTICATION_CACHE}@/; + $logout = "login: $USERS{$CLIENT}{FULLNAME}"; } # ---- language cookie management ----------------------- @@ -106,17 +105,17 @@ =head1 NAVIGATION FILE .html FORMAT my $langue_cgi = defined($cgi->param('langue'))?$cgi->param('langue'):""; if ( $langue_cgi =~ /^[a-zA-Z][a-zA-Z]/ && -d "$WEBOBS{ROOT_I18N}/locales/".($langue_cgi)."/LC_MESSAGES" ) { - $langue_utilisee = $langue_cgi; + $langue_utilisee = $langue_cgi; } elsif ( $langue_cookie =~ /^[a-zA-Z][a-zA-Z]/ && -d "$WEBOBS{ROOT_I18N}/locales/".($langue_cookie)."/LC_MESSAGES" ) { - $langue_utilisee = $langue_cookie; + $langue_utilisee = $langue_cookie; } else { - $langue_utilisee = $WEBOBS{LOCALE}; + $langue_utilisee = $WEBOBS{LOCALE}; } if ( $langue_cookie ne $langue_utilisee ) { - my $cookie1 = new CGI::Cookie(-name=>'langue_webobs',-value=>$langue_utilisee); - print $cgi->header(-cookie=>[$cookie1],-charset=>"utf-8",-type=>'text/html'); + my $cookie1 = new CGI::Cookie(-name=>'langue_webobs',-value=>$langue_utilisee); + print $cgi->header(-cookie=>[$cookie1],-charset=>"utf-8",-type=>'text/html'); } else { - print $cgi->header(-charset=>"utf-8",-type=>'text/html'); + print $cgi->header(-charset=>"utf-8",-type=>'text/html'); } cherche_langue($langue_utilisee); @@ -125,13 +124,13 @@ =head1 NAVIGATION FILE .html FORMAT my %nom_langue; my @liste_langues; for my $code_desc (split(/\|/,$WEBOBS{"LANGUAGE_LIST"})) { - my ($code,$desc) = split(/:/,$code_desc); - push(@liste_langues,$code); - $nom_langue{$code}=$desc; + my ($code,$desc) = split(/:/,$code_desc); + push(@liste_langues,$code); + $nom_langue{$code}=$desc; } my $drapeaux=""; for my $la (@liste_langues) { - $drapeaux .= ''.$nom_langue{$la}.''; + $drapeaux .= ''.$nom_langue{$la}.''; } $drapeaux =~ s/'/\\'/g; @@ -142,7 +141,7 @@ =head1 NAVIGATION FILE .html FORMAT my @liste_title = split(/;/,$MENU{"LOGO_TITLES"}); my $logos=""; for my $i (0..$#liste_logos) { -i $logos .= "\"$liste_title[$i]\""; + i $logos .= "\"$liste_title[$i]\""; } $logos =~ s/'/\\'/g; @@ -162,9 +161,9 @@ =head1 NAVIGATION FILE .html FORMAT my @groups = WebObs::Users::userListGroup($CLIENT); my $group; for (@groups) { - $group = $_; - chomp $group; - push(@menu,readCfgFile("$WEBOBS{ROOT_CONF}/MENUS/$group","utf8")); + $group = $_; + chomp $group; + push(@menu,readCfgFile("$WEBOBS{ROOT_CONF}/MENUS/$group","utf8")); } # adds optional additionnal menu for USER @@ -172,45 +171,46 @@ =head1 NAVIGATION FILE .html FORMAT # legacy format .rc if ( $menunav =~ m/.rc$/) { - my $l1 = my $l2 = 0; - $menuhtml = "
      "; - for (@menu) { - my ($titre,$lien)=split(/\|/,$_); - $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; - my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; - if (substr($titre,0,1) eq "+" || (substr($titre,0,1) eq "!" && $admOK)) { - if ($l2==1) { $menuhtml .= "
    "; $l2 = 0; } - if ($l1==1) { $menuhtml .= ""; } - $l1 = 1; - $menuhtml .= "
  • ".substr($titre,1)."\n"; - next; - } - if ( substr($titre,0,1) eq "*" ){ - next if (! $admOK); - $titre = substr($titre,1); - } - if ($l2==0) { $menuhtml .= "
      "; $l2 = 1; } - $menuhtml .= "
    • $titre
      • \n"; - } - if ($l2==1) { $menuhtml .= "
    "; } - if ($l1==1) { $menuhtml .= "
    • "; } - $menuhtml .=""; - $wmcss="wm2.css"; - -# new format .html (CSS) + my $l1 = my $l2 = 0; + $menuhtml = "
      "; + for (@menu) { + my ($titre,$lien)=split(/\|/,$_); + $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; + my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; + if (substr($titre,0,1) eq "+" || (substr($titre,0,1) eq "!" && $admOK)) { + if ($l2==1) { $menuhtml .= "
    "; $l2 = 0; } + if ($l1==1) { $menuhtml .= ""; } + $l1 = 1; + $menuhtml .= "
  • ".substr($titre,1)."\n"; + next; + } + if ( substr($titre,0,1) eq "*" ){ + next if (! $admOK); + $titre = substr($titre,1); + } + if ($l2==0) { $menuhtml .= "
      "; $l2 = 1; } + $menuhtml .= "
    • $titre
      • \n"; + } + if ($l2==1) { $menuhtml .= "
    "; } + if ($l1==1) { $menuhtml .= "
    • "; } + $menuhtml .=""; + $wmcss="wm2.css"; + + # new format .html (CSS) } else { - @menu = grep { $_ !~ /^\*/ } @menu if (! $admOK); - for(@menu) { - s/^\*//; - s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; - my $xtrn = ($_ =~ m/http.?:\/\//) ? " class=\"externe\" ": ""; - s/"); - push(@menu,""); - $menuhtml = join("\n",@menu); - $wmcss="wm2n.css"; + @menu = grep { $_ !~ /^\*/ } @menu if (! $admOK); + for(@menu) { + s/^\*//; + s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; + my $xtrn = ($_ =~ m/http.?:\/\//) ? " class=\"externe\" ": ""; + s/"); + push(@menu,""); + $menuhtml = join("\n",@menu); + $wmcss="wm2n.css"; } + # ---- 'signature' that will show up at bottom # my $year = WebObs::Utils::num2roman(strftime("%Y", localtime)); diff --git a/CODE/cgi-bin/listGRIDS.pl b/CODE/cgi-bin/listGRIDS.pl index 5d7b7f5f..3f98fc87 100755 --- a/CODE/cgi-bin/listGRIDS.pl +++ b/CODE/cgi-bin/listGRIDS.pl @@ -61,7 +61,7 @@ =head1 Query string parameters my $subsetDomain = checkParam(scalar($cgi->param('domain')), qr/^[a-zA-Z0-9_-]*$/, "domain") // ""; my $subsetType = checkParam(scalar($cgi->param('type')), qr/^[a-zA-Z0-9_-]*$/, "type") // "all"; - $subsetType = 'all' if ( $subsetType ne 'proc' && $subsetType ne 'view' && $subsetType ne 'sefran'); +$subsetType = 'all' if ( $subsetType ne 'proc' && $subsetType ne 'view' && $subsetType ne 'sefran'); my $wantViews = ($subsetType eq 'all' || $subsetType eq 'view') ? 1 : 0; my $wantProcs = ($subsetType eq 'all' || $subsetType eq 'proc') ? 1 : 0; my $wantSefrans = ($subsetType eq 'all' || $subsetType eq 'sefran') ? 1 : 0; @@ -77,76 +77,80 @@ =head1 Query string parameters my $admPROCS = 0; my $descGridType = my $descGridName = my $descLegacy = ""; - # Open an SQLite connection to the domains database sub connectDbDomains { - return DBI->connect("dbi:SQLite:$WEBOBS{SQL_DOMAINS}", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $WEBOBS{SQL_DOMAINS}: $DBI::errstr"; + return DBI->connect("dbi:SQLite:$WEBOBS{SQL_DOMAINS}", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $WEBOBS{SQL_DOMAINS}: $DBI::errstr"; } sub getDomains { - # Return the (code, name) tuples from the domains table. - # A domain code can be provided to only fetch this domain. - # Returns a reference to list of array references. - my $dbh = shift; - my $domain = shift // ''; - my $where = ''; - my @bind_values = (); - if ($domain) { - $where = "where CODE = ?"; - push @bind_values, $domain; - } - my $q = "select CODE, NAME from $WEBOBS{SQL_TABLE_DOMAINS} $where order by OOA"; - return $dbh->selectall_arrayref($q, undef, @bind_values); + + # Return the (code, name) tuples from the domains table. + # A domain code can be provided to only fetch this domain. + # Returns a reference to list of array references. + my $dbh = shift; + my $domain = shift // ''; + my $where = ''; + my @bind_values = (); + if ($domain) { + $where = "where CODE = ?"; + push @bind_values, $domain; + } + my $q = "select CODE, NAME from $WEBOBS{SQL_TABLE_DOMAINS} $where order by OOA"; + return $dbh->selectall_arrayref($q, undef, @bind_values); } sub getDomainGrids { - # Return the list of names of grids from the grids2domains table - # for the provided type ('PROC' or 'VIEW') and domain code. - # Returns a reference to a list of grid names. - my $dbh = shift; - my $type = shift; - my $domain_code = shift; - my $q = "select NAME from $WEBOBS{SQL_TABLE_GRIDS} " - ."where TYPE = ? and DCODE = ? order by name"; - return $dbh->selectcol_arrayref($q, { 'Columns' => [1] }, - $type, $domain_code); + + # Return the list of names of grids from the grids2domains table + # for the provided type ('PROC' or 'VIEW') and domain code. + # Returns a reference to a list of grid names. + my $dbh = shift; + my $type = shift; + my $domain_code = shift; + my $q = "select NAME from $WEBOBS{SQL_TABLE_GRIDS} " + ."where TYPE = ? and DCODE = ? order by name"; + return $dbh->selectcol_arrayref($q, { 'Columns' => [1] }, + $type, $domain_code); } sub getDomainProcs { - # Return the list of procs for a domain using getDomainGrids - my $dbh = shift; - my $domain_code = shift; - return getDomainGrids($dbh, 'PROC', $domain_code); + + # Return the list of procs for a domain using getDomainGrids + my $dbh = shift; + my $domain_code = shift; + return getDomainGrids($dbh, 'PROC', $domain_code); } sub getDomainViews { - # Return the list of views for a domain using getDomainGrids - my $dbh = shift; - my $domain_code = shift; - return getDomainGrids($dbh, 'VIEW', $domain_code); + + # Return the list of views for a domain using getDomainGrids + my $dbh = shift; + my $domain_code = shift; + return getDomainGrids($dbh, 'VIEW', $domain_code); } sub getDomainSefrans { - # Return the list of sefrans for a domain using getDomainGrids - my $dbh = shift; - my $domain_code = shift; - return getDomainGrids($dbh, 'SEFRAN', $domain_code); + + # Return the list of sefrans for a domain using getDomainGrids + my $dbh = shift; + my $domain_code = shift; + return getDomainGrids($dbh, 'SEFRAN', $domain_code); } if ($subsetDomain ne '') { - $descGridType = 'DOMAIN'; - $descGridName = $subsetDomain; + $descGridType = 'DOMAIN'; + $descGridName = $subsetDomain; } else { - $descGridType = 'GRIDS'; - switch ($subsetType) { - case 'all' { $descGridName = 'ALL'; } - case 'view' { $descGridName = 'VIEWS'; $descLegacy = 'VIEW.VIEWS'; } - case 'proc' { $descGridName = 'PROCS'; $descLegacy = 'PROC.PROCS'; }; - } + $descGridType = 'GRIDS'; + switch ($subsetType) { + case 'all' { $descGridName = 'ALL'; } + case 'view' { $descGridName = 'VIEWS'; $descLegacy = 'VIEW.VIEWS'; } + case 'proc' { $descGridName = 'PROCS'; $descLegacy = 'PROC.PROCS'; }; + } } # creation of new view or proc is allowed only if the user has admin authorization for ALL grids (views and/or procs) @@ -163,10 +167,10 @@ sub getDomainSefrans { my %domainViews = map(($_->[0] => []), @$domains); my %domainSefrans = map(($_->[0] => []), @$domains); for my $d (@$domains) { - my ($code, $name) = @$d; - push @{$domainProcs{$code}}, @{getDomainProcs($dbh, $code)} if $wantProcs; - push @{$domainViews{$code}}, @{getDomainViews($dbh, $code)} if $wantViews; - push @{$domainSefrans{$code}}, @{getDomainSefrans($dbh, $code)} if $wantSefrans; + my ($code, $name) = @$d; + push @{$domainProcs{$code}}, @{getDomainProcs($dbh, $code)} if $wantProcs; + push @{$domainViews{$code}}, @{getDomainViews($dbh, $code)} if $wantViews; + push @{$domainSefrans{$code}}, @{getDomainSefrans($dbh, $code)} if $wantSefrans; } $dbh->disconnect(); @@ -187,16 +191,15 @@ sub getDomainSefrans {
    "; - # ---- Title is = selected type (aka subsetType) # print "    "; print "

    "; - print "$DOMAINS{$subsetDomain}{NAME} " if ($subsetDomain ne ""); - print "$GRIDS{SHOW_GRIDS_TITLE}\n" if ($subsetType eq 'all'); - print "Views" if ($subsetType eq 'view'); - print "Procs" if ($subsetType eq 'proc'); - print "Sefrans" if ($subsetType eq 'sefran'); +print "$DOMAINS{$subsetDomain}{NAME} " if ($subsetDomain ne ""); +print "$GRIDS{SHOW_GRIDS_TITLE}\n" if ($subsetType eq 'all'); +print "Views" if ($subsetType eq 'view'); +print "Procs" if ($subsetType eq 'proc'); +print "Sefrans" if ($subsetType eq 'sefran'); print "

    \n"; # ---- Subtitle menu to other domains/grids displays @@ -207,14 +210,14 @@ sub getDomainSefrans { print " | ".($subsetType ne 'view' || $subsetDomain ne '' ? "Views":"Views"); print " | ".($subsetType ne 'sefran' || $subsetDomain ne '' ? "Sefrans":"Sefrans"); if ($subsetDomain eq '') { - print " - Domains: "; - print join(" | ", map("[0]&type=$subsetType\">$_->[1]", @$domains)); + print " - Domains: "; + print join(" | ", map("[0]&type=$subsetType\">$_->[1]", @$domains)); } else { - print " - $DOMAINS{$subsetDomain}{NAME}"; - print " ".($subsetType ne 'all' ? "Grids":"Grids"); - print " | ".($subsetType ne 'proc' ? "Procs":"Procs"); - print " | ".($subsetType ne 'view' ? "Views":"Views"); - print " | ".($subsetType ne 'sefran' ? "Sefrans":"Sefrans"); + print " - $DOMAINS{$subsetDomain}{NAME}"; + print " ".($subsetType ne 'all' ? "Grids":"Grids"); + print " | ".($subsetType ne 'proc' ? "Procs":"Procs"); + print " | ".($subsetType ne 'view' ? "Views":"Views"); + print " | ".($subsetType ne 'sefran' ? "Sefrans":"Sefrans"); } print " ]

    "; @@ -222,189 +225,188 @@ sub getDomainSefrans { # printdesc('Purpose','DESCRIPTION',$descGridType,$descGridName,$descLegacy); - # ---- list subsetType grids, grouped by domains # print "
    "; - my $d = my $p = my $v = 0; - if (@$domains) { - - # ---- The invisible-until-triggered-by-js popups ;-) - print ""; - print WebObs::Search::searchpopup(); - print geditpopup(); - print feditpopup(); - - # ---- The GRIDS table - # - print "\n
    \n"; - - print ""; - if ($subsetDomain eq "") { - print ""; - } - print "" if ($subsetType ne ""); - print ""; - print ""; - print "" if ($showType); - print "" if ($showOwnr); - print ""; - if ($wantProcs || $wantSefrans) { - print ""; - } - print "\n"; - for my $d (@$domains) { - my ($dc, $dn) = @$d; - my @procs; - my $ovl; - if ($wantProcs) { - @procs = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), - @{$domainProcs{$dc}}); - } - my $np = scalar(@procs); - my @views; - if ($wantViews) { - @views = grep(WebObs::Users::clientHasRead(type=>"authviews", name=>$_), - @{$domainViews{$dc}}); - } - my $nv = scalar(@views); - my @sefrans; - if ($wantSefrans) { - @sefrans = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), - @{$domainSefrans{$dc}}); - } - my $ns = scalar(@sefrans); - my $domrows = $np+$nv+$ns; - if ( $domrows > 0 ) { - print ""; - print "" if ($vs ne $sefrans[0]); - print "" if ($subsetType ne ""); - $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vs}{DESCRIPTION}."',CAPTION,'SEFRAN.$vs')\""; - print ""; - print ""; - print "" if ($showType); - print "" if ($showOwnr); - if ( -d "$G{$vs}{ROOT}" ) { - print ""; - print ""; - } - print "\n"; - } - } - if ( $np > 0 ) { - for my $vp (@procs) { - my %G = readProc($vp); - if (%G) { - print "" if ($vp ne $procs[0]); - print "" if ($subsetType ne ""); - $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vp}{DESCRIPTION}."',CAPTION,'PROC.$vp')\""; - print ""; - print ""; - print "" if ($showType); - print "" if ($showOwnr); - if ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_GRAPHS}" ) { - print ""; - print ""; - } - print "\n"; - } - } - if ( $nv > 0 ) { - for my $vn (@views) { - my %G = readView($vn); - if (%G) { - print "" if ($np > 0 || $vn ne $views[0]); - print ""; - $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vn}{DESCRIPTION}."',CAPTION,'VIEW.$vn')\""; - print "" - if ($showType); - print "" if ($showOwnr); - if ( -d "$WEBOBS{ROOT_OUTG}/VIEW.$vn/$WEBOBS{PATH_OUTG_MAPS}" ) { - print ""; - if ($wantProcs) { - print ""; - } - } - print "\n"; - } - } - } - } - print "
    "; - if (WebObs::Users::clientHasAdm(type=>"authmisc",name=>"*")) { - print "    "; - } - print "DomainGrid"; - if ($admVIEWS || $admPROCS) { - print " " - } - print "   NameNodesTypeOwnerGraphs"; - if ( $admPROCS ) { - print ""; - } - print "   Raw Data

    $dn

    " if ($subsetDomain eq ""); - if ( $ns > 0 ) { - for my $vs (@sefrans) { - my %G = readSefran($vs); - if (%G) { - print "
    SEFRAN"; - if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$G{$vs}{MC3_NAME})) { print " " } - print "  $G{$vs}{NAME}"; - print "".(split('\|',$G{$vs}{CHANNELLIST}))." channels".(defined($G{$vs}{TYPE}) ? $G{$vs}{TYPE} : "")."".(defined($G{$vs}{OWNCODE}) ? - (defined($OWNRS{$G{$vs}{OWNCODE}}) - ? $OWNRS{$G{$vs}{OWNCODE}} - : $G{$vs}{OWNCODE}) : "") - ."\"$vs\""; - } else { print " " } - print ""; - if (defined($G{$vs}{MC3_NAME}) && $G{$vs}{MC3_NAME} ne '') { - my %MC3 = readCfg("$WEBOBS{ROOT_CONF}/$G{$vs}{MC3_NAME}.conf"); - print "\"$G{$vs}{MC3_NAME}\""; - } - print "
    PROC"; - print ""; - if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$vp)) { print " " } - print "  $G{$vp}{NAME}"; - print "".scalar(@{$G{$vp}{NODESLIST}})." "; - if (defined($G{$vp}{NODE_NAME})) { printf ("%s%s","$G{$vp}{NODE_NAME}",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } - else { printf ("node%s",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } - print "".(defined($G{$vp}{TYPE}) ? $G{$vp}{TYPE} : "") - ."".(defined($G{$vp}{OWNCODE}) ? - (defined($OWNRS{$G{$vp}{OWNCODE}}) - ? $OWNRS{$G{$vp}{OWNCODE}} - : $G{$vp}{OWNCODE}) : "") - ."\"$vp\""; - } elsif ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_EVENTS}" ) { - print "\"$vp\""; - } else { print " " } - print ""; - if (defined($G{$vp}{FORM}) && $G{$vp}{FORM} ne '') { - my %F = readCfg("$WEBOBS{PATH_FORMS}/$G{$vp}{FORM}/$G{$vp}{FORM}.conf"); - print "\"$G{$vp}{FORM}\""; - } else { - if (defined($G{$vp}{URNDATA}) && $G{$vp}{URNDATA} ne '') { - print "\"""; - } - } - print "
    VIEW"; - print ""; - if (WebObs::Users::clientHasEdit(type=>"authviews",name=>$vn)) { print " " } - print "  $G{$vn}{NAME}"; - print "".scalar(@{$G{$vn}{NODESLIST}})." "; - if (defined($G{$vn}{NODE_NAME})) { printf ("%s%s","$G{$vn}{NODE_NAME}",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } - else { printf ("node%s",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } - print "".(defined($G{$vn}{TYPE}) ? $G{$vn}{TYPE} : "")."".(defined($G{$vn}{OWNCODE}) ? - (defined($OWNRS{$G{$vn}{OWNCODE}}) - ? $OWNRS{$G{$vn}{OWNCODE}} - : $G{$vn}{OWNCODE}) : "") - ."\"$vn\""; - } else { print " " } - print "

    "; - } else { - print "

    ** No domain defined or matching '$subsetDomain' **

    "; - } +my $d = my $p = my $v = 0; +if (@$domains) { + + # ---- The invisible-until-triggered-by-js popups ;-) + print ""; + print WebObs::Search::searchpopup(); + print geditpopup(); + print feditpopup(); + + # ---- The GRIDS table + # + print "\n
    \n"; + + print ""; + if ($subsetDomain eq "") { + print ""; + } + print "" if ($subsetType ne ""); + print ""; + print ""; + print "" if ($showType); + print "" if ($showOwnr); + print ""; + if ($wantProcs || $wantSefrans) { + print ""; + } + print "\n"; + for my $d (@$domains) { + my ($dc, $dn) = @$d; + my @procs; + my $ovl; + if ($wantProcs) { + @procs = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), + @{$domainProcs{$dc}}); + } + my $np = scalar(@procs); + my @views; + if ($wantViews) { + @views = grep(WebObs::Users::clientHasRead(type=>"authviews", name=>$_), + @{$domainViews{$dc}}); + } + my $nv = scalar(@views); + my @sefrans; + if ($wantSefrans) { + @sefrans = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), + @{$domainSefrans{$dc}}); + } + my $ns = scalar(@sefrans); + my $domrows = $np+$nv+$ns; + if ( $domrows > 0 ) { + print ""; + print "" if ($vs ne $sefrans[0]); + print "" if ($subsetType ne ""); + $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vs}{DESCRIPTION}."',CAPTION,'SEFRAN.$vs')\""; + print ""; + print ""; + print "" if ($showType); + print "" if ($showOwnr); + if ( -d "$G{$vs}{ROOT}" ) { + print ""; + print ""; + } + print "\n"; + } + } + if ( $np > 0 ) { + for my $vp (@procs) { + my %G = readProc($vp); + if (%G) { + print "" if ($vp ne $procs[0]); + print "" if ($subsetType ne ""); + $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vp}{DESCRIPTION}."',CAPTION,'PROC.$vp')\""; + print ""; + print ""; + print "" if ($showType); + print "" if ($showOwnr); + if ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_GRAPHS}" ) { + print ""; + print ""; + } + print "\n"; + } + } + if ( $nv > 0 ) { + for my $vn (@views) { + my %G = readView($vn); + if (%G) { + print "" if ($np > 0 || $vn ne $views[0]); + print ""; + $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vn}{DESCRIPTION}."',CAPTION,'VIEW.$vn')\""; + print "" + if ($showType); + print "" if ($showOwnr); + if ( -d "$WEBOBS{ROOT_OUTG}/VIEW.$vn/$WEBOBS{PATH_OUTG_MAPS}" ) { + print ""; + if ($wantProcs) { + print ""; + } + } + print "\n"; + } + } + } + } + print "
    "; + if (WebObs::Users::clientHasAdm(type=>"authmisc",name=>"*")) { + print "    "; + } + print "DomainGrid"; + if ($admVIEWS || $admPROCS) { + print " " + } + print "   NameNodesTypeOwnerGraphs"; + if ( $admPROCS ) { + print ""; + } + print "   Raw Data

    $dn

    " if ($subsetDomain eq ""); + if ( $ns > 0 ) { + for my $vs (@sefrans) { + my %G = readSefran($vs); + if (%G) { + print "
    SEFRAN"; + if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$G{$vs}{MC3_NAME})) { print " " } + print "  $G{$vs}{NAME}"; + print "".(split('\|',$G{$vs}{CHANNELLIST}))." channels".(defined($G{$vs}{TYPE}) ? $G{$vs}{TYPE} : "")."".(defined($G{$vs}{OWNCODE}) ? + (defined($OWNRS{$G{$vs}{OWNCODE}}) + ? $OWNRS{$G{$vs}{OWNCODE}} + : $G{$vs}{OWNCODE}) : "") + ."\"$vs\""; + } else { print " " } + print ""; + if (defined($G{$vs}{MC3_NAME}) && $G{$vs}{MC3_NAME} ne '') { + my %MC3 = readCfg("$WEBOBS{ROOT_CONF}/$G{$vs}{MC3_NAME}.conf"); + print "\"$G{$vs}{MC3_NAME}\""; + } + print "
    PROC"; + print ""; + if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$vp)) { print " " } + print "  $G{$vp}{NAME}"; + print "".scalar(@{$G{$vp}{NODESLIST}})." "; + if (defined($G{$vp}{NODE_NAME})) { printf ("%s%s","$G{$vp}{NODE_NAME}",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } + else { printf ("node%s",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } + print "".(defined($G{$vp}{TYPE}) ? $G{$vp}{TYPE} : "") + ."".(defined($G{$vp}{OWNCODE}) ? + (defined($OWNRS{$G{$vp}{OWNCODE}}) + ? $OWNRS{$G{$vp}{OWNCODE}} + : $G{$vp}{OWNCODE}) : "") + ."\"$vp\""; + } elsif ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_EVENTS}" ) { + print "\"$vp\""; + } else { print " " } + print ""; + if (defined($G{$vp}{FORM}) && $G{$vp}{FORM} ne '') { + my %F = readCfg("$WEBOBS{PATH_FORMS}/$G{$vp}{FORM}/$G{$vp}{FORM}.conf"); + print "\"$G{$vp}{FORM}\""; + } else { + if (defined($G{$vp}{URNDATA}) && $G{$vp}{URNDATA} ne '') { + print "\"""; + } + } + print "
    VIEW"; + print ""; + if (WebObs::Users::clientHasEdit(type=>"authviews",name=>$vn)) { print " " } + print "  $G{$vn}{NAME}"; + print "".scalar(@{$G{$vn}{NODESLIST}})." "; + if (defined($G{$vn}{NODE_NAME})) { printf ("%s%s","$G{$vn}{NODE_NAME}",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } + else { printf ("node%s",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } + print "".(defined($G{$vn}{TYPE}) ? $G{$vn}{TYPE} : "")."".(defined($G{$vn}{OWNCODE}) ? + (defined($OWNRS{$G{$vn}{OWNCODE}}) + ? $OWNRS{$G{$vn}{OWNCODE}} + : $G{$vn}{OWNCODE}) : "") + ."\"$vn\""; + } else { print " " } + print "

    "; +} else { + print "

    ** No domain defined or matching '$subsetDomain' **

    "; +} print "
    \n"; # ---- Protocole (aka 'Informations' of subsetType) @@ -422,116 +424,118 @@ sub getDomainSefrans { # ----------------------------------------------------------------------------- # printdesc (title,suffix,type,name,legacy,[top]) sub printdesc { - my @desc; - my $editCGI = "/cgi-bin/gedit.pl"; - my $go2top = ""; - - my $title = $_[0]; - my $suffix = $GRIDS{"$_[1]_SUFFIX"}; - my $type = $_[2]; - my $name = $_[3]; - my $fileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$type.$name$suffix"; - if ($_[4] ne '' && ! -e $fileDesc) { - my $legacyfileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$_[4]$suffix"; - if (-e $legacyfileDesc) { - copy($legacyfileDesc, $fileDesc); - } - } - if (defined($_[5])) { - $go2top = "  "; - } - - if (-e $fileDesc) { - @desc = readFile($fileDesc); - } - my $htmlcontents = "
       "; - $htmlcontents .= "$__{$title}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= "$go2top

    "; - if ($#desc >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@desc))."

    \n" } - $htmlcontents .= "
    \n"; - - print $htmlcontents; + my @desc; + my $editCGI = "/cgi-bin/gedit.pl"; + my $go2top = ""; + + my $title = $_[0]; + my $suffix = $GRIDS{"$_[1]_SUFFIX"}; + my $type = $_[2]; + my $name = $_[3]; + my $fileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$type.$name$suffix"; + if ($_[4] ne '' && ! -e $fileDesc) { + my $legacyfileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$_[4]$suffix"; + if (-e $legacyfileDesc) { + copy($legacyfileDesc, $fileDesc); + } + } + if (defined($_[5])) { + $go2top = "  "; + } + + if (-e $fileDesc) { + @desc = readFile($fileDesc); + } + my $htmlcontents = "
       "; + $htmlcontents .= "$__{$title}"; + if ($editOK == 1) { $htmlcontents .= "  " } + $htmlcontents .= "$go2top

    "; + if ($#desc >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@desc))."

    \n" } + $htmlcontents .= "
    \n"; + + print $htmlcontents; } # ----------------------------------------------------------------------------- # ---- helper edit grid popup sub geditpopup { - # prepares a list of grid's templates - my @tplates; - my @gt; - push(@gt,"VIEW") if ($admVIEWS); - push(@gt,"PROC,SEFRAN") if ($admPROCS); - my @tmp = glob("$WEBOBS{ROOT_CODE}/tplates/{".join(',',@gt)."}.*"); - foreach my $t (@tmp) { + + # prepares a list of grid's templates + my @tplates; + my @gt; + push(@gt,"VIEW") if ($admVIEWS); + push(@gt,"PROC,SEFRAN") if ($admPROCS); + my @tmp = glob("$WEBOBS{ROOT_CODE}/tplates/{".join(',',@gt)."}.*"); + foreach my $t (@tmp) { if (! -l $t) { - my @conf = readCfg($t); + my @conf = readCfg($t); next if (@conf == 1); # readCfg returns [0] if the file is empty my %G = @conf; - $t =~ s/$WEBOBS{ROOT_CODE}\/tplates\///; - my ($gt,$gn) = split(/\./,$t); - push(@tplates,"$gt|$gn|$G{DESCRIPTION}"); + $t =~ s/$WEBOBS{ROOT_CODE}\/tplates\///; + my ($gt,$gn) = split(/\./,$t); + push(@tplates,"$gt|$gn|$G{DESCRIPTION}"); } - } - - my $SP = ""; - $SP .= "
    "; - $SP .= ""; - $SP .= "

    Create/edit a GRID

    "; - $SP .= ""; - $SP .= " \n"; - $SP .= "

    "; - - $SP .= ""; - $SP .= " \n"; - $SP .= "

    "; - - $SP .= "

    "; - $SP .= ""; - $SP .= ""; - $SP .= "

    "; - $SP .= ""; - return $SP; + } + + my $SP = ""; + $SP .= "
    "; + $SP .= "
    "; + $SP .= "

    Create/edit a GRID

    "; + $SP .= ""; + $SP .= " \n"; + $SP .= "

    "; + + $SP .= ""; + $SP .= " \n"; + $SP .= "

    "; + + $SP .= "

    "; + $SP .= ""; + $SP .= ""; + $SP .= "

    "; + $SP .= "
    "; + return $SP; } # ---- helper edit form popup sub feditpopup { - # prepares a list of form's templates - my $SP = ""; - $SP .= "
    "; - $SP .= "
    "; - $SP .= "

    Create/edit a FORM

    "; - $SP .= ""; - my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; - opendir my $dir, ($tdir) or die "Cannot open directory: $!"; - my @templates = sort grep (/FORM\./, readdir($dir)); - closedir $dir; - $SP .= " "; - $SP .= "

    "; - $SP .= ""; - $SP .= " \n"; - - $SP .= "

    "; - $SP .= ""; - $SP .= ""; - $SP .= "

    "; - $SP .= "
    "; - return $SP; + + # prepares a list of form's templates + my $SP = ""; + $SP .= "
    "; + $SP .= "
    "; + $SP .= "

    Create/edit a FORM

    "; + $SP .= ""; + my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; + opendir my $dir, ($tdir) or die "Cannot open directory: $!"; + my @templates = sort grep (/FORM\./, readdir($dir)); + closedir $dir; + $SP .= " "; + $SP .= "

    "; + $SP .= ""; + $SP .= " \n"; + + $SP .= "

    "; + $SP .= ""; + $SP .= ""; + $SP .= "

    "; + $SP .= "
    "; + return $SP; } __END__ diff --git a/CODE/cgi-bin/mailB3.pl b/CODE/cgi-bin/mailB3.pl index a6e4793f..d3314d5b 100755 --- a/CODE/cgi-bin/mailB3.pl +++ b/CODE/cgi-bin/mailB3.pl @@ -48,21 +48,21 @@ =head1 Query string parameters my $g = $q->param('g'); my $b3 = "$WEBOBS{'ROOT_OUTG'}/$grid/$ts/$g"; if ( -l "$b3.png") { - my $b3png = readlink("$b3.png"); - $b3png =~ s/\.png$//g; - $b3 =~ s/b3/$b3png/g; - $g =~ s/b3/$b3png/g; + my $b3png = readlink("$b3.png"); + $b3png =~ s/\.png$//g; + $b3 =~ s/b3/$b3png/g; + $g =~ s/b3/$b3png/g; } my ($GRIDType, $GRIDName) = split(/\./,$grid); # before continuing, verify consistancy and authorization if (not (clientHasAdm(type=>"authprocs",name=>"$GRIDName"))) { - print_head(); - print("

    $__{'Unauthorized action'}

    \n"); - print_secondary("Sorry, you cannot use this script on $grid. Please contact your administrator."); - print_foot(); - exit(0); + print_head(); + print("

    $__{'Unauthorized action'}

    \n"); + print_secondary("Sorry, you cannot use this script on $grid. Please contact your administrator."); + print_foot(); + exit(0); } my $submit_url = $q->url(); @@ -75,7 +75,7 @@ =head1 Query string parameters ##---- Script functions sub print_head { - print <<__EOD__; + print <<__EOD__; Content-type: text/html @@ -138,69 +138,67 @@ sub print_head { __EOD__ } - sub print_foot { - print <<__EOD__; + print <<__EOD__; __EOD__ } - sub print_form { - my ($y,$m,$d,$id,$evt) = split(/\//,$g); - my ($evt_y,$evt_m,$evt_d,$evt_H,$evt_M,$evt_S,$evt_loc) = unpack("a4a2a2xa2a2a2xa*",$evt); - my $b3_urn = "$WEBOBS{'URN_OUTG'}/$grid/$ts/$g"; - my $evt_email = $P{TRIGGER_EMAIL}; - my $evt_subject = $P{TRIGGER_SUBJECT}; - my $report_email = $P{REPORT_EMAIL}; - my ($evt_latitude,$evt_longitude,$evt_magnitude,$evt_depth,$evt_department,$evt_region); - my $report_file = "$evt.pdf"; - my $report_subject = "$P{REPORT_SUBJECT}"; - my $report_message; - - # reads needed information from the event - my $triggerOK = 1; - my $trigger_check = 'checked'; - my $evt_origin = "$evt_y/$evt_m/$evt_d $evt_H:$evt_M:$evt_S"; - if (-e "$b3.json") { - my %json = %{decode_json(l2u(join("",readFile("$b3.json"))))}; - $evt_latitude = $json{'latitude'}; - $evt_longitude = $json{'longitude'}; - $evt_depth = $json{'depth'}; - $evt_magnitude = $json{'magnitude'}; - $evt_department = l2u($json{'department'}); - $evt_region = l2u($json{'region'}); - - } elsif (-e "$b3.gse") { - my @gse = readFile("$b3.gse"); - $evt_latitude = trim(substr($gse[9],25,9)); - $evt_longitude = trim(substr($gse[9],34,9)); - $evt_depth = trim(substr($gse[9],47,7)); - $evt_magnitude = trim(substr($gse[9],74,4)); - ($evt_region,$evt_department) = split(/ \(|\)/,l2u(trim($gse[12]))); - $evt_department = $P{REGION} if ($evt_department eq ""); - } else { - $triggerOK = 0; - $trigger_check = 'disabled'; - } - my $trigger_content = "Time: $evt_origin\n" - ."Latitude: $evt_latitude\n" - ."Longitude: $evt_longitude\n" - ."Depth: $evt_depth\n" - ."Magnitude: $evt_magnitude\n" - ."Department: $evt_department\n" - ."Region: $evt_region\n"; - - if (-e "$b3.msg") { - my @msg = readFile("$b3.msg"); - $report_message = tex2utf(l2u(join("",@msg))."\n\n$P{REPORT_FOOTNOTE}\n"); - $report_message =~ s/[ ]+/ /g; - } - print_secondary("Sorry, event $evt does not have json or gse file info. Will not be able to send the trigger email.") if (!$triggerOK); + my ($y,$m,$d,$id,$evt) = split(/\//,$g); + my ($evt_y,$evt_m,$evt_d,$evt_H,$evt_M,$evt_S,$evt_loc) = unpack("a4a2a2xa2a2a2xa*",$evt); + my $b3_urn = "$WEBOBS{'URN_OUTG'}/$grid/$ts/$g"; + my $evt_email = $P{TRIGGER_EMAIL}; + my $evt_subject = $P{TRIGGER_SUBJECT}; + my $report_email = $P{REPORT_EMAIL}; + my ($evt_latitude,$evt_longitude,$evt_magnitude,$evt_depth,$evt_department,$evt_region); + my $report_file = "$evt.pdf"; + my $report_subject = "$P{REPORT_SUBJECT}"; + my $report_message; + + # reads needed information from the event + my $triggerOK = 1; + my $trigger_check = 'checked'; + my $evt_origin = "$evt_y/$evt_m/$evt_d $evt_H:$evt_M:$evt_S"; + if (-e "$b3.json") { + my %json = %{decode_json(l2u(join("",readFile("$b3.json"))))}; + $evt_latitude = $json{'latitude'}; + $evt_longitude = $json{'longitude'}; + $evt_depth = $json{'depth'}; + $evt_magnitude = $json{'magnitude'}; + $evt_department = l2u($json{'department'}); + $evt_region = l2u($json{'region'}); + + } elsif (-e "$b3.gse") { + my @gse = readFile("$b3.gse"); + $evt_latitude = trim(substr($gse[9],25,9)); + $evt_longitude = trim(substr($gse[9],34,9)); + $evt_depth = trim(substr($gse[9],47,7)); + $evt_magnitude = trim(substr($gse[9],74,4)); + ($evt_region,$evt_department) = split(/ \(|\)/,l2u(trim($gse[12]))); + $evt_department = $P{REGION} if ($evt_department eq ""); + } else { + $triggerOK = 0; + $trigger_check = 'disabled'; + } + my $trigger_content = "Time: $evt_origin\n" + ."Latitude: $evt_latitude\n" + ."Longitude: $evt_longitude\n" + ."Depth: $evt_depth\n" + ."Magnitude: $evt_magnitude\n" + ."Department: $evt_department\n" + ."Region: $evt_region\n"; + + if (-e "$b3.msg") { + my @msg = readFile("$b3.msg"); + $report_message = tex2utf(l2u(join("",@msg))."\n\n$P{REPORT_FOOTNOTE}\n"); + $report_message =~ s/[ ]+/ /g; + } + print_secondary("Sorry, event $evt does not have json or gse file info. Will not be able to send the trigger email.") if (!$triggerOK); - print <<__EOD__; + print <<__EOD__; "; if ($displayOnly ne 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."" - ."\n" - ."" - ."" - .""; + ."\n" + ."" + ."" + .""; $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - $i++; - if ($rap[$i] == 1) { - $entete = $entete.""; - } + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + $i++; + if ($rap[$i] == 1) { + $entete = $entete.""; + } } - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split(/\|/,$_); - if ($hr1 ne "") { $date1 = "$date1 $hr1"; } - if ($hr2 ne "") { $date2 = "$date2 $hr2"; } - if ($i eq 0) { - push(@csv,u2l("$date1;$date2;Nb jours;Code Site;$site;$h2o;$koh;Masse;$cCl;$cCO2;$cSO4;\"$rem\";$val")); - } - elsif (($id ne "") - && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date1,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date1 lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date1,5,2)))) { - - my ($cCl_mmol,$cCO2_mmol,$cSO4_mmol) = split(/\|/,""); - if ($cCl ne "") { $cCl_mmol = sprintf($fmt,$cCl/$GMOL{Cl}); }; - if ($cCO2 ne "") { $cCO2_mmol = sprintf($fmt,$cCO2/$GMOL{CO2}); }; - if ($cSO4 ne "") { $cSO4_mmol = sprintf($fmt,$cSO4/$GMOL{SO4}); }; - - my $mtot; - if ($m1 ne "") { $mtot = sprintf("%1.2f",$m1 + $m2 + $m3 + $m4); } - - my $nj = (qx(date -d "$date2" +%s) - qx(date -d "$date1" +%s))/86400; - my $f_H2O; - my $f_Cl; - my $f_C; - my $f_S; - if (($nj != 0) && ($mtot > 0)) { - $f_H2O = sprintf("%1.2f",($mtot - ($h2o + $GMOL{KOH}*$koh*$h2o/1000))/$nj); - if ($cCl > 0) { $f_Cl = sprintf("%1.3f",$f_H2O/1e6*$cCl); } - if ($cCO2 > 0) { $f_C = sprintf("%1.3f",$f_H2O/1e6*$cCO2*12/44); } - if ($cSO4 > 0) { $f_S = sprintf("%1.3f",$f_H2O/1e6*$cSO4*32/96); } - } - my @rapv; - my $iv = 0; - my $rapport = ""; - - for (@rapports) { - my ($num,$den,$nrp) = split(/\|/,$_); - $iv++; - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - if ($rap[$iv] == 1) { - $rapport = $rapport.""; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($displayOnly ne 1) { - $texte = $texte.""; - } - $texte = $texte."" - .""; - $tcsv = "$date1;$date2;$nj;$site;$aliasSite;$h2o;$koh;$mtot;"; - if ($QryParm->{'unite'} eq "mmol") { - $texte = $texte.""; - $tcsv = $tcsv."$cCl_mmol;$cCO2_mmol;$cSO4_mmol;"; - } else { - $texte = $texte.""; - $tcsv = $tcsv."$cCl;$cCO2;$cSO4;"; - } - $texte = $texte."$rapport\n"; - $tcsv = $tcsv."\"$rem\"\n"; - push(@csv,u2l($tcsv)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split(/\|/,$_); + if ($hr1 ne "") { $date1 = "$date1 $hr1"; } + if ($hr2 ne "") { $date2 = "$date2 $hr2"; } + if ($i eq 0) { + push(@csv,u2l("$date1;$date2;Nb jours;Code Site;$site;$h2o;$koh;Masse;$cCl;$cCO2;$cSO4;\"$rem\";$val")); + } + elsif (($id ne "") + && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date1,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date1 lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date1,5,2)))) { + + my ($cCl_mmol,$cCO2_mmol,$cSO4_mmol) = split(/\|/,""); + if ($cCl ne "") { $cCl_mmol = sprintf($fmt,$cCl/$GMOL{Cl}); }; + if ($cCO2 ne "") { $cCO2_mmol = sprintf($fmt,$cCO2/$GMOL{CO2}); }; + if ($cSO4 ne "") { $cSO4_mmol = sprintf($fmt,$cSO4/$GMOL{SO4}); }; + + my $mtot; + if ($m1 ne "") { $mtot = sprintf("%1.2f",$m1 + $m2 + $m3 + $m4); } + + my $nj = (qx(date -d "$date2" +%s) - qx(date -d "$date1" +%s))/86400; + my $f_H2O; + my $f_Cl; + my $f_C; + my $f_S; + if (($nj != 0) && ($mtot > 0)) { + $f_H2O = sprintf("%1.2f",($mtot - ($h2o + $GMOL{KOH}*$koh*$h2o/1000))/$nj); + if ($cCl > 0) { $f_Cl = sprintf("%1.3f",$f_H2O/1e6*$cCl); } + if ($cCO2 > 0) { $f_C = sprintf("%1.3f",$f_H2O/1e6*$cCO2*12/44); } + if ($cSO4 > 0) { $f_S = sprintf("%1.3f",$f_H2O/1e6*$cSO4*32/96); } + } + my @rapv; + my $iv = 0; + my $rapport = ""; + + for (@rapports) { + my ($num,$den,$nrp) = split(/\|/,$_); + $iv++; + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + if ($rap[$iv] == 1) { + $rapport = $rapport.""; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($displayOnly ne 1) { + $texte = $texte.""; + } + $texte = $texte."" + .""; + $tcsv = "$date1;$date2;$nj;$site;$aliasSite;$h2o;$koh;$mtot;"; + if ($QryParm->{'unite'} eq "mmol") { + $texte = $texte.""; + $tcsv = $tcsv."$cCl_mmol;$cCO2_mmol;$cSO4_mmol;"; + } else { + $texte = $texte.""; + $tcsv = $tcsv."$cCl;$cCO2;$cSO4;"; + } + $texte = $texte."$rapport\n"; + $tcsv = $tcsv."\"$rem\"\n"; + push(@csv,u2l($tcsv)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"

    Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
    ", - "Sites sélectionnés: $afficheSite
    ", - "Unité des concentrations ioniques: $unite
    ", - "Nombre de données affichées = $nbLignesRetenues / $nbData.

    \n", - "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}&unite=$QryParm->{'unite'}\">$fileCSV

    \n"); + "Sites sélectionnés: $afficheSite
    ", + "Unité des concentrations ioniques: $unite
    ", + "Nombre de données affichées = $nbLignesRetenues / $nbData.

    \n", + "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}&unite=$QryParm->{'unite'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"

    $__{'Send felt earthquake report information'}

    $__{'Event origin'}: $evt_y-$evt_m-$evt_d $evt_H:$evt_M:$evt_S UT

    @@ -341,11 +339,10 @@ sub print_form { __EOD__ } - sub print_alert { my $alert_class = shift; - my $msg = join(" ", @_); - print <<__EOD__; + my $msg = join(" ", @_); + print <<__EOD__;

    $msg

    @@ -353,63 +350,63 @@ sub print_alert { } sub print_success { - return print_alert("alert-success", @_); + return print_alert("alert-success", @_); } sub print_error { - return print_alert("alert-error", @_); + return print_alert("alert-error", @_); } sub print_secondary { - return print_alert("alert-secondary", @_); + return print_alert("alert-secondary", @_); } - ##---- Main script # Print first part of the page print_head(); if ($q->param('send_trigger') eq '' and $q->param('send_report') eq '') { - # No action provided (from the form): simply print the form - print_form(); + + # No action provided (from the form): simply print the form + print_form(); } else { - print "

    $__{'Sending emails'}

    \n"; - my $replyto = "export REPLYTO=$operator_email"; - - # send trigger email - if ($q->param('send_trigger')) { - my $mail_address = $q->param('trigger_email'); - my $mail_subject = $q->param('trigger_subject'); - my $mail_content = "Time: ".$q->param('event_time')."\n" - ."Latitude: ".$q->param('event_latitude')."\n" - ."Longitude: ".$q->param('event_longitude')."\n" - ."Depth: ".$q->param('event_depth')."\n" - ."Magnitude: ".$q->param('event_magnitude')."\n" - ."Department: ".u2l($q->param('event_department'))."\n" - ."Region: ".u2l($q->param('event_region'))."\n"; - my $cmd = "$replyto;echo \"$mail_content\" | mutt -s \"$mail_subject\" $mutt_options $mail_address $operator_email"; - if ( ! system($cmd) ) { - print_success($__{'Trigger email has been successfully sent!'}); - } else { - print_error($__{'Sorry, an error occured during report email sending. Please contact an administator.'}); + print "

    $__{'Sending emails'}

    \n"; + my $replyto = "export REPLYTO=$operator_email"; + + # send trigger email + if ($q->param('send_trigger')) { + my $mail_address = $q->param('trigger_email'); + my $mail_subject = $q->param('trigger_subject'); + my $mail_content = "Time: ".$q->param('event_time')."\n" + ."Latitude: ".$q->param('event_latitude')."\n" + ."Longitude: ".$q->param('event_longitude')."\n" + ."Depth: ".$q->param('event_depth')."\n" + ."Magnitude: ".$q->param('event_magnitude')."\n" + ."Department: ".u2l($q->param('event_department'))."\n" + ."Region: ".u2l($q->param('event_region'))."\n"; + my $cmd = "$replyto;echo \"$mail_content\" | mutt -s \"$mail_subject\" $mutt_options $mail_address $operator_email"; + if ( ! system($cmd) ) { + print_success($__{'Trigger email has been successfully sent!'}); + } else { + print_error($__{'Sorry, an error occured during report email sending. Please contact an administator.'}); + } } - } - # send report email - if ($q->param('send_report')) { - my $mail_address = $q->param('report_email'); - my $mail_subject = u2l($q->param('report_subject')); - my $mail_content = u2l($q->param('report_message')); - my $mail_attach = $q->param('report_file'); - my $cmd = "$replyto;echo \"$mail_content\" | mutt -s \"$mail_subject\" -a \"$mail_attach\" -b \"$mail_address\" $mutt_options -- $operator_email"; - if ( ! system($cmd) ) { - print_success($__{'Report email has been successfully sent!'}); - } else { - print_error($__{'Sorry, an error occured during report email sending. Please contact an administator.'}); + # send report email + if ($q->param('send_report')) { + my $mail_address = $q->param('report_email'); + my $mail_subject = u2l($q->param('report_subject')); + my $mail_content = u2l($q->param('report_message')); + my $mail_attach = $q->param('report_file'); + my $cmd = "$replyto;echo \"$mail_content\" | mutt -s \"$mail_subject\" -a \"$mail_attach\" -b \"$mail_address\" $mutt_options -- $operator_email"; + if ( ! system($cmd) ) { + print_success($__{'Report email has been successfully sent!'}); + } else { + print_error($__{'Sorry, an error occured during report email sending. Please contact an administator.'}); + } } - } } diff --git a/CODE/cgi-bin/mailInfo_OVPF.pl b/CODE/cgi-bin/mailInfo_OVPF.pl index 004e3192..995e0a4f 100755 --- a/CODE/cgi-bin/mailInfo_OVPF.pl +++ b/CODE/cgi-bin/mailInfo_OVPF.pl @@ -58,6 +58,7 @@ use Locale::TextDomain('webobs'); set_message(\&webobs_cgi_msg); + #my $old_locale = setlocale(LC_NUMERIC); #setlocale(LC_NUMERIC,'C'); @@ -106,7 +107,7 @@ my $debug; if ($valParams =~ /debug/) { - $debug = $cgi->url_param('debug'); + $debug = $cgi->url_param('debug'); } my $dateStart = $cgi->url_param('dateStart'); @@ -130,7 +131,7 @@ my @comments_geodesy = $cgi->url_param('comment_geodesy'); my $comments_geochemistry = $cgi->url_param('comment_geochemistry'); if ($comments_geochemistry eq "") { - $comments_geochemistry = "Géochimie non renseignée."; + $comments_geochemistry = "Géochimie non renseignée."; } my @mail = $cgi->url_param('mail'); @@ -149,8 +150,8 @@ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (($dateStart ne $dateEnd || $yesterday ne $dateEnd) && !defined($send)) { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -166,235 +167,238 @@ PART1 } elsif (defined($send)) { - my $html; - #my $outputFilename = '/tmp/bulletin.html'; - my $outputFilename = '/home/sysop/bulletin/bulletin.html'; - my $htmlOutput = ""; - my $htmlBrowser = ""; - my $htmlMail = ""; - my %alerts; - for (@typeAlerts) { - my @liste = split(/\|/,$_); - $alerts{$liste[0]} = $liste[1]; - } - my %geodesy; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - $geodesy{$liste[0]} = $liste[2]; + my $html; + + #my $outputFilename = '/tmp/bulletin.html'; + my $outputFilename = '/home/sysop/bulletin/bulletin.html'; + my $htmlOutput = ""; + my $htmlBrowser = ""; + my $htmlMail = ""; + my %alerts; + for (@typeAlerts) { + my @liste = split(/\|/,$_); + $alerts{$liste[0]} = $liste[1]; + } + my %geodesy; + for (@commentsGeodesy) { + my @liste = split(/\|/,$_); + $geodesy{$liste[0]} = $liste[2]; + } + + print $cgi->header(-charset=>'utf-8'); + + $html = ''; + $html .= ''; + $html .= ' '; + $html .= ' '; + $html .= ' Bulletin d\'information'; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= " "; + $htmlBrowser .= " "; + + #$htmlBrowser .= " "; + $htmlBrowser .= " "; + $html = ' '; + $html .= ' '; + $html .= '
    '; + $html .= '

    Observatoire Volcanologique du Piton de La Fournaise

    '; + $html .= '
    '; + $html .= ' '; + $html .= '
    '; + $html .= '
    '; + $html .= "

    $timePeriodHTML

    "; + my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); + $html .= "

    Bulletin créé le $dateBulletin TU.

    "; + $html .= "

    Ce bulletin est issu de l'examen préliminaire quotidien des dernières données. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
    Pour une information complète, veuillez vous reporter aux derniers bulletins mensuels validés de l'observatoire.

    "; + $html .= '
    '; + $html .= '

    '; + $html .= ' Piton de la Fournaise
    '; + $html .= ' 21°14\'38" S
    '; + $html .= ' 55°42\'29" E
    '; + $html .= ' Altitude : 2632m
    '; + $html .= '

    '; + $html .= '
    '; + $html .= '

    '; + $html .= " Niveau d'alerte : $alerts{$alert}"; + $html .= '

    '; + $html .= '
    '; + my %zones; + for (@typeZones) { + my @liste = split(/\|/,$_); + $zones{$liste[0]} = $liste[1]; + } + $html .= '

    Sismologie

    '; + + my $subject = "[ovpf_bulletin] $timePeriod"; + $html .= "

    - Nombre d'éboulements du $dateEndFrench : $comptabilisesRockfall
    "; + if($#zones_rockfall >= 0) { + if($#zones_rockfall == 0) { + $html .= "Zone concernée par les éboulements :
    "; + } else { + $html .= "Zones concernées par les éboulements :
    "; } - - print $cgi->header(-charset=>'utf-8'); - - $html = ''; - $html .= ''; - $html .= ' '; - $html .= ' '; - $html .= ' Bulletin d\'information'; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlBrowser .= " "; - #$htmlBrowser .= " "; - $htmlBrowser .= " "; - $html = ' '; - $html .= ' '; - $html .= '

    '; - $html .= '

    Observatoire Volcanologique du Piton de La Fournaise

    '; - $html .= '
    '; - $html .= ' '; - $html .= '
    '; - $html .= '
    '; - $html .= "

    $timePeriodHTML

    "; - my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); - $html .= "

    Bulletin créé le $dateBulletin TU.

    "; - $html .= "

    Ce bulletin est issu de l'examen préliminaire quotidien des dernières données. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
    Pour une information complète, veuillez vous reporter aux derniers bulletins mensuels validés de l'observatoire.

    "; - $html .= '
    '; - $html .= '

    '; - $html .= ' Piton de la Fournaise
    '; - $html .= ' 21°14\'38" S
    '; - $html .= ' 55°42\'29" E
    '; - $html .= ' Altitude : 2632m
    '; - $html .= '

    '; - $html .= '
    '; - $html .= '

    '; - $html .= " Niveau d'alerte : $alerts{$alert}"; - $html .= '

    '; - $html .= '
    '; - my %zones; - for (@typeZones) { - my @liste = split(/\|/,$_); - $zones{$liste[0]} = $liste[1]; + $html .= "
      "; + for (@zones_rockfall) { + $html .= "
    • $zones{$_}
      • "; + } + $html .= "
    "; + $html .= "

    "; + } + $html .= "

    - Nombre de séismes volcano-tectoniques (VT) du $dateEndFrench : $comptabilisesVT
    "; + if($#zones_vt >= 0) { + if($#zones_vt == 0) { + $html .= "Zone concernée par les VT :
    "; + } else { + $html .= "Zones concernées par les VT :
    "; } - $html .= '

    Sismologie

    '; - - my $subject = "[ovpf_bulletin] $timePeriod"; - $html .= "

    - Nombre d'éboulements du $dateEndFrench : $comptabilisesRockfall
    "; - if($#zones_rockfall >= 0) { - if($#zones_rockfall == 0) { - $html .= "Zone concernée par les éboulements :
    "; - } else { - $html .= "Zones concernées par les éboulements :
    "; - } - $html .= "

      "; - for (@zones_rockfall) { - $html .= "
    • $zones{$_}
      • "; - } - $html .= "
    "; - $html .= "

    "; - } - $html .= "

    - Nombre de séismes volcano-tectoniques (VT) du $dateEndFrench : $comptabilisesVT
    "; - if($#zones_vt >= 0) { - if($#zones_vt == 0) { - $html .= "Zone concernée par les VT :
    "; - } else { - $html .= "Zones concernées par les VT :
    "; - } - $html .= "

      "; - for (@zones_vt) { - $html .= "
    • $zones{$_}
      • "; - } - $html .= "
    "; - $html .= "

    "; - } - $html .= "

    - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
    "; - $html .= "

      "; - $html .= "
    • Durée : $stat_max_duration s
      • "; - $html .= "
    • Magnitude de durée : $stat_max_magnitude
      • "; - $html .= "
    "; - $html .= "

    - Nombre de séismes locaux (en dehors du massif du Piton de la Fournaise) du $dateEndFrench : $comptabilisesLOC

    "; - $html .= "

    - Séisme local de plus grande magnitude du $dateEndFrench :
    "; - $html .= "

      "; - $html .= "
    • Durée : $stat_max_duration_loc s
      • "; - $html .= "
    • Magnitude de durée : $stat_max_magnitude_loc
      • "; - $html .= "
    "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ""; - $htmlBrowser .= ""; - $html = "

    "; - $htmlMail .= $html; - $html .= "

    "; - $html .= "Carte de localisation (épicentres) et coupes nord-ouest - sud-est et sud-ouest - nord-est (montrant la localisation en profondeur, hypocentres) des séismes enregistrés et localisés par l'OVPF-IPGP sur 2 mois sous La Réunion. Seuls les séismes localisables ont été représentés sur la carte.
    "; - $html .= "L'observatoire enregistre des évènements sismiques non représentés sur cette carte car non localisables, en raison de leur trop faible magnitude.
    Pour prendre connaissance du nombre de séismes détectés par les réseaux de l'observatoire, vous pouvez vous reporter à son dernier bulletin mensuel.
    "; - $html .= "La sismicité déterminée et validée en continu par l'OVPF-IPGP peut être également suivie sur le portail RENASS."; - $html .= "

    "; - $html .= '
    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

    Déformations

    "; - for (@comments_geodesy) { - $html .= " - $geodesy{$_}

    "; + $html .= "

      "; + for (@zones_vt) { + $html .= "
    • $zones{$_}
      • "; } - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlOutput .= "
      "; - $htmlBrowser .= "
      "; - $html = "

      "; - $htmlMail .= $html; - $html .= "

      "; - $html .= "Illustration de la déformation sur 1 an. Sont ici représentées des lignes de base (variation de distance entre deux récepteurs GPS) traversant l'édifice du Piton de la Fournaise, au sommet (en haut), à la base du cône terminal (au milieu) et en champ lointain (en bas) (cf. localisation sur les cartes associées). Une hausse est synonyme d'élongation et donc de gonflement du volcan ; inversement une diminution est synonyme de contraction et donc de dégonflement du volcan. Les éventuelles périodes coloriées en rose clair correspondent aux éruptions."; + $html .= "

    "; $html .= "

    "; - $html .= '
    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

    Géochimie

    "; - $comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); - $comments_geochemistry =~ s;\n;
    ;g; - $html .= "

    $comments_geochemistry

    "; - if ($comment ne "") { - $html .= "

    Informations complémentaires

    "; - $comment = encode_entities(decode('utf8', $comment)); - $comment =~ s;\n;
    ;g; - $html .= "

    $comment

    "; - } - $html .= '
    '; - $html .= "

    Glossaire

    "; - $html .= "

    + } + $html .= "

    - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
    "; + $html .= "

      "; + $html .= "
    • Durée : $stat_max_duration s
      • "; + $html .= "
    • Magnitude de durée : $stat_max_magnitude
      • "; + $html .= "
    "; + $html .= "

    - Nombre de séismes locaux (en dehors du massif du Piton de la Fournaise) du $dateEndFrench : $comptabilisesLOC

    "; + $html .= "

    - Séisme local de plus grande magnitude du $dateEndFrench :
    "; + $html .= "

      "; + $html .= "
    • Durée : $stat_max_duration_loc s
      • "; + $html .= "
    • Magnitude de durée : $stat_max_magnitude_loc
      • "; + $html .= "
    "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ""; + $htmlBrowser .= ""; + $html = "

    "; + $htmlMail .= $html; + $html .= "

    "; + $html .= "Carte de localisation (épicentres) et coupes nord-ouest - sud-est et sud-ouest - nord-est (montrant la localisation en profondeur, hypocentres) des séismes enregistrés et localisés par l'OVPF-IPGP sur 2 mois sous La Réunion. Seuls les séismes localisables ont été représentés sur la carte.
    "; + $html .= "L'observatoire enregistre des évènements sismiques non représentés sur cette carte car non localisables, en raison de leur trop faible magnitude.
    Pour prendre connaissance du nombre de séismes détectés par les réseaux de l'observatoire, vous pouvez vous reporter à son dernier bulletin mensuel.
    "; + $html .= "La sismicité déterminée et validée en continu par l'OVPF-IPGP peut être également suivie sur le portail RENASS."; + $html .= "

    "; + $html .= '
    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

    Déformations

    "; + for (@comments_geodesy) { + $html .= " - $geodesy{$_}

    "; + } + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= " "; + $htmlOutput .= "
    "; + $htmlBrowser .= "
    "; + $html = "

    "; + $htmlMail .= $html; + $html .= "

    "; + $html .= "Illustration de la déformation sur 1 an. Sont ici représentées des lignes de base (variation de distance entre deux récepteurs GPS) traversant l'édifice du Piton de la Fournaise, au sommet (en haut), à la base du cône terminal (au milieu) et en champ lointain (en bas) (cf. localisation sur les cartes associées). Une hausse est synonyme d'élongation et donc de gonflement du volcan ; inversement une diminution est synonyme de contraction et donc de dégonflement du volcan. Les éventuelles périodes coloriées en rose clair correspondent aux éruptions."; + $html .= "

    "; + $html .= '
    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

    Géochimie

    "; + $comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); + $comments_geochemistry =~ s;\n;
    ;g; + $html .= "

    $comments_geochemistry

    "; + if ($comment ne "") { + $html .= "

    Informations complémentaires

    "; + $comment = encode_entities(decode('utf8', $comment)); + $comment =~ s;\n;
    ;g; + $html .= "

    $comment

    "; + } + $html .= '
    '; + $html .= "

    Glossaire

    "; + $html .= "

    - Séisme volcano-tectonique sommital : séisme localisé au dessus du niveau de la mer à l'aplomb du sommet du volcan.
    - Séisme volcano-tectonique profond : séisme localisé sous le niveau de la mer à l'aplomb du volcan.
    - Séisme local : séisme localisé dans un rayon de 200km de l'île.
    - Signaux GPS sommitaux: témoin de l'influence de sources de pression superficielles à l'aplomb du volcan.
    - Signaux GPS lointains: témoin de l'influence de sources de pression profondes à l'aplomb du volcan.

    "; - $html .= "
    "; - $html .= "
    "; - $html .= " "; - $html .= ""; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - - print "$htmlBrowser"; - - print "Debut ECRITURE BULLETIN"; - #open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; - open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; - print $fh $htmlOutput; - close $fh; - print "Fin ECRITURE BULLETIN"; - -# print "Envoie du mail"; - - my $from = $MC3{MAIL_FROM}; - my $smtpServer = $MC3{MAIL_SMTP_SERVER}; - my $smtpPort = $MC3{MAIL_SMTP_PORT}; - my $user = $MC3{MAIL_USER}; - my $passwd = $MC3{MAIL_PASSWD}; - - my $mailList = ''; - my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); - for (@mailConf) { - my @liste = split(/\|/,$_); - my %hash; - @hash{@mail}=(); - if (exists $hash{$liste[0]}){ - if ($mailList eq '') { - $mailList = $mailList.$liste[4] - } else { - $mailList = $mailList.','.$liste[4] - } - } - } - - my $message = Email::MIME->create_html( - header => [ - From => $from, - 'Reply-To' => $from, - Subject => $subject, - Type => 'text/html; charset=UTF-8', - ], - body => $htmlMail, - ); - - my @mailingList = split(/,/,$mailList); - for(@mailingList) { - if($MC3{MAIL_USE_SMTP}) { - my $transport = Email::Sender::Transport::SMTP::TLS->new( - host => $smtpServer, - port => $smtpPort, - username => $user, - password => $passwd, - ); - sendmail($message, { from => $from, to => $_, transport => $transport}); - } else { - sendmail($message, { from => $from, to => $_}); - } - } + $html .= "
    "; + $html .= "
    "; + $html .= " "; + $html .= ""; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + print "$htmlBrowser"; + + print "Debut ECRITURE BULLETIN"; + +#open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; + open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; + print $fh $htmlOutput; + close $fh; + print "Fin ECRITURE BULLETIN"; + + # print "Envoie du mail"; + + my $from = $MC3{MAIL_FROM}; + my $smtpServer = $MC3{MAIL_SMTP_SERVER}; + my $smtpPort = $MC3{MAIL_SMTP_PORT}; + my $user = $MC3{MAIL_USER}; + my $passwd = $MC3{MAIL_PASSWD}; + + my $mailList = ''; + my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); + for (@mailConf) { + my @liste = split(/\|/,$_); + my %hash; + @hash{@mail}=(); + if (exists $hash{$liste[0]}){ + if ($mailList eq '') { + $mailList = $mailList.$liste[4] + } else { + $mailList = $mailList.','.$liste[4] + } + } + } + + my $message = Email::MIME->create_html( + header => [ + From => $from, + 'Reply-To' => $from, + Subject => $subject, + Type => 'text/html; charset=UTF-8', + ], + body => $htmlMail, + ); + + my @mailingList = split(/,/,$mailList); + for(@mailingList) { + if($MC3{MAIL_USE_SMTP}) { + my $transport = Email::Sender::Transport::SMTP::TLS->new( + host => $smtpServer, + port => $smtpPort, + username => $user, + password => $passwd, + ); + sendmail($message, { from => $from, to => $_, transport => $transport}); + } else { + sendmail($message, { from => $from, to => $_}); + } + } } else { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -425,12 +429,12 @@

    Nombre d'éboulements : $comptabilisesRockfall

    @@ -438,24 +442,24 @@

    PART2 - for (@typeZones) { - my @liste = split(/\|/,$_); - print "$liste[1]\n"; - } + for (@typeZones) { + my @liste = split(/\|/,$_); + print "$liste[1]\n"; + } - print <<"PART3"; + print <<"PART3";

    Nombre de séismes volcano-tectoniques (VT) : $comptabilisesVT

    Zone(s) concernée(s) par les VT :

    PART3 - for (@typeZones) { - my @liste = split(/\|/,$_); - print "$liste[1]\n"; - } + for (@typeZones) { + my @liste = split(/\|/,$_); + print "$liste[1]\n"; + } - print <<"PART4"; + print <<"PART4";

    VT principal:

    @@ -475,52 +479,52 @@

    PART4 - print <<"PART51"; + print <<"PART51";

    Commentaire geodesie:

    PART51 - my $category = -1; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - if ($category != $liste[3]) { - if ($category != -1) { - print ""; - } - print ""; + } + print "

    PART52 - print <<"PART61"; + print <<"PART61";

    Commentaire geochimie:

    PART61 - print <<"PART7"; + print <<"PART7";

    Informations complémentaires :

    Destinataires :

    PART7 - my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); - for (@mails) { - my @liste = split(/\|/,$_); - if ($liste[3] == 1) { - if ($liste[2] == 1) { - print "$liste[1]
    \n"; - } else { - print "$liste[1]
    \n"; - } - } - } - - print <<"PART5"; + my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); + for (@mails) { + my @liste = split(/\|/,$_); + if ($liste[3] == 1) { + if ($liste[2] == 1) { + print "$liste[1]
    \n"; + } else { + print "$liste[1]
    \n"; + } + } + } + + print <<"PART5"; diff --git a/CODE/cgi-bin/mailInfo_REVOSIMA.pl b/CODE/cgi-bin/mailInfo_REVOSIMA.pl index 696d0ad0..554cec01 100755 --- a/CODE/cgi-bin/mailInfo_REVOSIMA.pl +++ b/CODE/cgi-bin/mailInfo_REVOSIMA.pl @@ -48,6 +48,7 @@ use Switch; set_message(\&webobs_cgi_msg); + #my $old_locale = setlocale(LC_NUMERIC); #setlocale(LC_NUMERIC,'C'); @@ -96,7 +97,7 @@ my $debug; if ($valParams =~ /debug/) { - $debug = $cgi->url_param('debug'); + $debug = $cgi->url_param('debug'); } my $dateStart = $cgi->url_param('dateStart'); @@ -171,7 +172,7 @@ my @comments_geodesy = $cgi->url_param('comment_geodesy'); my $comments_geochemistry = $cgi->url_param('comment_geochemistry'); if ($comments_geochemistry eq "") { - $comments_geochemistry = "Géochimie non renseignée."; + $comments_geochemistry = "Géochimie non renseignée."; } my @mail = $cgi->url_param('mail'); @@ -190,8 +191,8 @@ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (($dateStart ne $dateEnd || $yesterday ne $dateEnd) && !defined($send)) { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -207,36 +208,36 @@ PART1 } elsif (defined($send)) { - my $html; - my $outputFilename = '/opt/php/bulletin/bulletin.html'; - my $htmlOutput = ""; - my $htmlBrowser = ""; - my $htmlMail = ""; - my %alerts; - for (@typeAlerts) { - my @liste = split(/\|/,$_); - $alerts{$liste[0]} = $liste[1]; - } - my %geodesy; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - $geodesy{$liste[0]} = $liste[2]; - } + my $html; + my $outputFilename = '/opt/php/bulletin/bulletin.html'; + my $htmlOutput = ""; + my $htmlBrowser = ""; + my $htmlMail = ""; + my %alerts; + for (@typeAlerts) { + my @liste = split(/\|/,$_); + $alerts{$liste[0]} = $liste[1]; + } + my %geodesy; + for (@commentsGeodesy) { + my @liste = split(/\|/,$_); + $geodesy{$liste[0]} = $liste[2]; + } - print $cgi->header(-charset=>'utf-8'); - - $html = ''; - $html .= ''; - $html .= ' '; - $html .= ' '; - $html .= ' Bulletin d\'information'; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlBrowser .= " "; - $htmlBrowser .= " "; - $html = ' '; - $html .= ' '; - $html .= ' '; - $html .= '

    '; - $html .= '

    Réseau de surveillance Volcanologique et Sismologique de Mayotte

    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $html = '
    '; - $html .= ' '; - $html .= '
    '; - $html .= "

    $timePeriodHTML

    "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); - $html = "

    Bulletin créé le $dateBulletin TU.

    "; - $html .= "

    Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
    Pour une information complète, veuillez vous reporter aux actualités du réseau validées.

    "; - $html .= '
    '; - $html .= '

    Activité

    '; - $html .= '

    '; - $html .= ' Evènement en cours : activité sismique en cours entre 5 et 50 km l\'Est de Mayotte et émissions de fluides sur la zone du Fer à Cheval. Dernière activité sous-marine obsersée au niveau du volcan Fani Maoré le 18/01/2021 lors de la campagne MAYOBS17.'; - $html .= '

    '; - $html .= '

    '; - $html .= " Arrêt probable de l\'éruption. Aucune hypothèse n\'est pour l\'instant écartée quant à l\'évolution de la situation à venir (arrêt définitif, reprise de l'activité éruptive sur le même site, reprise de l'activité éruptive sur un autre site), compte tenu de l\'activité sismique persistante et d\'émissions de fluides localisées dans la zone du Fer à Cheval."; - $html .= '

    '; - $html .= '

    '; - $html .= " Edifice principal
    "; - $html .= ' Latitude : -12°54\' ; longitude : 45°43\'
    '; - $html .= ' Hauteur : au moins 800 m
    '; - $html .= ' Profondeur à la base du site éruptif : -3500 m
    '; - $html .= '

    '; - $html .= '
    '; - $html .= '

    '; - $html .= " Niveau d'alerte : $alerts{$alert}"; - $html .= '

    '; - $html .= '
    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - #$htmlOutput .= ' '; - #$htmlBrowser .= ' '; - $html = '

    Sismologie

    '; - - my $subject = "[revosima_bulletin] $timePeriod"; - $html .= "

    - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

    "; - $html .= "

    - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

    "; - $html .= "

    - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

    "; - $html .= "

    - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
    "; - $html .= "

      "; - $html .= "
    • Durée : $stat_max_duration s
      • "; - $html .= "
    • Magnitude (MLv) : $stat_max_magnitude
      • "; - $html .= "

    "; - $html .= "

    - Dernier séisme ressenti :
    "; - $html .= "

      "; - $html .= "
    • Date : $date_felt
      • "; - $html .= "
    • Magnitude (MLv) : $magnitude_felt
      • "; - $html .= "
    • Profondeur : $depth_felt km
      • "; - $html .= "
    • Localisation : $loc_felt
      • "; - $html .= "

    "; - $html .= "

    Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

    "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ""; - $htmlBrowser .= ""; - $html = "

    "; - $htmlMail .= $html; - $html .= "

    "; - $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, ITES) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA
    "; - $html .= "La sismicité déterminée et validée en continu par le REVOSIMA peut être également suivie sur le portail RENASS."; - $html .= "

    "; - $html .= '
    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

    Déformations

    "; - for (@comments_geodesy) { - $html .= " - $geodesy{$_}

    "; - } - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= "
    "; - $htmlBrowser .= "
    "; - $html = "

    "; - $htmlMail .= $html; - $html .= "

    "; - $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; - $html .= "

    "; - $html .= '
    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = ""; - $html .= "

    Géochimie

    "; - $comments_geochemistry = encode_entities(decode('utf-8', $comments_geochemistry)); - $comments_geochemistry =~ s;\n;
    ;g; - $html .= "

    $comments_geochemistry

    "; - if ($comment ne "") { - $html .= "

    Informations complémentaires

    "; - $comment = encode_entities(decode('utf-8', $comment)); - $comment =~ s;\n;
    ;g; - $html .= "

    $comment

    "; - } - $html .= '
    '; - $html .= "

    Contexte


    "; - $html .= "

    + $html .= ' '; + $html .= ' '; + $html .= '

    '; + $html .= '

    Réseau de surveillance Volcanologique et Sismologique de Mayotte

    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $html = '
    '; + $html .= ' '; + $html .= '
    '; + $html .= "

    $timePeriodHTML

    "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); + $html = "

    Bulletin créé le $dateBulletin TU.

    "; + $html .= "

    Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
    Pour une information complète, veuillez vous reporter aux actualités du réseau validées.

    "; + $html .= '
    '; + $html .= '

    Activité

    '; + $html .= '

    '; + $html .= ' Evènement en cours : activité sismique en cours entre 5 et 50 km l\'Est de Mayotte et émissions de fluides sur la zone du Fer à Cheval. Dernière activité sous-marine obsersée au niveau du volcan Fani Maoré le 18/01/2021 lors de la campagne MAYOBS17.'; + $html .= '

    '; + $html .= '

    '; + $html .= " Arrêt probable de l\'éruption. Aucune hypothèse n\'est pour l\'instant écartée quant à l\'évolution de la situation à venir (arrêt définitif, reprise de l'activité éruptive sur le même site, reprise de l'activité éruptive sur un autre site), compte tenu de l\'activité sismique persistante et d\'émissions de fluides localisées dans la zone du Fer à Cheval."; + $html .= '

    '; + $html .= '

    '; + $html .= " Edifice principal
    "; + $html .= ' Latitude : -12°54\' ; longitude : 45°43\'
    '; + $html .= ' Hauteur : au moins 800 m
    '; + $html .= ' Profondeur à la base du site éruptif : -3500 m
    '; + $html .= '

    '; + $html .= '
    '; + $html .= '

    '; + $html .= " Niveau d'alerte : $alerts{$alert}"; + $html .= '

    '; + $html .= '
    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + #$htmlOutput .= ' '; + #$htmlBrowser .= ' '; + $html = '

    Sismologie

    '; + + my $subject = "[revosima_bulletin] $timePeriod"; + $html .= "

    - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

    "; + $html .= "

    - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

    "; + $html .= "

    - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

    "; + $html .= "

    - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
    "; + $html .= "

      "; + $html .= "
    • Durée : $stat_max_duration s
      • "; + $html .= "
    • Magnitude (MLv) : $stat_max_magnitude
      • "; + $html .= "

    "; + $html .= "

    - Dernier séisme ressenti :
    "; + $html .= "

      "; + $html .= "
    • Date : $date_felt
      • "; + $html .= "
    • Magnitude (MLv) : $magnitude_felt
      • "; + $html .= "
    • Profondeur : $depth_felt km
      • "; + $html .= "
    • Localisation : $loc_felt
      • "; + $html .= "

    "; + $html .= "

    Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

    "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ""; + $htmlBrowser .= ""; + $html = "

    "; + $htmlMail .= $html; + $html .= "

    "; + $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, ITES) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA
    "; + $html .= "La sismicité déterminée et validée en continu par le REVOSIMA peut être également suivie sur le portail RENASS."; + $html .= "

    "; + $html .= '
    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

    Déformations

    "; + for (@comments_geodesy) { + $html .= " - $geodesy{$_}

    "; + } + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= "
    "; + $htmlBrowser .= "
    "; + $html = "

    "; + $htmlMail .= $html; + $html .= "

    "; + $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; + $html .= "

    "; + $html .= '
    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = ""; + $html .= "

    Géochimie

    "; + $comments_geochemistry = encode_entities(decode('utf-8', $comments_geochemistry)); + $comments_geochemistry =~ s;\n;
    ;g; + $html .= "

    $comments_geochemistry

    "; + if ($comment ne "") { + $html .= "

    Informations complémentaires

    "; + $comment = encode_entities(decode('utf-8', $comment)); + $comment =~ s;\n;
    ;g; + $html .= "

    $comment

    "; + } + $html .= '
    '; + $html .= "

    Contexte


    "; + $html .= "

    • Activité éruptive: Du 2 au 18 mai 2019, une campagne océanographique (MD220-MAYOBS1) sur le Marion Dufresne a permis la découverte d'un nouveau site éruptif sous-marin à 50 km à l'est de Mayotte qui a formé un édifice d'environ 820 m de hauteur sur le plancher océanique situé à 3500m de profondeur d'eau. Les campagnes (MD221-MAYOBS2 - 10-17 juin 2019 ; MD222-MAYOBS3 - 13-14 juillet 2019 ; MD223-MAYOBS4 - 19-31 juillet 2019 ; mission SHOM-MAYOBS5 20-21 août 2019; MAYOBS13 - 4-11 mai 2020) ont mis en évidence de nouvelles coulées de lave, au sud, à l'ouest et au nord du nouveau site éruptif. Des panaches acoustiques (700 à 1000 m de haut) de nature hydrothermale et/ou magmatique, ont été détectés dans la colonne d'eau au-dessus des coulées actives, ainsi qu'au-dessus de la structure volcanique ancienne dite du \"Fer à cheval \" située à l'aplomb de la zone de l'essaim sismique principal (5-15 km à l'est de Petite-Terre). En l’état actuel des connaissances, l’éruption a produit un volume estimé d’environ 6,4 km3 de lave depuis le début de son édification avec des flux qui ont variés, d'environ 35 à 181 m3/s. Ces volumes et flux éruptifs, notamment au début de la crise, sont exceptionnels et sont, malgré les incertitudes, parmi les plus élevés observés sur un volcan effusif depuis l'éruption du Laki (Islande) en 1783.

    • @@ -382,71 +384,71 @@

    "; - $html .= "
    "; - $html .= "
    "; - $html .= " "; - $html .= ""; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - - print "$htmlBrowser"; - - #open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; - open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; - print $fh $htmlOutput; - close $fh; - -# print "Envoie du mail"; - - my $from = $MC3{MAIL_FROM_REVOSIMA}; - my $smtpServer = $MC3{MAIL_SMTP_SERVER}; - my $smtpPort = $MC3{MAIL_SMTP_PORT}; - my $user = $MC3{MAIL_USER_REVOSIMA}; - my $passwd = $MC3{MAIL_PASSWD_REVOSIMA}; - - my $mailList = ''; - my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); - for (@mailConf) { - my @liste = split(/\|/,$_); - my %hash; - @hash{@mail}=(); - if (exists $hash{$liste[0]}){ - if ($mailList eq '') { - $mailList = $mailList.$liste[4] - } else { - $mailList = $mailList.','.$liste[4] - } - } - } - - my $message = Email::MIME->create_html( - header => [ - From => $from, - 'Reply-To' => $from, - Subject => $subject, - Type => 'text/html; charset=UTF-8', - ], - body => $htmlMail, - ); - - my @mailingList = split(/,/,$mailList); - for(@mailingList) { - if($MC3{MAIL_USE_SMTP_REVOSIMA}) { - my $transport = Email::Sender::Transport::SMTP::TLS->new( - host => $smtpServer, - port => $smtpPort, - username => $user, - password => $passwd, - ); - sendmail($message, { from => $from, to => $_, transport => $transport}); - } else { - sendmail($message, { from => $from, to => $_}); - } - } + $html .= "
    "; + $html .= " "; + $html .= " "; + $html .= ""; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + print "$htmlBrowser"; + +#open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; + open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; + print $fh $htmlOutput; + close $fh; + + # print "Envoie du mail"; + + my $from = $MC3{MAIL_FROM_REVOSIMA}; + my $smtpServer = $MC3{MAIL_SMTP_SERVER}; + my $smtpPort = $MC3{MAIL_SMTP_PORT}; + my $user = $MC3{MAIL_USER_REVOSIMA}; + my $passwd = $MC3{MAIL_PASSWD_REVOSIMA}; + + my $mailList = ''; + my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); + for (@mailConf) { + my @liste = split(/\|/,$_); + my %hash; + @hash{@mail}=(); + if (exists $hash{$liste[0]}){ + if ($mailList eq '') { + $mailList = $mailList.$liste[4] + } else { + $mailList = $mailList.','.$liste[4] + } + } + } + + my $message = Email::MIME->create_html( + header => [ + From => $from, + 'Reply-To' => $from, + Subject => $subject, + Type => 'text/html; charset=UTF-8', + ], + body => $htmlMail, + ); + + my @mailingList = split(/,/,$mailList); + for(@mailingList) { + if($MC3{MAIL_USE_SMTP_REVOSIMA}) { + my $transport = Email::Sender::Transport::SMTP::TLS->new( + host => $smtpServer, + port => $smtpPort, + username => $user, + password => $passwd, + ); + sendmail($message, { from => $from, to => $_, transport => $transport}); + } else { + sendmail($message, { from => $from, to => $_}); + } + } } else { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -463,12 +465,12 @@

    @@ -495,28 +497,28 @@

    Deplacements sur Mayotte sur le dernier mois

    PART12 - my $category = -1; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - if ($category != $liste[3]) { - if ($category != -1) { - print ""; - } - print ""; + } + print "

    PART52 - print <<"PART61"; + print <<"PART61";

    Commentaire geochimie:

    PART61 - print <<"PART7"; + print <<"PART7";

    Informations complémentaires :

    Ajouter un éventuel séisme ressenti au cours des 24 dernières heures.
    @@ -525,19 +527,19 @@

    PART7 - my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); - for (@mails) { - my @liste = split(/\|/,$_); - if ($liste[3] == 1) { - if ($liste[2] == 1) { - print "$liste[1]
    \n"; - } else { - print "$liste[1]
    \n"; - } - } - } - - print <<"PART5"; + my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); + for (@mails) { + my @liste = split(/\|/,$_); + if ($liste[3] == 1) { + if ($liste[2] == 1) { + print "$liste[1]
    \n"; + } else { + print "$liste[1]
    \n"; + } + } + } + + print <<"PART5"; diff --git a/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl b/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl index 4446c270..cac75f92 100755 --- a/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl +++ b/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl @@ -47,6 +47,7 @@ use Switch; set_message(\&webobs_cgi_msg); + #my $old_locale = setlocale(LC_NUMERIC); #setlocale(LC_NUMERIC,'C'); @@ -95,7 +96,7 @@ my $debug; if ($valParams =~ /debug/) { - $debug = $cgi->url_param('debug'); + $debug = $cgi->url_param('debug'); } my $dateStart = $cgi->url_param('dateStart'); @@ -169,7 +170,7 @@ my @comments_geodesy = $cgi->url_param('comment_geodesy'); my $comments_geochemistry = $cgi->url_param('comment_geochemistry'); if ($comments_geochemistry eq "") { - $comments_geochemistry = "Géochimie non renseignée."; + $comments_geochemistry = "Géochimie non renseignée."; } my @mail = $cgi->url_param('mail'); @@ -180,15 +181,15 @@ my @typeZones = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{ZONES_CODES_REVOSIMA_CONF}"); my @commentsGeodesy = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{COMMENTS_GEODESY_REVOSIMA_CONF}"); -my $dateEndFrench = substr($dateEnd,8,2)."-".substr($dateEnd,5,2)."-".substr($dateEnd,0,4); -my $dateStartFrench = substr($dateStart,8,2)."-".substr($dateStart,5,2)."-".substr($dateStart,0,4); +my $dateEndFrench = substr($dateEnd,8,2)."-".substr($dateEnd,5,2)."-".substr($dateEnd,0,4); +my $dateStartFrench = substr($dateStart,8,2)."-".substr($dateStart,5,2)."-".substr($dateStart,0,4); my $timePeriod = "Bilan du $dateEnd"; my $timePeriodHTML = "Bulletin préliminaire d'activité du $dateEndFrench"; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ($dateStart ne $dateEnd && !defined($send)) { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -202,37 +203,37 @@ PART1 - + } elsif (defined($send)) { - my $html; - my $outputFilename = '/opt/php/bulletin/bulletin.html'; - my $htmlOutput = ""; - my $htmlBrowser = ""; - my $htmlMail = ""; - my %alerts; - for (@typeAlerts) { - my @liste = split(/\|/,$_); - $alerts{$liste[0]} = $liste[1]; - } - my %geodesy; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - $geodesy{$liste[0]} = $liste[2]; - } + my $html; + my $outputFilename = '/opt/php/bulletin/bulletin.html'; + my $htmlOutput = ""; + my $htmlBrowser = ""; + my $htmlMail = ""; + my %alerts; + for (@typeAlerts) { + my @liste = split(/\|/,$_); + $alerts{$liste[0]} = $liste[1]; + } + my %geodesy; + for (@commentsGeodesy) { + my @liste = split(/\|/,$_); + $geodesy{$liste[0]} = $liste[2]; + } - print $cgi->header(-charset=>'utf-8'); - - $html = ''; - $html .= ''; - $html .= ' '; - $html .= ' '; - $html .= ' Bulletin d\'information'; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlBrowser .= " "; - $html = ' '; - $html .= ' '; - $html .= ' '; - $html .= '

    '; - $html .= '

    Réseau de surveillance Volcanologique et Sismologique de Mayotte

    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $html = '
    '; - $html .= ' '; - $html .= '
    '; - $html .= "

    $timePeriodHTML

    "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ' '; - $htmlBrowser .= ' '; - my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); - $html = "

    Bulletin créé le $dateBulletin TU.

    "; - $html .= "

    Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
    Pour une information complète, veuillez vous reporter aux Actualités du réseau validées.

    "; - $html .= '
    '; - $html .= '

    Activité

    '; - $html .= '

    '; - $html .= ' Evènement en cours : éruption sous-marine très probablement toujours en cours à 50-60 km à l\'Est de Mayotte avec sismicité et déformations associées. '; - $html .= '

    '; - $html .= '

    '; - $html .= " Dernière preuve sans équivoque d'activité éruptive : autour du 20 août 2019"; - $html .= '

    '; - $html .= '

    '; - $html .= " Site éruptif actuel (au 20-08-2019)
    "; - $html .= ' Edifice principal : latitude : -12°54\' ; longitude : 45°43\'
    '; - $html .= ' Hauteur : au moins 800 m
    '; - $html .= ' Profondeur à la base du site éruptif : -3500 m
    '; - $html .= '

    '; - $html .= '
    '; - $html .= '

    '; - $html .= " Niveau d'alerte : $alerts{$alert}"; - $html .= '

    '; - $html .= '
    '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - #$htmlOutput .= ' '; - #$htmlBrowser .= ' '; - $html = '

    Sismologie

    '; - - my $subject = "$timePeriod"; - $html .= "

    - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

    "; - $html .= "

    - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

    "; - $html .= "

    - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

    "; - $html .= "

    - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
    "; - $html .= "

      "; - $html .= "
    • Durée : $stat_max_duration s
      • "; - $html .= "
    • Magnitude (MLv) : $stat_max_magnitude
      • "; - $html .= "

    "; - $html .= "

    - Dernier séisme ressenti :
    "; - $html .= "

      "; - $html .= "
    • Date : $date_felt
      • "; - $html .= "
    • Magnitude (MLv) : $magnitude_felt
      • "; - $html .= "
    • Profondeur : $depth_felt km
      • "; - $html .= "
    • Localisation : $loc_felt
      • "; - $html .= "

    "; - $html .= "

    Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

    "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ""; - $htmlBrowser .= ""; - $html = "

    "; - $htmlMail .= $html; - $html .= "

    "; - $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, IPGS) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA"; - $html .= "

    "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

    Déformations

    "; - for (@comments_geodesy) { - $html .= " - $geodesy{$_}

    "; - } - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= "
    "; - $htmlBrowser .= "
    "; - $html = "

    "; - $htmlMail .= $html; - $html .= "

    "; - $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; - $html .= "

    "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = ""; - #$html .= "

    Géochimie

    "; - #$comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); - #$comments_geochemistry =~ s;\n;
    ;g; - #$html .= "

    $comments_geochemistry

    "; - if ($comment ne "") { - $html .= "

    Informations complémentaires

    "; - $comment = encode_entities(decode('utf8', $comment)); - $comment =~ s;\n;
    ;g; - $html .= "

    $comment

    "; - } - $html .= '
    '; - $html .= "

    Contexte


    "; - $html .= "

    + '; + $html .= ' '; + $html .= ' '; + $html .= '

    '; + $html .= '

    Réseau de surveillance Volcanologique et Sismologique de Mayotte

    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $html = '
    '; + $html .= ' '; + $html .= '
    '; + $html .= "

    $timePeriodHTML

    "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ' '; + $htmlBrowser .= ' '; + my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); + $html = "

    Bulletin créé le $dateBulletin TU.

    "; + $html .= "

    Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
    Pour une information complète, veuillez vous reporter aux Actualités du réseau validées.

    "; + $html .= '
    '; + $html .= '

    Activité

    '; + $html .= '

    '; + $html .= ' Evènement en cours : éruption sous-marine très probablement toujours en cours à 50-60 km à l\'Est de Mayotte avec sismicité et déformations associées. '; + $html .= '

    '; + $html .= '

    '; + $html .= " Dernière preuve sans équivoque d'activité éruptive : autour du 20 août 2019"; + $html .= '

    '; + $html .= '

    '; + $html .= " Site éruptif actuel (au 20-08-2019)
    "; + $html .= ' Edifice principal : latitude : -12°54\' ; longitude : 45°43\'
    '; + $html .= ' Hauteur : au moins 800 m
    '; + $html .= ' Profondeur à la base du site éruptif : -3500 m
    '; + $html .= '

    '; + $html .= '
    '; + $html .= '

    '; + $html .= " Niveau d'alerte : $alerts{$alert}"; + $html .= '

    '; + $html .= '
    '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + #$htmlOutput .= ' '; + #$htmlBrowser .= ' '; + $html = '

    Sismologie

    '; + + my $subject = "$timePeriod"; + $html .= "

    - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

    "; + $html .= "

    - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

    "; + $html .= "

    - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

    "; + $html .= "

    - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
    "; + $html .= "

      "; + $html .= "
    • Durée : $stat_max_duration s
      • "; + $html .= "
    • Magnitude (MLv) : $stat_max_magnitude
      • "; + $html .= "

    "; + $html .= "

    - Dernier séisme ressenti :
    "; + $html .= "

      "; + $html .= "
    • Date : $date_felt
      • "; + $html .= "
    • Magnitude (MLv) : $magnitude_felt
      • "; + $html .= "
    • Profondeur : $depth_felt km
      • "; + $html .= "
    • Localisation : $loc_felt
      • "; + $html .= "

    "; + $html .= "

    Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

    "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ""; + $htmlBrowser .= ""; + $html = "

    "; + $htmlMail .= $html; + $html .= "

    "; + $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, IPGS) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA"; + $html .= "

    "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

    Déformations

    "; + for (@comments_geodesy) { + $html .= " - $geodesy{$_}

    "; + } + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= "
    "; + $htmlBrowser .= "
    "; + $html = "

    "; + $htmlMail .= $html; + $html .= "

    "; + $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; + $html .= "

    "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = ""; + +#$html .= "

    Géochimie

    "; +#$comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); +#$comments_geochemistry =~ s;\n;
    ;g; +#$html .= "

    $comments_geochemistry

    "; + if ($comment ne "") { + $html .= "

    Informations complémentaires

    "; + $comment = encode_entities(decode('utf8', $comment)); + $comment =~ s;\n;
    ;g; + $html .= "

    $comment

    "; + } + $html .= '
    '; + $html .= "

    Contexte


    "; + $html .= "

    • Activité éruptive: Du 2 au 18 mai 2019, une campagne océanographique (MD220-MAYOBS-1) sur le Marion Dufresne a permis la découverte d'un nouveau site éruptif sous-marin à 50 km à l'est de Mayotte qui a formé un édifice d'environ 820 m de hauteur sur le plancher océanique situé à 3500m de profondeur d'eau. Les campagnes (MD221-MAYOBS-2 - 10-17 juin 2019 ; MD222-MAYOBS-3 - 13-14 juillet 2019 ; MD223-MAYOBS-4 - 19-31 juillet 2019 ; mission SHOM-MAYOBS-5 20-21 août 2019) ont mis en évidence de nouvelles coulées de lave, au sud, à l'ouest et au nord du nouveau site éruptif. Des panaches acoustiques (700 à 1000 m de haut) de nature hydrothermale et/ou magmatique, ont été détectés dans la colonne d'eau au-dessus des coulées actives, ainsi qu'au-dessus de la structure volcanique ancienne dite du \"Fer à cheval \" située à l'aplomb de la zone de l'essaim sismique principal (5-15 km à l'est de Petite-Terre). En l'état actuel des connaissances, le nouveau site éruptif a produit au moins 5,1 km3 de lave depuis le début de son édification avec des flux qui ont variés, d'environ 45 à 200 m3/s. Ces volumes et flux éruptifs, notamment au début de la crise, sont exceptionnels et sont, malgré les incertitudes, parmi les plus élevés observés sur un volcan effusif depuis l'éruption du Laki (Islande) en 1783.

    • @@ -377,23 +380,23 @@

    "; - $html .= "
    "; - $html .= "
    "; - $htmlBrowser .= $html; - $html .= " "; - $html .= ""; - $htmlOutput .= $html; - $htmlMail .= $html; + $html .= "
    "; + $html .= " "; + $htmlBrowser .= $html; + $html .= " "; + $html .= ""; + $htmlOutput .= $html; + $htmlMail .= $html; - print "$htmlBrowser"; - print 'Your visible link text'; + print "$htmlBrowser"; + print 'Your visible link text'; - #open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; - open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; - print $fh $htmlOutput; - close $fh; +#open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; + open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; + print $fh $htmlOutput; + close $fh; -# print "Envoie du mail"; + # print "Envoie du mail"; # my $from = $MC3{MAIL_FROM_REVOSIMA}; # my $smtpServer = $MC3{MAIL_SMTP_SERVER}; @@ -441,8 +444,8 @@ # } # } } else { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -459,12 +462,12 @@

    @@ -491,28 +494,28 @@

    Deplacements sur Mayotte sur le long terme

    PART12 - my $category = -1; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - if ($category != $liste[3]) { - if ($category != -1) { - print ""; - } - print ""; + } + print "

    PART52 - print <<"PART61"; + print <<"PART61";

    Commentaire geochimie:

    PART61 - print <<"PART7"; + print <<"PART7";

    Informations complémentaires :

    Ajouter un éventuel séisme ressenti au cours des 24 dernières heures.
    @@ -521,19 +524,19 @@

    PART7 - my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); - for (@mails) { - my @liste = split(/\|/,$_); - if ($liste[3] == 1) { - if ($liste[2] == 1) { - print "$liste[1]
    \n"; - } else { - print "$liste[1]
    \n"; - } - } - } - - print <<"PART5"; + my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); + for (@mails) { + my @liste = split(/\|/,$_); + if ($liste[3] == 1) { + if ($liste[2] == 1) { + print "$liste[1]
    \n"; + } else { + print "$liste[1]
    \n"; + } + } + } + + print <<"PART5"; diff --git a/CODE/cgi-bin/mc3.pl b/CODE/cgi-bin/mc3.pl index 049edf38..e4ec9dab 100755 --- a/CODE/cgi-bin/mc3.pl +++ b/CODE/cgi-bin/mc3.pl @@ -157,6 +157,7 @@ =head1 HYPOCENTERS FILES use Locale::TextDomain('webobs'); set_message(\&webobs_cgi_msg); + #DL-TBD: no strict "subs"; #DL-TBD: my $old_locale = setlocale(LC_NUMERIC); #DL-TBD: setlocale(LC_NUMERIC,'C'); @@ -230,62 +231,61 @@ =head1 HYPOCENTERS FILES $|=1; - # ---- a few useful subroutines ----------------------------------------------- sub compute_energy { - # Energy calculation in joules, from: - # Hanks, T. C., & Kanamori, H. (1979). A moment magnitude scale. - # Journal of Geophysical Research: Solid Earth, 84(B5), 2348-2350 - my $mag = shift; - return 10**(1.5 * $mag + 11.8) / 10**7; -} + # Energy calculation in joules, from: + # Hanks, T. C., & Kanamori, H. (1979). A moment magnitude scale. + # Journal of Geophysical Research: Solid Earth, 84(B5), 2348-2350 + my $mag = shift; + return 10**(1.5 * $mag + 11.8) / 10**7; +} # ---- check/fix OR default the requested date range -------------------------- # - handle 28-31 days/month by re-evaluating with "YYYY-MM-01 (DD-1) day" # (ie. 2012-02-30 ==> 2012-03-02) # - check range-start < range-end , otherwise swap if ($QryParm->{'routine'} =~ /^(day|month|year)$/) { - if ($QryParm->{'routine'} eq "day") { - $start_datetime = DateTime->today()->subtract(days => 1); - $end_datetime = DateTime->today()->subtract(hours => 1); - } elsif ($QryParm->{'routine'} eq "month") { - $start_datetime = DateTime->today()->set_day(1)->subtract(months => 1); - $end_datetime = DateTime->today()->set_day(1)->subtract(hours => 1); - } elsif ($QryParm->{'routine'} eq "year") { - $start_datetime = DateTime->today()->subtract(years => 1)->set_month(1)->set_day(1); - $end_datetime = DateTime->today()->set_month(1)->set_day(1)->subtract(hours => 1); - } + if ($QryParm->{'routine'} eq "day") { + $start_datetime = DateTime->today()->subtract(days => 1); + $end_datetime = DateTime->today()->subtract(hours => 1); + } elsif ($QryParm->{'routine'} eq "month") { + $start_datetime = DateTime->today()->set_day(1)->subtract(months => 1); + $end_datetime = DateTime->today()->set_day(1)->subtract(hours => 1); + } elsif ($QryParm->{'routine'} eq "year") { + $start_datetime = DateTime->today()->subtract(years => 1)->set_month(1)->set_day(1); + $end_datetime = DateTime->today()->set_month(1)->set_day(1)->subtract(hours => 1); + } } elsif (($QryParm->{'y1'} ne "") && ($QryParm->{'m1'} ne "") && ($QryParm->{'d1'} ne "") - && ($QryParm->{'y2'} ne "") && ($QryParm->{'m2'} ne "") && ($QryParm->{'d2'} ne "")) { - - # We chose to handle short months by converting (e.g.) 30 February to 02 March, or 31 June to 01 July. - # For this, we add the number of days to the first day of the chosen month. - $start_datetime = DateTime->new(year => $QryParm->{y1}, - month => $QryParm->{m1}, - day => 1) - + DateTime::Duration->new(days => ($QryParm->{d1}-1)) - + DateTime::Duration->new(hours => ($QryParm->{h1})); - $end_datetime = DateTime->new(year => $QryParm->{y2}, - month => $QryParm->{m2}, - day => 1) - + DateTime::Duration->new(days => ($QryParm->{d2}-1)) - + DateTime::Duration->new(hours => ($QryParm->{h2})); + && ($QryParm->{'y2'} ne "") && ($QryParm->{'m2'} ne "") && ($QryParm->{'d2'} ne "")) { + +# We chose to handle short months by converting (e.g.) 30 February to 02 March, or 31 June to 01 July. +# For this, we add the number of days to the first day of the chosen month. + $start_datetime = DateTime->new(year => $QryParm->{y1}, + month => $QryParm->{m1}, + day => 1) + + DateTime::Duration->new(days => ($QryParm->{d1}-1)) + + DateTime::Duration->new(hours => ($QryParm->{h1})); + $end_datetime = DateTime->new(year => $QryParm->{y2}, + month => $QryParm->{m2}, + day => 1) + + DateTime::Duration->new(days => ($QryParm->{d2}-1)) + + DateTime::Duration->new(hours => ($QryParm->{h2})); } else { - $start_datetime = DateTime->now()->subtract(hours => (24*$MC3{DEFAULT_TABLE_DAYS}-1)); - $end_datetime = $now; + $start_datetime = DateTime->now()->subtract(hours => (24*$MC3{DEFAULT_TABLE_DAYS}-1)); + $end_datetime = $now; } # Change to local time if ($QryParm->{'slt'} != 0) { - $start_datetime = $start_datetime - DateTime::Duration->new(hours => ($slt)); - $end_datetime = $end_datetime - DateTime::Duration->new(hours => ($slt)); + $start_datetime = $start_datetime - DateTime::Duration->new(hours => ($slt)); + $end_datetime = $end_datetime - DateTime::Duration->new(hours => ($slt)); } # Swap start and end if necessary if ($start_datetime gt $end_datetime) { - ($start_datetime, $end_datetime) = ($end_datetime, $start_datetime); + ($start_datetime, $end_datetime) = ($end_datetime, $start_datetime); } $QryParm->{'y1'} = $start_datetime->year; @@ -310,9 +310,10 @@ sub compute_energy { my @Durations = readCfgFile("$MC3{DURATIONS_CONF}"); my %duration_s; for (@Durations) { - my ($key,$nam,$val) = split(/\|/,$_); - $duration_s{$key} = $val; + my ($key,$nam,$val) = split(/\|/,$_); + $duration_s{$key} = $val; } + # ---- Load Amplitudes -------------------------------------------------------- # my @amplitudes = readCfgFile("$MC3{AMPLITUDES_CONF}"); @@ -320,9 +321,9 @@ sub compute_energy { my %valAmp; my %opeAmp = ( 'le' => '≤', 'eq' => '=', 'ge' => '≥' ); for (@amplitudes) { - my ($key,$nam,$val) = split(/\|/,$_); - $namAmp{$key} = $nam; - $valAmp{$key} = $val; + my ($key,$nam,$val) = split(/\|/,$_); + $namAmp{$key} = $nam; + $valAmp{$key} = $val; } # ---- Load No location SC3 types ---------------------------------------------- @@ -332,197 +333,207 @@ sub compute_energy { # if ($QryParm->{'dump'} eq "") { - $html .= "

    $MC3{TITLE}

    "; - $html .= "

    »» [ Associated Sefran3: "; - # adds links to all associated Sefran - my @Sefran = qx(grep -H -E 'MC3_NAME\|$mc3\$' $WEBOBS{PATH_SEFRANS}/*/*.conf); - my @SefranLinks; - for my $s3 (@Sefran) { - chomp $s3; - $s3 =~ s/^$WEBOBS{PATH_SEFRANS}\///g; - $s3 =~ s/\/.*//g; - push(@SefranLinks, "$s3"); - } - $html .= join(" | ",@SefranLinks)." - Notes ]

    "; - - $html .= "
    " - .""; - ; - - # ----- selection box TZ (UTC or local) - if ($MC3{SELECT_LOCAL_TZ} ne "") { - $html .= "\n"; - } - - $html .="
    Date TZ: Start Date: "; - - # ----- selection box YEAR1 - $html .= "\n"; - # ----- selection box MONTH1 - $html .= "\n"; - # ----- selection box DAY1 - $html .= "\n"; - # ----- selection box HOUR1 - $html .= "\n"; - - # ----- selection box YEAR2 - $html .= "    End Date: \n"; - # ----- selection Box MONTH2 - $html .= "\n"; - # ----- selection box DAY2 - $html .= "\n"; - # ----- selection box HOUR2 - $html .= "\n"; - - # ----- selection box TYPE EVNT - $html .= "    Type: \n"; - - # ----- selection box DUREE - $html .= "    Duration: \n"; - - # ----- selection box AMPLITUDE - $html .= "    Amplitude: \n
    "; - - # ----- selection box OBSERVATION - my $msg = "Regular expression"; - if (@infoFiltre ne ("")) { - $msg = htmlspecialchars(join('',@infoFiltre)); - $msg =~ s/\n//g; # this is needed by overlib() - $msg =~ s/'/\\'/g; # this is needed by overlib() - } - - $html .= " Filter (?):" - ." {'obs'}\">"; - if ($QryParm->{'obs'} ne "") { - $html .= ""; - } - - # ----- selection box LOCALISATION - $html .= "  Status: \n"; - - $html .= "  Locations: \n"; - - if ( !$MC3{DISPLAY_LOCATION_DEFAULT} ) { - $html .= "  {'hideloc'} ? "":" checked").">Show loc info (slower)"; - } else { - $html .= "  {'hideloc'} ? " checked":"").">No loc info (faster)"; - } - - if (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) { - $html .= "  {'trash'} ? " checked":"").">Trash"; - } - $html .= "  {'nograph'} ? " checked":"").">No graph (faster)"; - $html .= "    		"; - - # ----- Hidden fields + button(s) - $html .= "\n" - ."\n" - ."{'newts'}\">\n" - #."" - ."" - ."
    \n" - ."
    Searching for data... please wait.
    "; - - $html .= "\n" - ."\n" - ."\n); - } + my ($job_jid, $job_kid, $org, $job_start, $job_end, + $job_cmd, $job_stdpath, $job_rc, $job_rcmsg, $elapsed) = @$run; + + push(@jid_list, $job_jid) unless grep{$_ eq $job_jid} @jid_list; + + if ($QryParm->{'jid'} eq "" || $QryParm->{'jid'} eq $job_jid) { + + my $elapsed_column = ''; + my $bgcolor = "transparent"; + + # Running jobs have an undefined end date + my $is_running = not defined($job_end); + $jobsdefsCount++; + $jobsdefsId="jdef".$jobsdefsCount; + + if ($is_running) { + $job_rc = ''; + $job_rcmsg = ''; + $job_end = 'Running'; + } else { + my ($seconds, $ms) = split(/\./, ($elapsed)); + my @time = reverse($seconds%60, ($seconds/=60) % 60, ($seconds/=60) % 24, ($seconds/=24) ); + $elapsed_column = sprintf "%03d:%02d:%02d:%02d.%3.3s", @time, $ms; + + # Return code shows success: use a green background in the RC column + $bgcolor = ($job_rc == 0 ? "green":"red"); + } + + if (length($job_cmd) > $maxdcmdl) { + my $s = ($maxdcmdl-5)/2; + $job_cmd = substr($job_cmd,0,$s).'(...)'.substr($job_cmd,-$s); + } + $job_start =~ s/^.* //; + $job_end =~ s/^.* //; + $jobsruns .= qq(\n); + } } - # ---- Print the rest of the page # ------------------------------- print <<"EOP1"; @@ -386,7 +398,7 @@ sub fetch_all { } EOP1 if ($admOK) { - print <<"EOP2"; + print <<"EOP2"; function delADate() { var d1 = \$('#indate').val(); var answer = confirm("do you really want to delete all records for "+d1+" ?"); @@ -426,29 +438,29 @@ sub fetch_all {
    EOP3 - print " •  Job: "; - print " "; - print " •  Date: "; - print ""; - if ($admOK) { - print ""; - } +print " •  Job: "; +print " "; +print " •  Date: "; +print ""; +if ($admOK) { + print ""; +} print <<"EOP4"; $jobsrunsMsg
    diff --git a/CODE/cgi-bin/sefran3.pl b/CODE/cgi-bin/sefran3.pl index 99dfda83..cce16da5 100755 --- a/CODE/cgi-bin/sefran3.pl +++ b/CODE/cgi-bin/sefran3.pl @@ -95,6 +95,7 @@ =head1 Query string parameters my $replay = $cgi->url_param('replay'); my $hpx = $cgi->url_param('hpx'); my $limit = $cgi->url_param('limit'); + # $hideloc is read below # ---- analysis (depouillement) mode ? @@ -108,7 +109,7 @@ =head1 Query string parameters my %SEFRAN3 = readCfg("$s3conf") if (-f "$s3conf"); my $hideloc = $cgi->url_param('hideloc') - // not $SEFRAN3{MC3_EVENT_DISPLAY_LOC} =~ m/^(Y|YES|1)$/i; + // not $SEFRAN3{MC3_EVENT_DISPLAY_LOC} =~ m/^(Y|YES|1)$/i; # ---- loads MC3 configuration: requested or Sefran's or default $mc3 ||= $SEFRAN3{MC3_NAME} ||= $WEBOBS{MC3_DEFAULT_NAME}; @@ -118,15 +119,15 @@ =head1 Query string parameters # ---- checking for authorizations my $editOK = 0; if (%SEFRAN3) { - if (%MC3) { - if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"MC") - || WebObs::Users::clientHasRead(type=>"authprocs",name=>"$mc3")) { - if ( WebObs::Users::clientHasEdit(type=>"authprocs",name=>"MC") - || WebObs::Users::clientHasEdit(type=>"authprocs",name=>"$mc3")) { - $editOK = 1; - } - } else { die "$__{'Not authorized'} (read)"} - } else { die "$__{'Could not read'} MC configuration $mc3" } + if (%MC3) { + if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"MC") + || WebObs::Users::clientHasRead(type=>"authprocs",name=>"$mc3")) { + if ( WebObs::Users::clientHasEdit(type=>"authprocs",name=>"MC") + || WebObs::Users::clientHasEdit(type=>"authprocs",name=>"$mc3")) { + $editOK = 1; + } + } else { die "$__{'Not authorized'} (read)"} + } else { die "$__{'Could not read'} MC configuration $mc3" } } else { die "$__{'Could not read'} Sefran configuration $s3" } my $userLevel = 0; @@ -135,6 +136,7 @@ =head1 Query string parameters $userLevel = 4 if (WebObs::Users::clientHasAdm(type=>"authprocs",name=>"MC") || WebObs::Users::clientHasAdm(type=>"authprocs",name=>"$mc3")); if (!defined($limit)) { $limit = $SEFRAN3{TIME_INTERVALS_DEFAULT_VALUE}; } + # for "last events" mode ($limit = 0), forces real-time ($ref = 0) if ($limit == 0) { $ref = 0; } @@ -144,26 +146,29 @@ =head1 Query string parameters my @alias; my @streams; for (@channels) { - my ($ali,$cod) = split(/\s+/,$_); - push(@alias,$ali); - push(@streams,$cod); + my ($ali,$cod) = split(/\s+/,$_); + push(@alias,$ali); + push(@streams,$cod); } + # event codes (types) my %types = readCfg("$MC3{EVENT_CODES_CONF}",'sorted'); my %typesSO; my $typesJSARR = "["; for (keys(%types)) { - $typesSO{$types{$_}{_SO_}} = $_; - $typesJSARR .= "\"$_\"," if ($types{$_}{WO2SC3} == 1); + $typesSO{$types{$_}{_SO_}} = $_; + $typesJSARR .= "\"$_\"," if ($types{$_}{WO2SC3} == 1); } $typesJSARR .= "]"; + # events duration texts my @durations = readCfgFile("$MC3{DURATIONS_CONF}"); my %duration_s; for (@durations) { - my ($key,$nam,$val) = split(/\|/,$_); - $duration_s{$key} = $val; + my ($key,$nam,$val) = split(/\|/,$_); + $duration_s{$key} = $val; } + # events amplitude texts/thresholds # [TODO]: converts to regular HoH config file... my %nomAmp; @@ -171,30 +176,30 @@ =head1 Query string parameters my @ampfile = readCfgFile("$MC3{AMPLITUDES_CONF}"); my $i = 0; for (@ampfile) { - my ($key,$nam,$val,$kb) = split(/\|/,$_); - my $skey = sprintf("%02d",$i)."_$key"; # adds a prefix "xx_" to the hash key to be sorted - $nomAmp{$key} = $nam; - $amplitudes{$skey}{Name} = $nam; - $amplitudes{$skey}{Value} = $val; - $amplitudes{$skey}{KBcode} = $kb; - $i++; + my ($key,$nam,$val,$kb) = split(/\|/,$_); + my $skey = sprintf("%02d",$i)."_$key"; # adds a prefix "xx_" to the hash key to be sorted + $nomAmp{$key} = $nam; + $amplitudes{$skey}{Name} = $nam; + $amplitudes{$skey}{Value} = $val; + $amplitudes{$skey}{KBcode} = $kb; + $i++; } + # time interval texts + value in hours my @time_intervals = split(/,/,exists($SEFRAN3{TIME_INTERVALS_LIST}) ? $SEFRAN3{TIME_INTERVALS_LIST}:"0,6,12,24,48"); my %time_limits; for (@time_intervals) { - if ($_ == 0) { - $time_limits{$_} = $__{'Last MC events'}; - } elsif ($_%168 == 0) { - $time_limits{$_} = ($_/168)." week".($_/168>1 ? "s":""); - } elsif ($_%24 == 0) { - $time_limits{$_} = ($_/24)." day".($_/24>1 ? "s":""); - } else { - $time_limits{$_} = "$_ hours"; - } + if ($_ == 0) { + $time_limits{$_} = $__{'Last MC events'}; + } elsif ($_%168 == 0) { + $time_limits{$_} = ($_/168)." week".($_/168>1 ? "s":""); + } elsif ($_%24 == 0) { + $time_limits{$_} = ($_/24)." day".($_/24>1 ? "s":""); + } else { + $time_limits{$_} = "$_ hours"; + } } - # spectrogram my $sgramOK = isok($SEFRAN3{SGRAM_ACTIVE}); @@ -226,16 +231,18 @@ =head1 Query string parameters my $i; if (!$ref) { - $yref = $Ya; - $mref = $ma; - $dref = $da; - $href = $Ha; + $yref = $Ya; + $mref = $ma; + $dref = $da; + $href = $Ha; } else { - # permits 29-31 days for all months... - my $day0 = $dref - 1; - ($yref,$mref,$dref) = split('/',strftime('%Y/%m/%d',gmtime(timegm(0,0,0,1,$mref-1,$yref-1900) + $day0*86400))); - # if the reference date is specified (not real-time), forces 24 hours minimum display - $limit = 24 if ($limit < 24); + + # permits 29-31 days for all months... + my $day0 = $dref - 1; + ($yref,$mref,$dref) = split('/',strftime('%Y/%m/%d',gmtime(timegm(0,0,0,1,$mref-1,$yref-1900) + $day0*86400))); + +# if the reference date is specified (not real-time), forces 24 hours minimum display + $limit = 24 if ($limit < 24); } # ---- some display setups @@ -244,8 +251,8 @@ =head1 Query string parameters my $largeur_voies = $SEFRAN3{VALUE_PPI}+1; my $speed = $SEFRAN3{VALUE_SPEED}; if (($high || $dep) && $SEFRAN3{VALUE_SPEED_HIGH} > 0) { - $high = 1; - $speed = $SEFRAN3{VALUE_SPEED_HIGH}; + $high = 1; + $speed = $SEFRAN3{VALUE_SPEED_HIGH}; } my $largeur_image = $speed*$SEFRAN3{VALUE_PPI}; my $hauteur_image = ($hpx ne "" ? $hpx:$SEFRAN3{HEIGHT_INCH}*$SEFRAN3{VALUE_PPI}) + 1; @@ -268,7 +275,7 @@ =head1 Query string parameters "; if (!$date && !$ref) { - print "\n"; + print "\n"; } # ---- dynamic Javascript share variables with sefran3.js ---------------------- @@ -313,7 +320,7 @@ =head1 Query string parameters html if ($dep) { - print < html + # ---- end dynamic CSS --------------------------------------------------------- print ""; @@ -415,740 +423,760 @@ =head1 Query string parameters # ----------------------------------------------------------------------------- if (!$date) { - my $last_mc; - my $dt_lastmc; - my $limit_lastmc = $SEFRAN3{TIME_INTERVALS_DEFAULT_VALUE}; - if ($limit == 0) { - # gets the N=$SEFRAN3{DISPLAY_LAST_MC} last MC event: from the 2 last monthly files, extracts the Nth last event non 'AUTO' and returns 'yyyy-mm-dd|HH' - $last_mc = qx(find $MC3{ROOT} -name "$MC3{FILE_PREFIX}*.txt" | sort | tail -n2 | xargs sort -t '|' -k2,3 | tail -n$SEFRAN3{DISPLAY_LAST_MC} | head -n1 |sed -nE "s/^[0-9]+\\|([0-9]{4}-[0-9]{2}-[0-9]{2}\\|[0-9]{2}):.*/\\1/p" | xargs echo -n); - my $dtn = timegm(gmtime); - $dt_lastmc = timegm(0,0,substr($last_mc,11,2),substr($last_mc,8,2),substr($last_mc,5,2)-1,substr($last_mc,0,4)); - $limit_lastmc = int(($dtn - $dt_lastmc)/3600); - $limit_lastmc = $SEFRAN3{DISPLAY_DAYS}*24 if ($limit_lastmc/24 > $SEFRAN3{DISPLAY_DAYS}); - } - # builds the list of dates and loads associated MC events over the period (+ 1 day) - my @dates; - my @mclist; - for (0 .. ($limit>0?$limit:$limit_lastmc)) { - my $ymdh = strftime('%Y-%m-%d|%H',gmtime(timegm(0,0,$href,$dref,$mref-1,$yref-1900) - $_*3600)); - my $ymd = substr($ymdh,0,10); - push(@dates,$ymd) if (!grep(/^$ymd$/,@dates) && $_ < 24*$SEFRAN3{DISPLAY_DAYS}); - my $f = "$MC3{ROOT}/".substr($ymd,0,4)."/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}".substr($ymd,0,4).substr($ymd,5,2).".txt"; - if (-f $f) { - my @mchour = split(/\n/,qx(grep "|$ymdh:" $f)); - push(@mclist,@mchour); - } - } - my @listeHeures = reverse('00'..'23'); - - my $dt = 0; - my $last_mn; - my $lmn; - - # what's the last minute-image ? searches for it and computes realtime delta - my $last_d = qx(y=\$(find $SEFRAN3{ROOT} -maxdepth 1 -name "????" | sort | tail -n1);find \$y -maxdepth 1| sort | tail -n1 | xargs echo -n); - if ($last_d) { - $last_mn = qx/find $last_d -name "??????????????.png"|sort|tail -n1/; - if ($last_mn) { - $lmn = basename($last_mn); - my @lm = (substr($lmn,10,2),substr($lmn,8,2),substr($lmn,6,2),substr($lmn,4,2),substr($lmn,0,4)); - $dt = (timegm(gmtime) - timegm(0,$lm[0],$lm[1],$lm[2],$lm[3]-1,$lm[4]-1900) - 60); - } - } - - # title and current data/time - print "
    "; - if ($QryParm->{'nograph'} == 0) { - $html .= "
    \n" - ."\n" - ."
    		"; - # ----- selection box graph-type - $html .= "

    Graph: 

    "; - } else { - $html .= "    		"; - } + $html .= "

    $MC3{TITLE}

    "; + $html .= "

    »» [ Associated Sefran3: "; + + # adds links to all associated Sefran + my @Sefran = qx(grep -H -E 'MC3_NAME\|$mc3\$' $WEBOBS{PATH_SEFRANS}/*/*.conf); + my @SefranLinks; + for my $s3 (@Sefran) { + chomp $s3; + $s3 =~ s/^$WEBOBS{PATH_SEFRANS}\///g; + $s3 =~ s/\/.*//g; + push(@SefranLinks, "$s3"); + } + $html .= join(" | ",@SefranLinks)." - Notes ]

    "; + + $html .= "" + .""; + ; + + # ----- selection box TZ (UTC or local) + if ($MC3{SELECT_LOCAL_TZ} ne "") { + $html .= "\n"; + } + + $html .="
    Date TZ: Start Date: "; + + # ----- selection box YEAR1 + $html .= "\n"; + + # ----- selection box MONTH1 + $html .= "\n"; + + # ----- selection box DAY1 + $html .= "\n"; + + # ----- selection box HOUR1 + $html .= "\n"; + + # ----- selection box YEAR2 + $html .= "    End Date: \n"; + + # ----- selection Box MONTH2 + $html .= "\n"; + + # ----- selection box DAY2 + $html .= "\n"; + + # ----- selection box HOUR2 + $html .= "\n"; + + # ----- selection box TYPE EVNT + $html .= "    Type: \n"; + + # ----- selection box DUREE + $html .= "    Duration: \n"; + + # ----- selection box AMPLITUDE + $html .= "    Amplitude: \n
    "; + + # ----- selection box OBSERVATION + my $msg = "Regular expression"; + if (@infoFiltre ne ("")) { + $msg = htmlspecialchars(join('',@infoFiltre)); + $msg =~ s/\n//g; # this is needed by overlib() + $msg =~ s/'/\\'/g; # this is needed by overlib() + } + + $html .= " Filter (?):" + ." {'obs'}\">"; + if ($QryParm->{'obs'} ne "") { + $html .= ""; + } + + # ----- selection box LOCALISATION + $html .= "  Status: \n"; + + $html .= "  Locations: \n"; + + if ( !$MC3{DISPLAY_LOCATION_DEFAULT} ) { + $html .= "  {'hideloc'} ? "":" checked").">Show loc info (slower)"; + } else { + $html .= "  {'hideloc'} ? " checked":"").">No loc info (faster)"; + } + + if (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) { + $html .= "  {'trash'} ? " checked":"").">Trash"; + } + $html .= "  {'nograph'} ? " checked":"").">No graph (faster)"; + $html .= "    		"; + + # ----- Hidden fields + button(s) + $html .= "\n" + ."\n" + ."{'newts'}\">\n" + +#."" + ."" + ."
    \n" + ."
    Searching for data... please wait.
    "; + + $html .= "\n" + ."\n" + ."
    "; + if ($QryParm->{'nograph'} == 0) { + $html .= "
    \n" + ."
    " + ."plot all" + + #."
    download image
    \n" + ."
    		"; + + # ----- selection box graph-type + $html .= "

    Graph: 

    "; + } else { + $html .= "    		"; + } } # ---- some more inits (mainly for files below) ------------------------------- @@ -546,13 +557,13 @@ sub compute_energy { my @b3_lon; my @b3_lat; my @b3_nam; my @b3_isl; my @b3_sit; my @b3_dat; my $i = 0; for (@listeCommunes) { - my (@champs) = split(/\|/,$_); - $b3_sit[$i] = $champs[4]; - $b3_lon[$i] = $champs[1]; - $b3_lat[$i] = $champs[0]; - $b3_nam[$i] = $champs[2]; - $b3_isl[$i] = $champs[3]; - $i++; + my (@champs) = split(/\|/,$_); + $b3_sit[$i] = $champs[4]; + $b3_lon[$i] = $champs[1]; + $b3_lat[$i] = $champs[0]; + $b3_nam[$i] = $champs[2]; + $b3_isl[$i] = $champs[3]; + $i++; } # ---- init/check for Hypocenters files (FMT) usage --------------------------- @@ -561,10 +572,10 @@ sub compute_energy { my $HYPO_USE_FMT0_FILE = ""; # FMT0 was SISMOHYP_HYPO_USE and al. my $HYPO_USE_FMT1_PATH = ""; # FMT1 was OVPF_HYPO_USE and al. if (defined $MC3{HYPO_USE_FMT0} and length $MC3{HYPO_USE_FMT0}) { - ($HYPO_USE_FMT0_PATH,$HYPO_USE_FMT0_FILE) = split(/,/,$MC3{HYPO_USE_FMT0}); + ($HYPO_USE_FMT0_PATH,$HYPO_USE_FMT0_FILE) = split(/,/,$MC3{HYPO_USE_FMT0}); } if (defined $MC3{HYPO_USE_FMT1} and length $MC3{HYPO_USE_FMT1}) { - $HYPO_USE_FMT1_PATH = $MC3{HYPO_USE_FMT1}; + $HYPO_USE_FMT1_PATH = $MC3{HYPO_USE_FMT1}; } # ---- Load hypocentres ------------------------------------------------------- @@ -572,55 +583,58 @@ sub compute_energy { #DL-was: if ($MC3{SISMOHYP_HYPO_USE}) { #DL-was: my $fileHypo = "$WEBOBS{RACINE_FTP}/$WEBOBS{SISMOHYP_PATH_FTP}/$WEBOBS{SISMOHYP_HYPO_FILE}"; if ($HYPO_USE_FMT0_PATH) { - my $fileHypo = "$HYPO_USE_FMT0_PATH/$HYPO_USE_FMT0_FILE"; - if (-e $fileHypo) { - @hypos = readFile($fileHypo); - } - my $fileHypoAuto = "$HYPO_USE_FMT0_PATH/Auto/$HYPO_USE_FMT0_FILE"; - if (-e $fileHypoAuto) { - push(@hypos,readFile($fileHypoAuto)); - } + my $fileHypo = "$HYPO_USE_FMT0_PATH/$HYPO_USE_FMT0_FILE"; + if (-e $fileHypo) { + @hypos = readFile($fileHypo); + } + my $fileHypoAuto = "$HYPO_USE_FMT0_PATH/Auto/$HYPO_USE_FMT0_FILE"; + if (-e $fileHypoAuto) { + push(@hypos,readFile($fileHypoAuto)); + } } # ---- Load data files (MC + HYPO) for [dateStart-dateEnd] -------------------- # for my $y ($start_datetime->year..$end_datetime->year) { - my $y2 = substr($y,2); - if ($HYPO_USE_FMT0_PATH) { - my $fileHypo2 = "$HYPO_USE_FMT0_PATH/Global/$y"."_".$HYPO_USE_FMT0_FILE; - if (-e $fileHypo2) { - push(@hypos,readFile($fileHypo2)); - } - } - #DL-was: if ($MC3{OVPF_HYPO_USE}) { - #DL-was: my $fileHypo3 = "$WEBOBS{OVPFHYP_PATH}/$y.hyp" - if ($HYPO_USE_FMT1_PATH) { - my $fileHypo3 = "$HYPO_USE_FMT1_PATH/$y.hyp"; - if (-e $fileHypo3) { - push(@hypos,readFile($fileHypo3)); - } - } - for my $m ("01".."12") { - my $start_month = DateTime->new(year => $y, month => $m, day => 1); - #my $end_month = DateTime->last_day_of_month(year => $y, month => $m); - my $end_month = $start_month->clone; - $end_month->add( months => 1 ); # first day of the next month - if (DateTime->compare($end_month,$start_datetime) gt 0 - && DateTime->compare($start_month,$end_datetime) le 0) { - $fileMC = "$MC3{ROOT}/$y/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$y$m.txt"; - if (-e $fileMC) { - push(@lignes,grep(/.+\|.+/,readCfgFile($fileMC))); - $nb = $#lignes; - } - # @hypo will contain only valid year-month locations - if ($HYPO_USE_FMT0_PATH) { - push(@hypo,grep(/^$y$m/,@hypos)); - } - if ($HYPO_USE_FMT1_PATH) { - push(@hypo,grep(/^$y2$m/,@hypos)); - } - } - } + my $y2 = substr($y,2); + if ($HYPO_USE_FMT0_PATH) { + my $fileHypo2 = "$HYPO_USE_FMT0_PATH/Global/$y"."_".$HYPO_USE_FMT0_FILE; + if (-e $fileHypo2) { + push(@hypos,readFile($fileHypo2)); + } + } + + #DL-was: if ($MC3{OVPF_HYPO_USE}) { + #DL-was: my $fileHypo3 = "$WEBOBS{OVPFHYP_PATH}/$y.hyp" + if ($HYPO_USE_FMT1_PATH) { + my $fileHypo3 = "$HYPO_USE_FMT1_PATH/$y.hyp"; + if (-e $fileHypo3) { + push(@hypos,readFile($fileHypo3)); + } + } + for my $m ("01".."12") { + my $start_month = DateTime->new(year => $y, month => $m, day => 1); + + #my $end_month = DateTime->last_day_of_month(year => $y, month => $m); + my $end_month = $start_month->clone; + $end_month->add( months => 1 ); # first day of the next month + if (DateTime->compare($end_month,$start_datetime) gt 0 + && DateTime->compare($start_month,$end_datetime) le 0) { + $fileMC = "$MC3{ROOT}/$y/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$y$m.txt"; + if (-e $fileMC) { + push(@lignes,grep(/.+\|.+/,readCfgFile($fileMC))); + $nb = $#lignes; + } + + # @hypo will contain only valid year-month locations + if ($HYPO_USE_FMT0_PATH) { + push(@hypo,grep(/^$y$m/,@hypos)); + } + if ($HYPO_USE_FMT1_PATH) { + push(@hypo,grep(/^$y2$m/,@hypos)); + } + } + } } # ---- Load titles ------------------------------------------------------------ @@ -631,198 +645,212 @@ sub compute_energy { # ---- Process request to dump a bulletin ------------------------------------- # if ($QryParm->{'dump'} eq 'bul') { - $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_bulletin.csv"; - push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); - push(@csv,"#YYYYmmdd HHMMSS.ss;Nb(#);Duration;Amplitude;Magnitude;E(J);Longitude;Latitude;Depth;Type;File;LocMode;LocType;Projection;Operator;Timestamp;ID\n"); + $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_bulletin.csv"; + push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); + push(@csv,"#YYYYmmdd HHMMSS.ss;Nb(#);Duration;Amplitude;Magnitude;E(J);Longitude;Latitude;Depth;Type;File;LocMode;LocType;Projection;Operator;Timestamp;ID\n"); } if ($QryParm->{'dump'} eq 'cum') { - $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_daily_total.csv"; - push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); - push(@csv,"#Daily histogram counted from ".(($start_datetime)->strftime('%F %H:00:00'))."\n"); - push(@csv,"#YYYY-mm-dd Daily_Total(#);Daily_Count;Daily_Moment(N.m);Daily_Energy(J)\n"); + $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_daily_total.csv"; + push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); + push(@csv,"#Daily histogram counted from ".(($start_datetime)->strftime('%F %H:00:00'))."\n"); + push(@csv,"#YYYY-mm-dd Daily_Total(#);Daily_Count;Daily_Moment(N.m);Daily_Energy(J)\n"); } # ---- Filter events based on selection criteria: use of grep on the data line (fast!) ------------------------------ - # Filter out trashed event (except for Administrators) - # - if ( (!clientHasAdm(type=>"authprocs",name=>"MC") && !clientHasAdm(type=>"authprocs",name=>"$mc3")) || $QryParm->{'trash'} == 0 ) { - @lignes = grep(!/^-/, @lignes); - } - # Filter on type - # - if (($QryParm->{'type'} ne "") && ($QryParm->{'type'} ne "ALL")) { - @lignes = grep(/\|$QryParm->{'type'}\|/, @lignes) - } - # Filter on amplitude - # - if (($QryParm->{'ampoper'} eq "eq") && ($QryParm->{'amplitude'} ne "") && ($QryParm->{'amplitude'} ne "ALL")) { - @lignes = grep(/\|$QryParm->{'amplitude'}\|/, @lignes) - } - # Filter on observations - # - if ($QryParm->{'obs'} ne "") { - if (substr($QryParm->{'obs'},0,1) eq "!") { - my $regex = substr($QryParm->{'obs'},1); - @lignes = grep(!/$regex/i, @lignes); - } else { - @lignes = grep(/$QryParm->{'obs'}/i, @lignes); - } - } +# Filter out trashed event (except for Administrators) +# +if ( (!clientHasAdm(type=>"authprocs",name=>"MC") && !clientHasAdm(type=>"authprocs",name=>"$mc3")) || $QryParm->{'trash'} == 0 ) { + @lignes = grep(!/^-/, @lignes); +} + +# Filter on type +# +if (($QryParm->{'type'} ne "") && ($QryParm->{'type'} ne "ALL")) { + @lignes = grep(/\|$QryParm->{'type'}\|/, @lignes) +} + +# Filter on amplitude +# +if (($QryParm->{'ampoper'} eq "eq") && ($QryParm->{'amplitude'} ne "") && ($QryParm->{'amplitude'} ne "ALL")) { + @lignes = grep(/\|$QryParm->{'amplitude'}\|/, @lignes) +} + +# Filter on observations +# +if ($QryParm->{'obs'} ne "") { + if (substr($QryParm->{'obs'},0,1) eq "!") { + my $regex = substr($QryParm->{'obs'},1); + @lignes = grep(!/$regex/i, @lignes); + } else { + @lignes = grep(/$QryParm->{'obs'}/i, @lignes); + } +} # ---- Filters requiring loading of data from $dateStart to $DateEnd), duration, localization, ... # my $l = 0; my %QML; foreach my $line (@lignes) { - $l++; - my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat, - $nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature, - $comment) = split(/\|/,$line); - my ($operator,$timestamp) = split("/",$signature); - my $origin; - my $duree_s = ($duree ? $duree*$duration_s{$unite}:""); - my @evt_date_elem = split(/-/,$date); - my @evt_hour_elem = split(/:/,$heure); - my $evt_date = DateTime->new(year => $evt_date_elem[0], - month => $evt_date_elem[1], - day => $evt_date_elem[2], - hour => $evt_hour_elem[0]); - my $evt_amp = $valAmp{$amplitude}; - # default timestamp for old data is event date - $timestamp = join('',@evt_date_elem)."T".join('',@evt_hour_elem) if ($timestamp eq ""); - my ($lat,$lon,$dep,$mag,$mty,$cod,$dat,$pha,$qua,$mod,$sta,$mth,$mdl,$typ); - #XB-was: if (($date le $dateEnd && $date ge $dateStart) - #XB-was: && ($QryParm->{'duree'} eq "" || $QryParm->{'duree'} eq "NA" || $QryParm->{'duree'} eq "ALL" || $duree_s >= $QryParm->{'duree'}) - if ($evt_date ge $start_datetime && $evt_date le $end_datetime - && ($QryParm->{'duree'} ~~ ["", "NA", "ALL"] || $duree_s >= $QryParm->{'duree'} || length($qml) > 2) - && ($QryParm->{'amplitude'} ~~ ["", "ALL"] || $QryParm->{'ampoper'} eq 'eq' - || ($QryParm->{'ampoper'} eq 'le' && $evt_amp <= $valAmp{$QryParm->{'amplitude'}}) - || ($QryParm->{'ampoper'} eq 'ge' && $evt_amp >= $valAmp{$QryParm->{'amplitude'}})) - && ($QryParm->{'newts'} eq "" || $timestamp ge $QryParm->{'newts'}) - ) { - # do not display location informations - if ($QryParm->{'hideloc'} == 1 || $MC3{SC3_EVENTS_ROOT} eq "") { - for (keys %QML) { - delete $QML{$_}; - } - } - # ID SC3 case: load SC3ml file (et écrasement d'une éventuelle origine existante - cas de Zandets) - elsif ($MC3{SC3_EVENTS_ROOT} ne "" && $qml =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { - my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$qml); - %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$qml/$sc3id.last.xml"); - if (%QML) { - $origin = "$sc3id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; - } else { - $origin = ''; - } - $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; - } - # ID FDSNWS case: request QuakeML file by FDSN webservice - elsif ($qml =~ /:\/\//) { - my ($fdsnws_src,$evt_id) = split(/:\/\//,$qml); - my $fdsnws_url = ""; - my $fdsnws_detail = ""; - if (defined($MC3{FDSNWS_EVENTS_URL})) { - $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; - } - if (length($fdsnws_src) > 0) { - my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; - $fdsnws_url = "$MC3{$varname}"; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; - $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_src"; - if (defined($MC3{$varname})) { - $fdsnws_detail = $MC3{$varname}; - } - } - %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); - if (%QML) { - #[FB-note]: replaced by empty type in the SC3_EVENT_TYPES_NOLOCATION list - #$QML{type} = "not locatable" if ($QML{type} eq ""); - $origin = "$evt_id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; - } else { - $origin = ''; - } - $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; - } - # Old suds ID case : - elsif (length($qml) < 3 && $HYPO_USE_FMT0_PATH) { - my @loca; - my $suds_sans_seconde; - my $suds_racine; - my $evt_annee4; - my $evt_mois; - if (length($suds) > 10 && ($suds =~ ".gwa" || $suds =~ ".mq0")) { - ($evt_annee4, $evt_mois) = unpack("a4 a2",$suds); - } else { - ($evt_annee4, $evt_mois) = unpack("a4 x a2",$date); - } - if (length($suds)==12 && substr($suds,8,1) eq '.') { - # ne prend que les premiers caractères du nom de fichier - $suds_sans_seconde = substr($suds,0,7); - @loca = grep(/ $suds_sans_seconde/,grep(/^$evt_annee4$evt_mois/,@hypo)); - } elsif (length($suds)==19) { - $suds_racine = substr($suds,0,15); - @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); - } - for (@loca) { - my $id; - $dat = sprintf("%d-%02d-%02d %02d:%02d:%02.2f TU",substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,9,2),substr($_,11,2),substr($_,14,5)); - $mag = substr($_,47,5); - $mty = 'Md'; - $lat = substr($_,20,2) + substr($_,23,5)/60; - $lon = -(substr($_,30,2) + substr($_,33,5)/60); - $dep = substr($_,39,6); - $pha = substr($_,53,2); - $qua = substr($_,80,1); - $cod = substr($_,83,5); - if (length(substr($_,89))>15) { - $id = substr($_,89,15); - } - elsif (length(substr($_,89))<10) { - $id = substr($_,89); - } - $mod = 'manual'; - $origin = "$id;$dat;$lat;$lon;$dep;$pha;$mod;;$mag;$mty;Hypo71;;$cod"; - $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; - } - } - - ($cod,$dat,$lat,$lon,$dep,$pha,$mod,$sta,$mag,$mty,$mth,$mdl,$typ) = split(';',$origin); - my $noloc = 0; - $noloc = 1 if (grep(/^$typ$/,@nolocation_types)); - - if ($QryParm->{'located'} == 0 && $QryParm->{'locstatus'} == 0 - || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') - || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') - || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 0) - || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') - || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') - || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 0) - || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') - || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') - || $QryParm->{'hideloc'} == 1 ) { - if ($QryParm->{'dump'} eq 'bul') { - my $energy = ''; - if ($mag) { - # Include energy in joules into the CSV output - $energy = compute_energy($mag); - } - push(@csv,join('',split(/-/,$date))." ".join('',split(/:/,$heure)).";" - ."$nombre;$duree_s;$amplitude;$mag;$energy;$lon;$lat;$dep;$type;$qml;" - #.($mod eq 'manual' ? "1":"0").";WGS84;$operator;$timestamp;" - ."$mod".($sta == "" ? "":" ($sta)").";$typ;WGS84;$operator;$timestamp;" - .substr($date,0,7)."#$id_evt\n"); - #FB-was:} elsif ($QryParm->{'dump'} eq "") { - } else { - push(@finalLignes,$line); - push(@numeroLigneReel,$l); - } - } - } + $l++; + my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat, + $nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature, + $comment) = split(/\|/,$line); + my ($operator,$timestamp) = split("/",$signature); + my $origin; + my $duree_s = ($duree ? $duree*$duration_s{$unite}:""); + my @evt_date_elem = split(/-/,$date); + my @evt_hour_elem = split(/:/,$heure); + my $evt_date = DateTime->new(year => $evt_date_elem[0], + month => $evt_date_elem[1], + day => $evt_date_elem[2], + hour => $evt_hour_elem[0]); + my $evt_amp = $valAmp{$amplitude}; + + # default timestamp for old data is event date + $timestamp = join('',@evt_date_elem)."T".join('',@evt_hour_elem) if ($timestamp eq ""); + my ($lat,$lon,$dep,$mag,$mty,$cod,$dat,$pha,$qua,$mod,$sta,$mth,$mdl,$typ); + +#XB-was: if (($date le $dateEnd && $date ge $dateStart) +#XB-was: && ($QryParm->{'duree'} eq "" || $QryParm->{'duree'} eq "NA" || $QryParm->{'duree'} eq "ALL" || $duree_s >= $QryParm->{'duree'}) + if ($evt_date ge $start_datetime && $evt_date le $end_datetime + && ($QryParm->{'duree'} ~~ ["", "NA", "ALL"] || $duree_s >= $QryParm->{'duree'} || length($qml) > 2) + && ($QryParm->{'amplitude'} ~~ ["", "ALL"] || $QryParm->{'ampoper'} eq 'eq' + || ($QryParm->{'ampoper'} eq 'le' && $evt_amp <= $valAmp{$QryParm->{'amplitude'}}) + || ($QryParm->{'ampoper'} eq 'ge' && $evt_amp >= $valAmp{$QryParm->{'amplitude'}})) + && ($QryParm->{'newts'} eq "" || $timestamp ge $QryParm->{'newts'}) + ) { + + # do not display location informations + if ($QryParm->{'hideloc'} == 1 || $MC3{SC3_EVENTS_ROOT} eq "") { + for (keys %QML) { + delete $QML{$_}; + } + } + +# ID SC3 case: load SC3ml file (et écrasement d'une éventuelle origine existante - cas de Zandets) + elsif ($MC3{SC3_EVENTS_ROOT} ne "" && $qml =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { + my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$qml); + %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$qml/$sc3id.last.xml"); + if (%QML) { + $origin = "$sc3id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; + } else { + $origin = ''; + } + $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; + } + + # ID FDSNWS case: request QuakeML file by FDSN webservice + elsif ($qml =~ /:\/\//) { + my ($fdsnws_src,$evt_id) = split(/:\/\//,$qml); + my $fdsnws_url = ""; + my $fdsnws_detail = ""; + if (defined($MC3{FDSNWS_EVENTS_URL})) { + $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; + } + if (length($fdsnws_src) > 0) { + my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; + $fdsnws_url = "$MC3{$varname}"; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; + $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_src"; + if (defined($MC3{$varname})) { + $fdsnws_detail = $MC3{$varname}; + } + } + %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); + if (%QML) { + + #[FB-note]: replaced by empty type in the SC3_EVENT_TYPES_NOLOCATION list + #$QML{type} = "not locatable" if ($QML{type} eq ""); + $origin = "$evt_id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; + } else { + $origin = ''; + } + $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; + } + + # Old suds ID case : + elsif (length($qml) < 3 && $HYPO_USE_FMT0_PATH) { + my @loca; + my $suds_sans_seconde; + my $suds_racine; + my $evt_annee4; + my $evt_mois; + if (length($suds) > 10 && ($suds =~ ".gwa" || $suds =~ ".mq0")) { + ($evt_annee4, $evt_mois) = unpack("a4 a2",$suds); + } else { + ($evt_annee4, $evt_mois) = unpack("a4 x a2",$date); + } + if (length($suds)==12 && substr($suds,8,1) eq '.') { + + # ne prend que les premiers caractères du nom de fichier + $suds_sans_seconde = substr($suds,0,7); + @loca = grep(/ $suds_sans_seconde/,grep(/^$evt_annee4$evt_mois/,@hypo)); + } elsif (length($suds)==19) { + $suds_racine = substr($suds,0,15); + @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); + } + for (@loca) { + my $id; + $dat = sprintf("%d-%02d-%02d %02d:%02d:%02.2f TU",substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,9,2),substr($_,11,2),substr($_,14,5)); + $mag = substr($_,47,5); + $mty = 'Md'; + $lat = substr($_,20,2) + substr($_,23,5)/60; + $lon = -(substr($_,30,2) + substr($_,33,5)/60); + $dep = substr($_,39,6); + $pha = substr($_,53,2); + $qua = substr($_,80,1); + $cod = substr($_,83,5); + if (length(substr($_,89))>15) { + $id = substr($_,89,15); + } + elsif (length(substr($_,89))<10) { + $id = substr($_,89); + } + $mod = 'manual'; + $origin = "$id;$dat;$lat;$lon;$dep;$pha;$mod;;$mag;$mty;Hypo71;;$cod"; + $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; + } + } + + ($cod,$dat,$lat,$lon,$dep,$pha,$mod,$sta,$mag,$mty,$mth,$mdl,$typ) = split(';',$origin); + my $noloc = 0; + $noloc = 1 if (grep(/^$typ$/,@nolocation_types)); + + if ($QryParm->{'located'} == 0 && $QryParm->{'locstatus'} == 0 + || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') + || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') + || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 0) + || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') + || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') + || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 0) + || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') + || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') + || $QryParm->{'hideloc'} == 1 ) { + if ($QryParm->{'dump'} eq 'bul') { + my $energy = ''; + if ($mag) { + + # Include energy in joules into the CSV output + $energy = compute_energy($mag); + } + push(@csv,join('',split(/-/,$date))." ".join('',split(/:/,$heure)).";" + ."$nombre;$duree_s;$amplitude;$mag;$energy;$lon;$lat;$dep;$type;$qml;" + + #.($mod eq 'manual' ? "1":"0").";WGS84;$operator;$timestamp;" + ."$mod".($sta == "" ? "":" ($sta)").";$typ;WGS84;$operator;$timestamp;" + .substr($date,0,7)."#$id_evt\n"); + + #FB-was:} elsif ($QryParm->{'dump'} eq "") { + } else { + push(@finalLignes,$line); + push(@numeroLigneReel,$l); + } + } + } } # ---- finalLignes = data to process, sorted ---------------------------------- @@ -837,17 +865,17 @@ sub compute_energy { my @stat_t; # Dates in YYYY-MM-DD format my @stat_j; # Javascript dates (in ms since 1970-01-01) for my $d (0..($nbDays - 1/24)) { - push(@stat_t, ($start_datetime + DateTime::Duration->new(days => $d))->strftime('%F')); - push(@stat_j, ($start_datetime + DateTime::Duration->new(days => $d) + DateTime::Duration->new(hours => 12))->epoch * 1000); + push(@stat_t, ($start_datetime + DateTime::Duration->new(days => $d))->strftime('%F')); + push(@stat_j, ($start_datetime + DateTime::Duration->new(days => $d) + DateTime::Duration->new(hours => 12))->epoch * 1000); } my @stat_th; my @stat_jh; # Javascript dates hourly (in ms since 1970-01-01) for my $h (0 .. ($nbDays*24 - 1)) { - my $d = $start_datetime + DateTime::Duration->new(hours => $h); - if ($d <= $now) { - push(@stat_th, $d->strftime('%F %H')); - push(@stat_jh, $d->epoch*1000); - } + my $d = $start_datetime + DateTime::Duration->new(hours => $h); + if ($d <= $now) { + push(@stat_th, $d->strftime('%F %H')); + push(@stat_jh, $d->epoch*1000); + } } my %stat_m; # hash of event types seismic moment per day my %stat_energy; # hash of event types seismic energy per day @@ -866,150 +894,154 @@ sub compute_energy { my $stat_max_duration_loc = 0; my $stat_max_magnitude_loc = 0; foreach (@finalLignes) { - if ( $_ ne "" ) { - my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); - if (!$nombre) { $nombre = 1; } - my $time = timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2),substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900); - my $duree_s = ($duree ? $duree*$duration_s{$unite}:0); - # computes index into data array from time - my $time_dt = DateTime->new(year => substr($date,0,4), - month => substr($date,5,2), - day => substr($date,8,2), - hour => substr($heure,0,2), - minute => substr($heure,3,2), - second => substr($heure,6,2)); - my $kd = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/86400); - my $kh = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/3600); - if ($origin) { - my @orig = split(';',$origin); - if ($orig[0]) { - # Event has an ID - my $M0 = 0; - my $km = 0; - my $mag = $orig[8]; - if ($mag) { - $M0 = 10**(1.5*$mag + 9.1); # unit = N.m - $stat_m{$type}[$kd] += $M0; - $stat_smh{$type}[$kh] += $M0; - $km = int($mag*10); - # negative magnitudes are counted in the first histogram bin - if ($km < 0) { $km = 0; } - $stat_grm[$km] = $km/10; - $stat_gr{$type}[$km] += 1; - - # Seismic energy calculation (J) - my $energy = compute_energy($mag); - $stat_energy{$type}[$kd] += $energy; - $stat_energy{TOTAL}[$kd] += $energy; - } - } - } - $stat{$type} += $nombre; - $stat{TOTAL} += $nombre; - $stat{VTcount} += ($types{$type}{asVT} ? $nombre * $types{$type}{asVT}:0); - $stat{RFcount} += ($types{$type}{asRF} ? $nombre * $types{$type}{asRF}:0); - if ($type eq "LOCAL") { - $stat{LOCcount} += $nombre; - } - - $stat_d{$type}[$kd] += $nombre; - if ($QryParm->{'nograph'} == 0) { - $stat_ch{$type}[$kh] += $nombre; - $stat_dh{$type}[$kh] += $nombre; - for ($kh .. ($kh+23)) { - $stat_vh{$type}[$_] += $nombre if ($_ <= $#stat_th); - } - for ($kh .. ($kh+(7*24-1))) { - $stat_wh{$type}[$_] += $nombre if ($_ <= $#stat_th); - } - for ($kh .. ($kh+(28*24-1))) { - $stat_mh{$type}[$_] += $nombre if ($_ <= $#stat_th); - } - } - my $dist; - my $Pvel = 6; - $Pvel = $MC3{P_WAVE_VELOCITY} if (defined $MC3{P_WAVE_VELOCITY}); - my $VpVs = 1.75; - $VpVs = $MC3{VP_VS_RATIO} if (defined $MC3{VP_VS_RATIO}); - if ($s_moins_p ne "NA" && $s_moins_p ne "") { - $dist = $Pvel*$s_moins_p/($VpVs-1); - } else { - $dist = 0; - } - if ($types{$type}{asVT} && $duree_s > $stat_max_duration) { - $stat_max_duration = $duree_s; - $stat_max_magnitude = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; - } - if ($type eq "LOCAL" && $duree_s > $stat_max_duration_loc) { - $stat_max_duration_loc = $duree_s; - $stat_max_magnitude_loc = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; - } - } + if ( $_ ne "" ) { + my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); + if (!$nombre) { $nombre = 1; } + my $time = timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2),substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900); + my $duree_s = ($duree ? $duree*$duration_s{$unite}:0); + + # computes index into data array from time + my $time_dt = DateTime->new(year => substr($date,0,4), + month => substr($date,5,2), + day => substr($date,8,2), + hour => substr($heure,0,2), + minute => substr($heure,3,2), + second => substr($heure,6,2)); + my $kd = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/86400); + my $kh = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/3600); + if ($origin) { + my @orig = split(';',$origin); + if ($orig[0]) { + + # Event has an ID + my $M0 = 0; + my $km = 0; + my $mag = $orig[8]; + if ($mag) { + $M0 = 10**(1.5*$mag + 9.1); # unit = N.m + $stat_m{$type}[$kd] += $M0; + $stat_smh{$type}[$kh] += $M0; + $km = int($mag*10); + + # negative magnitudes are counted in the first histogram bin + if ($km < 0) { $km = 0; } + $stat_grm[$km] = $km/10; + $stat_gr{$type}[$km] += 1; + + # Seismic energy calculation (J) + my $energy = compute_energy($mag); + $stat_energy{$type}[$kd] += $energy; + $stat_energy{TOTAL}[$kd] += $energy; + } + } + } + $stat{$type} += $nombre; + $stat{TOTAL} += $nombre; + $stat{VTcount} += ($types{$type}{asVT} ? $nombre * $types{$type}{asVT}:0); + $stat{RFcount} += ($types{$type}{asRF} ? $nombre * $types{$type}{asRF}:0); + if ($type eq "LOCAL") { + $stat{LOCcount} += $nombre; + } + + $stat_d{$type}[$kd] += $nombre; + if ($QryParm->{'nograph'} == 0) { + $stat_ch{$type}[$kh] += $nombre; + $stat_dh{$type}[$kh] += $nombre; + for ($kh .. ($kh+23)) { + $stat_vh{$type}[$_] += $nombre if ($_ <= $#stat_th); + } + for ($kh .. ($kh+(7*24-1))) { + $stat_wh{$type}[$_] += $nombre if ($_ <= $#stat_th); + } + for ($kh .. ($kh+(28*24-1))) { + $stat_mh{$type}[$_] += $nombre if ($_ <= $#stat_th); + } + } + my $dist; + my $Pvel = 6; + $Pvel = $MC3{P_WAVE_VELOCITY} if (defined $MC3{P_WAVE_VELOCITY}); + my $VpVs = 1.75; + $VpVs = $MC3{VP_VS_RATIO} if (defined $MC3{VP_VS_RATIO}); + if ($s_moins_p ne "NA" && $s_moins_p ne "") { + $dist = $Pvel*$s_moins_p/($VpVs-1); + } else { + $dist = 0; + } + if ($types{$type}{asVT} && $duree_s > $stat_max_duration) { + $stat_max_duration = $duree_s; + $stat_max_magnitude = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; + } + if ($type eq "LOCAL" && $duree_s > $stat_max_duration_loc) { + $stat_max_duration_loc = $duree_s; + $stat_max_magnitude_loc = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; + } + } } my $total = 0; $i = 0; foreach my $day (@stat_t) { - my $daily_count = 0; - my $daily_moment = 0; - my $daily_energy = 0; - foreach my $evt_type (keys(%stat_d)) { - $daily_count += $stat_d{$evt_type}[$i] || 0; - $daily_moment += $stat_m{$evt_type}[$i] || 0; - - # Cumulate the total events energy for this day - $daily_energy += $stat_energy{$evt_type}[$i] || 0; - - # Also add up daily energy for this type of event - $stat_energy{$evt_type}[$i] += ($stat_energy{$evt_type}[$i-1] || 0) unless ($i == 0); - } - # Store the total daily energy - $stat_energy{TOTAL}[$i] = ($i > 0 ? $stat_energy{TOTAL}[$i-1] : 0) + $daily_energy; - - if ($QryParm->{'dump'} eq 'cum') { - push(@csv, sprintf("%s;%d;%g;%e\n", $day, $daily_count, $daily_moment, $daily_energy)); - } - $total += $daily_count; - $i++; + my $daily_count = 0; + my $daily_moment = 0; + my $daily_energy = 0; + foreach my $evt_type (keys(%stat_d)) { + $daily_count += $stat_d{$evt_type}[$i] || 0; + $daily_moment += $stat_m{$evt_type}[$i] || 0; + + # Cumulate the total events energy for this day + $daily_energy += $stat_energy{$evt_type}[$i] || 0; + + # Also add up daily energy for this type of event + $stat_energy{$evt_type}[$i] += ($stat_energy{$evt_type}[$i-1] || 0) unless ($i == 0); + } + + # Store the total daily energy + $stat_energy{TOTAL}[$i] = ($i > 0 ? $stat_energy{TOTAL}[$i-1] : 0) + $daily_energy; + + if ($QryParm->{'dump'} eq 'cum') { + push(@csv, sprintf("%s;%d;%g;%e\n", $day, $daily_count, $daily_moment, $daily_energy)); + } + $total += $daily_count; + $i++; } if ($QryParm->{'nograph'} == 0) { - for ($i = 1; $i <= $#stat_th; $i++) { - foreach (keys(%stat_smh)) { - $stat_smh{$_}[$i] += ($stat_smh{$_}[$i-1] ? $stat_smh{$_}[$i-1]:0); - } - foreach (keys(%stat_ch)) { - $stat_ch{$_}[$i] += ($stat_ch{$_}[$i-1] ? $stat_ch{$_}[$i-1]:0); - } - } - for ($i = $#stat_grm - 1; $i >= 0; $i--) { - if (!$stat_grm[$i]) { - $stat_grm[$i] = $i/10; - } - foreach (keys(%stat_gr)) { - $stat_gr{$_}[$i] += ($stat_gr{$_}[$i+1] ? $stat_gr{$_}[$i+1]:0); - } - } - my @key = keys(%stat_gr); - for ($i = 0; $i <= $#stat_grm; $i++) { - foreach (@key) { - $stat_gr{TOTAL}[$i] += ($stat_gr{$_}[$i] ? $stat_gr{$_}[$i]:0); - } - } + for ($i = 1; $i <= $#stat_th; $i++) { + foreach (keys(%stat_smh)) { + $stat_smh{$_}[$i] += ($stat_smh{$_}[$i-1] ? $stat_smh{$_}[$i-1]:0); + } + foreach (keys(%stat_ch)) { + $stat_ch{$_}[$i] += ($stat_ch{$_}[$i-1] ? $stat_ch{$_}[$i-1]:0); + } + } + for ($i = $#stat_grm - 1; $i >= 0; $i--) { + if (!$stat_grm[$i]) { + $stat_grm[$i] = $i/10; + } + foreach (keys(%stat_gr)) { + $stat_gr{$_}[$i] += ($stat_gr{$_}[$i+1] ? $stat_gr{$_}[$i+1]:0); + } + } + my @key = keys(%stat_gr); + for ($i = 0; $i <= $#stat_grm; $i++) { + foreach (@key) { + $stat_gr{TOTAL}[$i] += ($stat_gr{$_}[$i] ? $stat_gr{$_}[$i]:0); + } + } } my $nbD = int($nbDays); $html .= "

    Selection: $nbD day".($nbD>1 ? "s":""); if ($nbDays - $nbD != 0) { - my $nbH = int(($nbDays - $nbD)*24); - $html .= " $nbH hour".($nbH>1 ? "s":""); + my $nbH = int(($nbDays - $nbD)*24); + $html .= " $nbH hour".($nbH>1 ? "s":""); } if ($nbDays > 365) { - my $nbY = int($nbDays/365.25 + 0.5); - my $nbM = int(($nbDays%365.25)/30.4 + 0.5); - $html .= " ( ~ $nbY year".($nbY>1 ? "s":"")." $nbM month".($nbM>1 ? "s":"")." ) ";; + my $nbY = int($nbDays/365.25 + 0.5); + my $nbM = int(($nbDays%365.25)/30.4 + 0.5); + $html .= " ( ~ $nbY year".($nbY>1 ? "s":"")." $nbM month".($nbM>1 ? "s":"")." ) ";; } elsif ($nbDays > 30) { - my $nbM = int($nbDays/30. + 0.5); - $html .= " ( ~ $nbM month".($nbM>1 ? "s":"")." ) "; + my $nbM = int($nbDays/30. + 0.5); + $html .= " ( ~ $nbM month".($nbM>1 ? "s":"")." ) "; } $html .= "

    Total number of events: $total

    "; $html .= qq(

    Cumulated energy:).sprintf(" %.3e MJ", $stat_energy{TOTAL}[-1] / 10**6).qq(

    ); @@ -1017,30 +1049,31 @@ sub compute_energy { $html .= "

    Events bulletin:

    "; $html .= "\n"; - # ---- HTML-form for Information mailing # if ($MC3{DISPLAY_INFO_MAIL} && (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3"))) { - $html .= "
    "; - $html .= "

    Mail d'information:

    "; - #XB-was: $html .= ""; - #XB-was: $html .= ""; - $html .= "strftime("%F")."\"/>"; - $html .= "strftime("%F")."\"/>"; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= "
    \n"; - $html .= "
    "; - $html .= "

    Mail d'information REVOSIMA:

    "; - $html .= "strftime("%F")."\"/>"; - $html .= "strftime("%F")."\"/>"; - $html .= "
    \n"; + $html .= "
    "; + $html .= "

    Mail d'information:

    "; + +#XB-was: $html .= ""; +#XB-was: $html .= ""; + $html .= "strftime("%F")."\"/>"; + $html .= "strftime("%F")."\"/>"; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= "
    \n"; + $html .= "
    "; + $html .= "

    Mail d'information REVOSIMA:

    "; + $html .= "strftime("%F")."\"/>"; + $html .= "strftime("%F")."\"/>"; + $html .= "
    \n"; } + # ---- END of HTML-form #print ""; @@ -1050,94 +1083,96 @@ sub compute_energy { #print ""; #print "
    Total
    $total
    ", $html .= "
    " - ."
    "; + ."
    "; # ---- JavaScript for graphs with flot.js ------------------------------------- # if ($QryParm->{'nograph'} == 0) { - my @stat_v; - $html .= "\n"; + my @stat_v; + $html .= "\n"; } # ---- start building main table ---------------------------------------------- @@ -1145,51 +1180,55 @@ sub compute_energy { $html .= ""; @titres = split(/\|/,$ligneTitre[0]); for (my $i = 0; $i <= $#titres; $i++) { - if ($QryParm->{'hideloc'} == 0 || $i < 15 ) { - $html .= ""; - } + if ($QryParm->{'hideloc'} == 0 || $i < 15 ) { + $html .= ""; + } } $html .= ""; # ---- build/display main table ----------------------------------------------- # for (@finalLignes) { - if ( $_ ne "") { - my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); - my ($operator,$timestamp) = split("/",$signature); - my ($evt_annee4,$evt_mois,$evt_jour,$suds_jour,$suds_heure,$suds_minute,$suds_seconde,$suds_reseau) = split; - my $diriaspei; - my $suds_continu; - my $dirTrigger; - my $dirTriggerUrn; - my $seedlink; - my $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&date=".substr($date,0,4).substr($date,5,2).substr($date,8,2).substr($heure,0,2).substr($heure,3,2).substr($heure,6,2)."&id=$id_evt"; - my $begin = strftime('%Y,%m,%d,%H,%M,%S', - gmtime(timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2), - substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900)-10)); - my $duree_s = ($duree ne "" ? $duree*$duration_s{$unite}:0); - my $durmseed = ($duree_s + 20); - if (length($suds) > 10 && $suds =~ ".gwa") { - ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); - $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_GWA}."/".$evt_annee4.$evt_mois.$suds_jour; - $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".gwa"; - #djl-was:$editURL = "frameMC2.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; - } elsif (length($suds) > 10 && $suds =~ ".mq0") { - ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); - $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_MQ0}."/".$evt_annee4.$evt_mois.$suds_jour; - $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".mar"; - #djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; - } elsif (length($suds) > 10 && $suds =~ ".GUA" || $suds =~ ".GUX" || $suds =~ ".gl0") { - ($suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a2 a2 a2 a2 x a3",$suds); - ($evt_annee4,$evt_mois,$evt_jour) = split(/-/,$date); - $diriaspei = $WEBOBS{"PATH_SOURCE_SISMO_$suds_reseau"}."/".$evt_annee4.$evt_mois.$suds_jour; - #djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; - } else { - ($evt_annee4, $evt_mois, $suds_jour) = unpack("a4 x a2 x a2",$date); - ($suds_heure,$suds_minute) = unpack("a2 x a2",$heure); - $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&s3=$suds&date=$evt_annee4$evt_mois$suds_jour$suds_heure$suds_minute&id=$id_evt"; - $seedlink = 1; - } + if ( $_ ne "") { + my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); + my ($operator,$timestamp) = split("/",$signature); + my ($evt_annee4,$evt_mois,$evt_jour,$suds_jour,$suds_heure,$suds_minute,$suds_seconde,$suds_reseau) = split; + my $diriaspei; + my $suds_continu; + my $dirTrigger; + my $dirTriggerUrn; + my $seedlink; + my $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&date=".substr($date,0,4).substr($date,5,2).substr($date,8,2).substr($heure,0,2).substr($heure,3,2).substr($heure,6,2)."&id=$id_evt"; + my $begin = strftime('%Y,%m,%d,%H,%M,%S', + gmtime(timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2), + substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900)-10)); + my $duree_s = ($duree ne "" ? $duree*$duration_s{$unite}:0); + my $durmseed = ($duree_s + 20); + if (length($suds) > 10 && $suds =~ ".gwa") { + ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); + $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_GWA}."/".$evt_annee4.$evt_mois.$suds_jour; + $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".gwa"; + +#djl-was:$editURL = "frameMC2.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; + } elsif (length($suds) > 10 && $suds =~ ".mq0") { + ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); + $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_MQ0}."/".$evt_annee4.$evt_mois.$suds_jour; + $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".mar"; + +#djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; + } elsif (length($suds) > 10 && $suds =~ ".GUA" || $suds =~ ".GUX" || $suds =~ ".gl0") { + ($suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a2 a2 a2 a2 x a3",$suds); + ($evt_annee4,$evt_mois,$evt_jour) = split(/-/,$date); + $diriaspei = $WEBOBS{"PATH_SOURCE_SISMO_$suds_reseau"}."/".$evt_annee4.$evt_mois.$suds_jour; + +#djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; + } else { + ($evt_annee4, $evt_mois, $suds_jour) = unpack("a4 x a2 x a2",$date); + ($suds_heure,$suds_minute) = unpack("a2 x a2",$heure); + $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&s3=$suds&date=$evt_annee4$evt_mois$suds_jour$suds_heure$suds_minute&id=$id_evt"; + $seedlink = 1; + } + # JMS was # $dirTrigger = "$WEBOBS{SISMOCP_PATH_FTP}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; # $dirTriggerUrn = "$WEBOBS{SISMOCP_PATH_FTP_URN}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; @@ -1199,7 +1238,7 @@ sub compute_energy { # my $suds_racine; # my $suds_ext; # my $suds2_pointe; - #djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { +#djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { # if (length($suds)==12 && substr($suds,8,1) eq '.') { # # ne prend que les premiers caractères du nom de fichier # $suds_sans_seconde = substr($suds,0,7); @@ -1212,28 +1251,29 @@ sub compute_energy { # @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); # } - my @lat; - my @lon; - my @dep; - my @mag; - my @mth; - my @mdl; - my @typ; - my @mty; - my @cod; - my @msk; - my @dat; - my @pha; - my @qua; - my @mod; - my @sta; - my @bcube; - my @nomB3; - my $isNotManuel = 1; - my $gse = ""; - - my $ii; - if ($QryParm->{'hideloc'} == 0) { + my @lat; + my @lon; + my @dep; + my @mag; + my @mth; + my @mdl; + my @typ; + my @mty; + my @cod; + my @msk; + my @dat; + my @pha; + my @qua; + my @mod; + my @sta; + my @bcube; + my @nomB3; + my $isNotManuel = 1; + my $gse = ""; + + my $ii; + if ($QryParm->{'hideloc'} == 0) { + # JMS was # if ($HYPO_USE_FMT0_PATH) { # $ii = 0; @@ -1261,7 +1301,7 @@ sub compute_energy { # .substr($_,0,8)."T".sprintf("%02.0f",substr($_,9,2)).sprintf("%02.0f",substr($_,11,2)) # .sprintf("%02.0f",substr($_,14,5))."_b3"; # } - # calcul de la distance epicentrale minimum (et azimut epicentre/villes) +# calcul de la distance epicentrale minimum (et azimut epicentre/villes) # for (0..$#b3_lat) { # my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); # my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; @@ -1273,353 +1313,371 @@ sub compute_energy { # } # } - # si le séisme a été localisé, les infos sont dans le champ $origin - if ($origin) { - ($cod[0],$dat[0],$lat[0],$lon[0],$dep[0],$pha[0],$mod[0],$sta[0],$mag[0],$mty[0],$mth[0],$mdl[0],$typ[0]) = split(';',$origin); - if($mod[0] eq 'manual' && $type eq 'AUTO') { - $type = 'UNKNOWN'; - } - - for ($ii = 0; $ii <= $#dat; $ii++) { - # calcul de la distance epicentrale minimum (et azimut epicentre/villes) - for (0..$#b3_lat) { - my ($dist,$bear) = greatcircle($b3_lat[$_],$b3_lon[$_],$lat[$ii],$lon[$ii]); - #my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); - #my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; - #$b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",sqrt($dx**2 + $dy**2),atan2($dy,$dx),$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); - $b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",$dist,$bear,$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); - } - my @xx = sort { $a cmp $b } @b3_dat; - $bcube[$ii] = $xx[0]; - if ($MC3{TREMBLEMAPS_PROC}) { - $nomB3[$ii] = substr($dat[$ii],0,4)."/".substr($dat[$ii],5,2)."/".substr($dat[$ii],8,2)."/$cod[$ii]"; - } - # cas d'une loc au format hyp71sum2k - if ($HYPO_USE_FMT0_PATH && (substr($typ[$ii],2,1) =~ /[2-9]{1}/)) { - $msk[$ii] = romanx(substr($typ[$ii],2,1)); - } - } - } - } - - ($duree_sat eq 0) and $duree_sat = " "; - ($s_moins_p eq 0) and $s_moins_p = " "; - - my $code = $station; - # extraction du code station (depuis NET.STA.LOC.CHA) - if ($station =~ /\./) { - my @stream = split(/\./,$station); - #$code = substr($stream[1],0,3); - $code = $stream[1]; - } - - # mise en evidence du filtre et pop-up - my $typeAff = ($types{$type}{Name} ? $types{$type}{Name}:""); - my $imageCAPTION = "$date $heure UT"; - my $imagePOPUP = "$typeAff $duree s $code - $comment [$operator]"; - if ($QryParm->{'obs'} ne "") { - #if (grep(/$QryParm->{'obs'}/i,$type)) { - # $typeAff =~ s/($QryParm->{'obs'})/$1<\/span>/ig; - #} - if (grep(/$QryParm->{'obs'}/i,$station)) { - $station =~ s/($QryParm->{'obs'})/$1<\/span>/ig; - } - if (grep(/$QryParm->{'obs'}/i,$comment)) { - $comment =~ s/($QryParm->{'obs'})/$1<\/span>/ig; - } - } - my $tc = $type; - if ($operator eq $MC3{SC3_USER}) { $tc = "AUTO"; } - - $html .= ""; - - # --- edit button - $html .= ""; - my $tmp = "$evt_annee4$evt_mois"; - - # --- computes distance and duration magnitude - my $md; - my $dist = -1; - if ($types{$type}{Md} == 0) { - $dist = 0; - } - if ($s_moins_p && !($s_moins_p ~~ ["","NA"," "]) && $types{$type}{Md} != -1) { - $dist = 8*$s_moins_p; - } - if ($duree_s > 0 && $dist >= 0) { - $md = sprintf("%.1f",2*log($duree_s)/log(10)+0.0035*$dist-0.87); - $html .= ""; - } else { - $html .= ""; - } - - # --- first arrival station - if ($arrivee eq "0") { - $html .= ""; - } else { - $html .= ""; - } - - # --- date and hour - $html .= "" - .""; - - # --- number of event - $html .= ""; - - # --- type of event - $html .= "$typeAff"; - my $amplitude_texte = ($amplitude ? (($amplitude eq "Sature" || $amplitude eq "OVERSCALE") ? "$namAmp{$amplitude} ($duree_sat s)" : "$namAmp{$amplitude}"):""); - my $amplitude_img = "/icons/signal_amplitude_".lc($amplitude).".png"; - if (! -e "$WEBOBS{ROOT_CODE}/$amplitude_img" ) { - $amplitude_img = "/icons/signal_amplitude_.png"; - } - $html .= ""; - - # --- duree - $html .= ""; - - # --- S-P - $html .= ""; - - # --- link to the waveform signal - $html .= ""; - - #print ""; - - # --- link to Sefran screenshot - $html .= ""; - - # --- comment - $html .= ""; - - # S'il y a au moins une localisation correspondante à l'événement: extraction des infos et calculs - $ii = 0; - for (@dat) { - # S'il y a une localisation validée, on n'affiche pas la localisation automatique - if ( ($isNotManuel && ($cod[$ii] eq "XXX ")) || $cod[$ii] ne "XXX " ) { - # Si la localisation est automatique, surlignage - # S'il y en a plus d'une, elles sont mises sur des lignes en-dessous, qui ne répetent pas les dates/heures - if ($ii > 0) { - $html .= "\n"; - $html .= "" - .""; - } else { - $html .= "  not locatable"; - } - - # --- Event energy calculation in joules (displayed in the popover for the magnitude column) - my $popover_attrs = ""; - if ($mag[$ii]) { - my $mag_disp = sprintf("%.2f %s", $mag[$ii], $mty[$ii]); - my $energy_disp = sprintf("%.3e", compute_energy($mag[$ii])); - my $popover_text = qq(Magnitude: $mag_disp
    ); - $popover_text .= qq(Energy: $energy_disp J
    ); - $popover_attrs = qq(onMouseOut="nd()" onMouseOver="overlib('$popover_text', CAPTION, 'Mag / Energy', WIDTH, 140)"); - } - - # --- Magnitude - $html .= qq("; - - # --- EMS - #if ($MC3{SISMOHYP_HYPO_USE} > 0) { - $html .= ""; - #} - - # Lien vers le B-Cube - if ($nomB3[$ii]) { - $html .= ""; - } - $ii++; - } - $html .= ($ii == 0 ? "\n"; - $nbLignesRetenues++; - } + # si le séisme a été localisé, les infos sont dans le champ $origin + if ($origin) { + ($cod[0],$dat[0],$lat[0],$lon[0],$dep[0],$pha[0],$mod[0],$sta[0],$mag[0],$mty[0],$mth[0],$mdl[0],$typ[0]) = split(';',$origin); + if($mod[0] eq 'manual' && $type eq 'AUTO') { + $type = 'UNKNOWN'; + } + + for ($ii = 0; $ii <= $#dat; $ii++) { + + # calcul de la distance epicentrale minimum (et azimut epicentre/villes) + for (0..$#b3_lat) { + my ($dist,$bear) = greatcircle($b3_lat[$_],$b3_lon[$_],$lat[$ii],$lon[$ii]); + +#my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); +#my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; +#$b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",sqrt($dx**2 + $dy**2),atan2($dy,$dx),$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); + $b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",$dist,$bear,$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); + } + my @xx = sort { $a cmp $b } @b3_dat; + $bcube[$ii] = $xx[0]; + if ($MC3{TREMBLEMAPS_PROC}) { + $nomB3[$ii] = substr($dat[$ii],0,4)."/".substr($dat[$ii],5,2)."/".substr($dat[$ii],8,2)."/$cod[$ii]"; + } + + # cas d'une loc au format hyp71sum2k + if ($HYPO_USE_FMT0_PATH && (substr($typ[$ii],2,1) =~ /[2-9]{1}/)) { + $msk[$ii] = romanx(substr($typ[$ii],2,1)); + } + } + } + } + + ($duree_sat eq 0) and $duree_sat = " "; + ($s_moins_p eq 0) and $s_moins_p = " "; + + my $code = $station; + + # extraction du code station (depuis NET.STA.LOC.CHA) + if ($station =~ /\./) { + my @stream = split(/\./,$station); + + #$code = substr($stream[1],0,3); + $code = $stream[1]; + } + + # mise en evidence du filtre et pop-up + my $typeAff = ($types{$type}{Name} ? $types{$type}{Name}:""); + my $imageCAPTION = "$date $heure UT"; + my $imagePOPUP = "$typeAff $duree s $code - $comment [$operator]"; + if ($QryParm->{'obs'} ne "") { + + #if (grep(/$QryParm->{'obs'}/i,$type)) { + # $typeAff =~ s/($QryParm->{'obs'})/$1<\/span>/ig; + #} + if (grep(/$QryParm->{'obs'}/i,$station)) { + $station =~ s/($QryParm->{'obs'})/$1<\/span>/ig; + } + if (grep(/$QryParm->{'obs'}/i,$comment)) { + $comment =~ s/($QryParm->{'obs'})/$1<\/span>/ig; + } + } + my $tc = $type; + if ($operator eq $MC3{SC3_USER}) { $tc = "AUTO"; } + + $html .= ""; + + # --- edit button + $html .= ""; + my $tmp = "$evt_annee4$evt_mois"; + + # --- computes distance and duration magnitude + my $md; + my $dist = -1; + if ($types{$type}{Md} == 0) { + $dist = 0; + } + if ($s_moins_p && !($s_moins_p ~~ ["","NA"," "]) && $types{$type}{Md} != -1) { + $dist = 8*$s_moins_p; + } + if ($duree_s > 0 && $dist >= 0) { + $md = sprintf("%.1f",2*log($duree_s)/log(10)+0.0035*$dist-0.87); + $html .= ""; + } else { + $html .= ""; + } + + # --- first arrival station + if ($arrivee eq "0") { + $html .= ""; + } else { + $html .= ""; + } + + # --- date and hour + $html .= "" + .""; + + # --- number of event + $html .= ""; + + # --- type of event + $html .= "$typeAff"; + my $amplitude_texte = ($amplitude ? (($amplitude eq "Sature" || $amplitude eq "OVERSCALE") ? "$namAmp{$amplitude} ($duree_sat s)" : "$namAmp{$amplitude}"):""); + my $amplitude_img = "/icons/signal_amplitude_".lc($amplitude).".png"; + if (! -e "$WEBOBS{ROOT_CODE}/$amplitude_img" ) { + $amplitude_img = "/icons/signal_amplitude_.png"; + } + $html .= ""; + + # --- duree + $html .= ""; + + # --- S-P + $html .= ""; + + # --- link to the waveform signal + $html .= ""; + + #print ""; + + # --- link to Sefran screenshot + $html .= ""; + + # --- comment + $html .= ""; + +# S'il y a au moins une localisation correspondante à l'événement: extraction des infos et calculs + $ii = 0; + for (@dat) { + +# S'il y a une localisation validée, on n'affiche pas la localisation automatique + if ( ($isNotManuel && ($cod[$ii] eq "XXX ")) || $cod[$ii] ne "XXX " ) { + +# Si la localisation est automatique, surlignage +# S'il y en a plus d'une, elles sont mises sur des lignes en-dessous, qui ne répetent pas les dates/heures + if ($ii > 0) { + $html .= "\n"; + $html .= "" + .""; + } else { + $html .= "  not locatable"; + } + +# --- Event energy calculation in joules (displayed in the popover for the magnitude column) + my $popover_attrs = ""; + if ($mag[$ii]) { + my $mag_disp = sprintf("%.2f %s", $mag[$ii], $mty[$ii]); + my $energy_disp = sprintf("%.3e", compute_energy($mag[$ii])); + my $popover_text = qq(Magnitude: $mag_disp
    ); + $popover_text .= qq(Energy: $energy_disp J
    ); + $popover_attrs = qq(onMouseOut="nd()" onMouseOver="overlib('$popover_text', CAPTION, 'Mag / Energy', WIDTH, 140)"); + } + + # --- Magnitude + $html .= qq("; + + # --- EMS + #if ($MC3{SISMOHYP_HYPO_USE} > 0) { + $html .= ""; + + #} + + # Lien vers le B-Cube + if ($nomB3[$ii]) { + $html .= ""; + } + $ii++; + } + $html .= ($ii == 0 ? "\n"; + $nbLignesRetenues++; + } } $html .= "
    $titres[$i]$titres[$i]
    "; - if ($editURL ne "") { - my $msg = "View..."; - my $ico = "view.png"; - if ( (($operator eq "" || $operator eq $CLIENT || $type eq "AUTO") - && (clientHasEdit(type=>"authprocs",name=>"MC") ||clientHasEdit(type=>"authprocs",name=>"$mc3"))) || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) { - $msg = "Edit..."; - $ico = "modif.png"; - } - $html .= qq() - .qq(); - } else { $html .= " " } - $html .= "$md".sprintf("%.0f",$dist)."  $code$code $date  $heure  ".($nombre gt 1 ? "$nombre" : $nombre)." ×$amplitude_texte".($duree ? sprintf("%1.1f %s",$duree,$unite):"")."".($s_moins_p eq "NA" ? " " : "$s_moins_p").""; - #djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { - #if (length($suds)==12 && substr($suds,8,1) eq '.') { - # for(@suds_liste) { - # $html .= ""; - # } - #} elsif (-f "$dirTrigger/$suds2_pointe") { - # for my $lettre ("a".."z") { - # $suds2_pointe = "${suds_racine}_${lettre}.${suds_ext}"; - # if (-f "$dirTrigger/$suds2_pointe") { - # $html .= ""; - # } - # } - #} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { - # $html .= ""; - #} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { - # $html .= ""; - #} elsif (-f "$WEBOBS{RACINE_SIGNAUX_SISMO}/$diriaspei/$suds") { - # $html .= ""; - #} elsif ($suds eq $nosuds) { - # $html .= ""; - #} elsif ($seedlink) { - # [FXB] AJOUTER &all=1 lorsque le serveur ArcLink acceptera les wildcards... - $html .= ""; - #} else { - # $html .= "($suds)"; - #} - $html .= "$sc3id"; - #FB-was: my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois/$MC3{FILE_PREFIX}$event_img"; - my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois"; - my $event_img_path = "$MC3{ROOT}/$event_img_subdir/$event_img"; - - # Split the MC3 column value on commas in case multiple images were to be displayed - my @img_list = map { $_ =~ s/^\s+|\s+$//g; $_; } split(/,/, "$event_img"); - - if (@img_list) { - # Define the icon visible in the MC3 'Sefran' column - # (wolbtarget designates the gallery of images to display defined below) - $html .= ""; - - # Add all collected images to a unique common gallery (same wolbset) - for my $img (@img_list) { - $html .= ""; - } - } else { - # No image was designated in the MC3 entry - $html .= " "; - } - - # --- operator - $html .= "$operator$comment
    "; - } - # Distance et direction d'après B3 - my $noloc = 0; - $noloc = 1 if (grep(/^$typ[$ii]$/,@nolocation_types)); - my $sc3AutoStyle = ($mod[$ii] eq 'automatic' || $noloc == 1 ? "color:gray":""); - my @b3; - my $town; - my $pga; - my $pgamax; - my $dir; - my $dkm; - my $ems; - my $emsmax; - if ($bcube[$ii]) { - @b3 = split(/\|/,$bcube[$ii]); - $b3[2] =~ s/\'/\`/g; - $town = $b3[2]; - #DL-was: if ($b3[4] != $WEBOBS{SHAKEMAPS_COMMUNES_PLACE}) { - if ($b3[3] ne $MC3{CITIES_PLACE}) { - $town = $b3[3]; - } - $pga = attenuation(($mag[$ii] ? $mag[$ii]:0),sqrt($b3[0]**2 + ($dep[$ii] ne "" ? $dep[$ii]**2:0))); - #DL-was: my $pgamax = $pga*$WEBOBS{SHAKEMAPS_SITE_EFFECTS}; - #FB-was: $pgamax = $pga*$MC3{CITIES_SITE_EFFECTS}; - $pgamax = $pga*($b3[4] > 0 ? $b3[4]:3); - $dir = compass($b3[1]); - $dkm = sprintf("%5.1f",$b3[0]); - $dkm =~ s/\s/  /g; - $ems = pga2msk($pga); - $emsmax = pga2msk($pgamax); - } - my $M_A = "M":"red>A").""; - - # Info-bulle avec les détails de la localisation - $html .= "$M_A%1.2f
    ",$mty[$ii],$mag[$ii]):"") - .($lat[$ii] < 0 ? sprintf("%2.2f°S",-$lat[$ii]):sprintf("%2.2f°N",$lat[$ii])) - ."  " - .($lon[$ii] < 0 ? sprintf("%2.2f°W",-$lon[$ii]):sprintf("%2.2f°E",$lon[$ii])) - .($dep[$ii] ? "  ".sprintf("%1.1f km",$dep[$ii]):"")."
    " - .(@b3 ? "$dkm km $dir $town
    ":""); - } - $html .="$pha[$ii] phases".($qua[$ii] ? " ($qua[$ii])":"")." / $mod[$ii]".($sta[$ii] ne "" ? " ($sta[$ii])":"")."
    " - .($mth[$ii] ne "" || $mdl[$ii] ne "" ? "$mth[$ii] / $mdl[$ii]
    ":"") - .($typ[$ii] ne "" ? "$typ[$ii]
    ":"") - ."
    " - ."ID = $cod[$ii]',CAPTION,'$dat[$ii]')\">"; - if ($noloc == 0 && $pha[$ii] >= $MC3{LOCATION_MIN_PHASES} && @b3) { - $html .= "$dkm km \"$dir\" $town    		".($dep[$ii] ? sprintf("%2.1f",$dep[$ii]):"").") - .($mty[$ii] && $mag[$ii] ? sprintf("%1.2f  %s",$mag[$ii],$mty[$ii]):"")."".($msk[$ii] ? $msk[$ii]:"")."%s (%s)
    %s (max. %s)",$b3[2],$b3[3],$ems,$emsmax) - } - $html .= "',CAPTION,'Rapport B³',WIDTH,80)\">"; - if ($ext) { - ( my $link = readlink("$fileB3/b3$ext") ) =~ s/.pdf//g; - $html .= ""; - # Print a link to remove the B3 file, only if no filter is in use and only for the last 10 lines - #if ($end_datetime->truncate(to => 'day') == $today - if ($nbLignesRetenues <= 10 - and ( (($operator eq "" || $operator eq $CLIENT) - && (clientHasEdit(type=>"authprocs",name=>"MC") || clientHasEdit(type=>"authprocs",name=>"$mc3"))) - || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) ) { - $html .= qq{  x}; - } - } elsif ($emsmax ne 'I') { - $html .= "$ems ($emsmax)"; - } - } else { - $html .= "    		"; - } - $html .= "
    ":"")."
    "; + if ($editURL ne "") { + my $msg = "View..."; + my $ico = "view.png"; + if ( (($operator eq "" || $operator eq $CLIENT || $type eq "AUTO") + && (clientHasEdit(type=>"authprocs",name=>"MC") ||clientHasEdit(type=>"authprocs",name=>"$mc3"))) || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) { + $msg = "Edit..."; + $ico = "modif.png"; + } + $html .= qq() + .qq(); + } else { $html .= " " } + $html .= "$md".sprintf("%.0f",$dist)."  $code$code $date  $heure  ".($nombre gt 1 ? "$nombre" : $nombre)." ×$amplitude_texte".($duree ? sprintf("%1.1f %s",$duree,$unite):"")."".($s_moins_p eq "NA" ? " " : "$s_moins_p").""; + +#djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { +#if (length($suds)==12 && substr($suds,8,1) eq '.') { +# for(@suds_liste) { +# $html .= ""; +# } +#} elsif (-f "$dirTrigger/$suds2_pointe") { +# for my $lettre ("a".."z") { +# $suds2_pointe = "${suds_racine}_${lettre}.${suds_ext}"; +# if (-f "$dirTrigger/$suds2_pointe") { +# $html .= ""; +# } +# } +#} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { +# $html .= ""; +#} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { +# $html .= ""; +#} elsif (-f "$WEBOBS{RACINE_SIGNAUX_SISMO}/$diriaspei/$suds") { +# $html .= ""; +#} elsif ($suds eq $nosuds) { +# $html .= ""; +#} elsif ($seedlink) { +# [FXB] AJOUTER &all=1 lorsque le serveur ArcLink acceptera les wildcards... + $html .= ""; + + #} else { + # $html .= "($suds)"; + #} + $html .= "$sc3id"; + +#FB-was: my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois/$MC3{FILE_PREFIX}$event_img"; + my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois"; + my $event_img_path = "$MC3{ROOT}/$event_img_subdir/$event_img"; + +# Split the MC3 column value on commas in case multiple images were to be displayed + my @img_list = map { $_ =~ s/^\s+|\s+$//g; $_; } split(/,/, "$event_img"); + + if (@img_list) { + + # Define the icon visible in the MC3 'Sefran' column + # (wolbtarget designates the gallery of images to display defined below) + $html .= ""; + + # Add all collected images to a unique common gallery (same wolbset) + for my $img (@img_list) { + $html .= ""; + } + } else { + + # No image was designated in the MC3 entry + $html .= " "; + } + + # --- operator + $html .= "$operator$comment
    "; + } + + # Distance et direction d'après B3 + my $noloc = 0; + $noloc = 1 if (grep(/^$typ[$ii]$/,@nolocation_types)); + my $sc3AutoStyle = ($mod[$ii] eq 'automatic' || $noloc == 1 ? "color:gray":""); + my @b3; + my $town; + my $pga; + my $pgamax; + my $dir; + my $dkm; + my $ems; + my $emsmax; + if ($bcube[$ii]) { + @b3 = split(/\|/,$bcube[$ii]); + $b3[2] =~ s/\'/\`/g; + $town = $b3[2]; + + #DL-was: if ($b3[4] != $WEBOBS{SHAKEMAPS_COMMUNES_PLACE}) { + if ($b3[3] ne $MC3{CITIES_PLACE}) { + $town = $b3[3]; + } + $pga = attenuation(($mag[$ii] ? $mag[$ii]:0),sqrt($b3[0]**2 + ($dep[$ii] ne "" ? $dep[$ii]**2:0))); + + #DL-was: my $pgamax = $pga*$WEBOBS{SHAKEMAPS_SITE_EFFECTS}; + #FB-was: $pgamax = $pga*$MC3{CITIES_SITE_EFFECTS}; + $pgamax = $pga*($b3[4] > 0 ? $b3[4]:3); + $dir = compass($b3[1]); + $dkm = sprintf("%5.1f",$b3[0]); + $dkm =~ s/\s/  /g; + $ems = pga2msk($pga); + $emsmax = pga2msk($pgamax); + } + my $M_A = "M":"red>A").""; + + # Info-bulle avec les détails de la localisation + $html .= "$M_A%1.2f
    ",$mty[$ii],$mag[$ii]):"") + .($lat[$ii] < 0 ? sprintf("%2.2f°S",-$lat[$ii]):sprintf("%2.2f°N",$lat[$ii])) + ."  " + .($lon[$ii] < 0 ? sprintf("%2.2f°W",-$lon[$ii]):sprintf("%2.2f°E",$lon[$ii])) + .($dep[$ii] ? "  ".sprintf("%1.1f km",$dep[$ii]):"")."
    " + .(@b3 ? "$dkm km $dir $town
    ":""); + } + $html .="$pha[$ii] phases".($qua[$ii] ? " ($qua[$ii])":"")." / $mod[$ii]".($sta[$ii] ne "" ? " ($sta[$ii])":"")."
    " + .($mth[$ii] ne "" || $mdl[$ii] ne "" ? "$mth[$ii] / $mdl[$ii]
    ":"") + .($typ[$ii] ne "" ? "$typ[$ii]
    ":"") + ."
    " + ."ID = $cod[$ii]',CAPTION,'$dat[$ii]')\">"; + if ($noloc == 0 && $pha[$ii] >= $MC3{LOCATION_MIN_PHASES} && @b3) { + $html .= "$dkm km \"$dir\" $town    		".($dep[$ii] ? sprintf("%2.1f",$dep[$ii]):"").") + .($mty[$ii] && $mag[$ii] ? sprintf("%1.2f  %s",$mag[$ii],$mty[$ii]):"")."".($msk[$ii] ? $msk[$ii]:"")."%s (%s)
    %s (max. %s)",$b3[2],$b3[3],$ems,$emsmax) + } + $html .= "',CAPTION,'Rapport B³',WIDTH,80)\">"; + if ($ext) { + ( my $link = readlink("$fileB3/b3$ext") ) =~ s/.pdf//g; + $html .= ""; + +# Print a link to remove the B3 file, only if no filter is in use and only for the last 10 lines +#if ($end_datetime->truncate(to => 'day') == $today + if ($nbLignesRetenues <= 10 + and ( (($operator eq "" || $operator eq $CLIENT) + && (clientHasEdit(type=>"authprocs",name=>"MC") || clientHasEdit(type=>"authprocs",name=>"$mc3"))) + || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) ) { + $html .= qq{  x}; + } + } elsif ($emsmax ne 'I') { + $html .= "$ems ($emsmax)"; + } + } else { + $html .= "    		"; + } + $html .= "
    ":"")."
    \n"; if ($QryParm->{'debug'}) { - $html .= "
    "; - $html .= "Number of lines kept / read: $nbLignesRetenues / $nb
    "; - $html .= "Dates interval: [".$start_datetime->strftime("%F %Hh").",".$end_datetime->strftime("%F %Hh")."]
    "; - $html .= "Type criteria: $QryParm->{'type'}
    "; - $html .= "Durations greater than: $QryParm->{'duree'} s
    "; - $html .= "User: $CLIENT
    "; - $html .= join('
    ',@listeCommunes); + $html .= "
    "; + $html .= "Number of lines kept / read: $nbLignesRetenues / $nb
    "; + $html .= "Dates interval: [".$start_datetime->strftime("%F %Hh").",".$end_datetime->strftime("%F %Hh")."]
    "; + $html .= "Type criteria: $QryParm->{'type'}
    "; + $html .= "Durations greater than: $QryParm->{'duree'} s
    "; + $html .= "User: $CLIENT
    "; + $html .= join('
    ',@listeCommunes); } # ---- Notes/legends area ----------------------------------------------------- # $html .= "
    "; - # legend : build types table ---------------------------------------------- - $html .= "

    Event Types

    " - ."\n"; - for (sort(keys(%typesSO))) { - my $key = $typesSO{$_}; - if ($key ne 'ALL' && $key ne 'TOTAL') { - $html .= "" - ."\n"; - } - } - # note : read from file --------------------------------------------------- - $html .= "
    CodeType
    $key$types{$key}{Name}
    \n" - ."
    ".WebObs::Wiki::wiki2html(join('',@infoTexte))."
    "; +# legend : build types table ---------------------------------------------- +$html .= "

    Event Types

    " + ."\n"; +for (sort(keys(%typesSO))) { + my $key = $typesSO{$_}; + if ($key ne 'ALL' && $key ne 'TOTAL') { + $html .= "" + ."\n"; + } +} +# note : read from file --------------------------------------------------- +$html .= "
    CodeType
    $key$types{$key}{Name}
    \n" + ."
    ".WebObs::Wiki::wiki2html(join('',@infoTexte))."
    "; # ---- now wrap $html into page html+javascript ------------------------------- # if ($QryParm->{'dump'} eq "") { - print $cgi->header(-charset=>'utf-8'); - print <<"ENDTOPOFPAGE"; + print $cgi->header(-charset=>'utf-8'); + print <<"ENDTOPOFPAGE"; @@ -1688,9 +1746,9 @@ sub compute_energy { ENDTOPOFPAGE - print $html; + print $html; - print <<"ENDBOTOFPAGE"; + print <<"ENDBOTOFPAGE"; -"; +"; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print "\n"; print "\n"; - # ---- List of available days in the 'runs' database table # -------------------------------------------------------- my @run_day_list = map { $_->[0] } (@{fetch_all($SCHED{SQL_DB_JOBS}, - "SELECT DISTINCT(DATE(CAST(startts AS INTEGER), 'unixepoch', 'localtime'))" - ." FROM runs ORDER BY 1 DESC")}); - + "SELECT DISTINCT(DATE(CAST(startts AS INTEGER), 'unixepoch', 'localtime'))" + ." FROM runs ORDER BY 1 DESC")}); # ---- Prepare the HTML table of job runs for selected day # -------------------------------------------------------- @@ -311,62 +322,63 @@ sub fetch_all { my @jid_list; my $query_runs = "SELECT jid, kid, org, DATETIME(CAST(startts AS INTEGER), 'unixepoch', 'localtime')," - . " CASE WHEN endts != 0 THEN DATETIME(CAST(endts AS INTEGER), 'unixepoch', 'localtime') ELSE NULL END," - . " cmd, stdpath, rc, rcmsg, endts - startts AS elps FROM runs" - . " WHERE startts >= $rdate AND startts <= $rdate+86400" - . " ORDER BY startts, jid"; + . " CASE WHEN endts != 0 THEN DATETIME(CAST(endts AS INTEGER), 'unixepoch', 'localtime') ELSE NULL END," + . " cmd, stdpath, rc, rcmsg, endts - startts AS elps FROM runs" + . " WHERE startts >= $rdate AND startts <= $rdate+86400" + . " ORDER BY startts, jid"; my $run_list = fetch_all($SCHED{SQL_DB_JOBS}, $query_runs); # Prepare the rows of the job run table for my $run (@$run_list) { - my ($job_jid, $job_kid, $org, $job_start, $job_end, - $job_cmd, $job_stdpath, $job_rc, $job_rcmsg, $elapsed) = @$run; - - push(@jid_list, $job_jid) unless grep{$_ eq $job_jid} @jid_list; - - if ($QryParm->{'jid'} eq "" || $QryParm->{'jid'} eq $job_jid) { - - my $elapsed_column = ''; - my $bgcolor = "transparent"; - # Running jobs have an undefined end date - my $is_running = not defined($job_end); - $jobsdefsCount++; - $jobsdefsId="jdef".$jobsdefsCount; - - if ($is_running) { - $job_rc = ''; - $job_rcmsg = ''; - $job_end = 'Running'; - } else { - my ($seconds, $ms) = split(/\./, ($elapsed)); - my @time = reverse($seconds%60, ($seconds/=60) % 60, ($seconds/=60) % 24, ($seconds/=24) ); - $elapsed_column = sprintf "%03d:%02d:%02d:%02d.%3.3s", @time, $ms; - # Return code shows success: use a green background in the RC column - $bgcolor = ($job_rc == 0 ? "green":"red"); - } - - if (length($job_cmd) > $maxdcmdl) { - my $s = ($maxdcmdl-5)/2; - $job_cmd = substr($job_cmd,0,$s).'(...)'.substr($job_cmd,-$s); - } - $job_start =~ s/^.* //; - $job_end =~ s/^.* //; - $jobsruns .= qq(
    ); - if ($is_running && $admOK) { - $jobsruns .= qq(); - } - $jobsruns .= qq(); - if (!$is_running && $admOK && $job_jid =~ /^\w/) { - $jobsruns .= qq(); - } - $jobsruns .= qq($job_jid$job_kid$org$job_start$job_end$job_cmd); - my $log_filename = $job_stdpath =~ s/^[><] +//r; - $jobsruns .= qq($log_filename); - $jobsruns .= qq($job_rc$job_rcmsg$elapsed_column
    ); + if ($is_running && $admOK) { + $jobsruns .= qq(); + } + $jobsruns .= qq(); + if (!$is_running && $admOK && $job_jid =~ /^\w/) { + $jobsruns .= qq(); + } + $jobsruns .= qq($job_jid$job_kid$org$job_start$job_end$job_cmd); + my $log_filename = $job_stdpath =~ s/^[><] +//r; + $jobsruns .= qq($log_filename); + $jobsruns .= qq($job_rc$job_rcmsg$elapsed_column
    "; - if ($header) { - print ""; - if (!$ref || $SEFRAN3{REF_NORTC} == 0) { - print ""; - } - print ""; - } - # form to display/select dates span (interval) and realtime vs start-date (reference) - print ""; - print "

    $titrePage".($userLevel == 4 ? " ":"")."

    ", - "

    »» [ ", - "", - " | "; - print "", - " | " if ($sgramOK); - print "$__{'Information'}", - " | $MC3{TITLE}", - " ]

    $Ya-$ma-$da
    $Ha:$Ma UTC

    ", - "ΔT ".($dt < 120 ? "= $dt s" : "< ".($dt < 7200 ? int($dt/60 +1)." mn" : int($dt/3600)." hr"))."
    "; - print "
    "; - # hidden values to pass all parameters in the form - print ""; - print "$__{'Interval'}: "; - print "  $__{'Reference'}: \n"; - print ""; - print " "; - print ""; - print " ".$__{'Header'}; - print " ".$__{'Status'}; - print " ".$__{'Event Loc'}; - print " ".$__{'Trash'}; - print "
    "; - print "
    "; - if ($sgramOK) { - print "", - ""; - } - - print ""; - my $nb_heures = 0; - my $nb_vign = 0; - for (@dates) { - my $dd = $_; - my $da = substr($_,0,4); - my $dm = substr($_,5,2); - my $dj = substr($_,8,2); - my $ddd = "$da$dm$dj"; - my $dt = l2u(strftime('%A %-d %B %Y UTC',gmtime(timegm(0,0,0,$dj,$dm-1,$da-1900)))); - my $nb_heures_jour=0; - for (@listeHeures) { - my $hh = $_; - if (($today ne $dd)||($Ha ge $hh)) { - if (($limit != 0 && ++$nb_heures <= $limit) || ($limit == 0 && ($nb_heures++ <= $limit_lastmc))) { - $nb_heures_jour++; - $nb_vign++; - my $f = "$da/$ddd/$SEFRAN3{PATH_IMAGES_HOUR}/$ddd$hh"; - my $imgopt = "border=\"1\" onClick=\"window.open('$prog&date=$ddd$hh&trash=$trash')\""; - print ""; - if (-e "$SEFRAN3{ROOT}/$f.jpg") { - my $sgramimg = ""; - my $sgramalign = ""; - if ($sgramOK) { - my $fs = "$SEFRAN3{ROOT}/${f}s.jpg"; - if (-e $fs) { - if ($nb_vign > 1) { - my ($w, $h) = dim(image_info($fs)); - $sgramalign = ";left:".($SEFRAN3{HOURLY_WIDTH}-$w)."px !important"; - } - $sgramimg = ""; - } - } - print "\n"; - } - } - } - if ($nb_heures_jour > 0) { - print "\n"; - } - - } - - print "
     $da-$dm-$dj 
     $hhh UTC 
    "; - print "$sgramimg"; - } else { - print "
    no image"; - } - - # plots MC events over sefran - for (reverse @mclist) { - my %MC = mcinfo($_,$evtloc); - if (($MC{id} > 0 || ($userLevel >= 2 && $trash == 1)) && $userLevel >= 1) { - # event start and end expressed in days - my $d0 = $MC{year}*10000 + $MC{month}*100 + $MC{day} + $MC{hour}/24 + $MC{minute}/1440 + $MC{second}/86400; - my $d1 = $d0 + $MC{duration}*$duration_s{$MC{unit}}/86400; - if ($d0 < $ddd + ($hh+1)/24 && $d1 >= $ddd + $hh/24) { - # event start and duration expressed in hour - my $h0 = $MC{minute}/60 + $MC{second}/3600; - my $dh = $MC{duration}*$duration_s{$MC{unit}}/3600; - # event start and duration expressed in pixels - my $deb_evt = 2 + int($SEFRAN3{HOURLY_WIDTH}*$h0); - my $dur_evt = 1 + int(0.5 + $SEFRAN3{HOURLY_WIDTH}*$dh); - # case A: event starts in the current hour - if ($MC{hour} eq $hh) { - # case A1: event duration exceeds current hour - if ($deb_evt + $dur_evt > $SEFRAN3{HOURLY_WIDTH}) { - $dur_evt = $SEFRAN3{HOURLY_WIDTH} - $deb_evt + 2; - } - # case B: event has started in a previous hour - } else { - $deb_evt = 2; - my $hdeb = $MC{hour}; - $hdeb -= 24 if ($hdeb > $hh); # solves event crossover a day - # case B1: more than 3 hours overlap = full width - if ($h0 + $dh > $hh - $hdeb + 1) { - $dur_evt = $SEFRAN3{HOURLY_WIDTH}; - } else { - $dur_evt = $SEFRAN3{HOURLY_WIDTH}*($h0 + $dh - ($hh-$hdeb)) + 1; - } - } - print "
    ", - "
    \n"; - } - } - } - print "
    ⇑  $dt  ⇑

    "; - - # table information about channel streams - print "

    Informations

    \n"; - if ($status) { - my $now_seconds = timegm(gmtime); - my $Q = qx($WEBOBS{PRGM_ALARM} $SEFRAN3{SEEDLINK_SERVER_TIMEOUT_SECONDS} $WEBOBS{SLINKTOOL_PRGM} -Q $SEFRAN3{SEEDLINK_SERVER}); - my @stream_server = split(/\n/,$Q); - - # read statistics - my @stat_streams = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:streams]" $last_mn/); - my @stat_offset = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:offset]" $last_mn/); - my @stat_median = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:median]" $last_mn/); - my @stat_rate = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:rate]" $last_mn/); - my @stat_sampling = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:sampling]" $last_mn/); - my @stat_drms = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:drms]" $last_mn/); - my @stat_asymetry = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:asymetry]" $last_mn/); - my @stat_fdom; - - if ($sgramOK) { - (my $last_sg = $last_mn) =~ s/$SEFRAN3{PATH_IMAGES_MINUTE}/$SEFRAN3{PATH_IMAGES_SGRAM}/; - $last_sg =~ s/\.png/s.png/; - @stat_fdom = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:freqdom]" $last_sg/); - } - - print "", - "", - "", - "", - "", - ($sgramOK ? "":""), - "\n"; - for (@channels) { - $i++; - my ($alias,$codes,$calib,$offset,$pp,$color) = split(/\s+/,$_); - $color =~ s/"//; - my ($net,$sta,$loc,$cha) = split(/\./,$codes); - my @chan = grep(/$net *$sta *$loc *$cha/,@stream_server); - my $idx = first { $stat_streams[$_] eq $codes } 0..$#stat_streams; - - print "", - "", - ""; - - my $ch_nagios = 3; # Nagios 'UNKNOWN' value - if ($idx ge 0) { - my ($status_offset,$status_noise) = (1,1); - if (abs($stat_offset[$idx]) < $SEFRAN3{STATUS_OFFSET_WARNING}) { $status_offset = 0; } - elsif (abs($stat_offset[$idx]) > $SEFRAN3{STATUS_OFFSET_CRITICAL}) { $status_offset = 2; } - if ($stat_drms[$idx] != 0 && ($stat_drms[$idx]/$calib) < $SEFRAN3{STATUS_NOISE_WARNING}) { $status_noise = 0; } - elsif ($stat_drms[$idx] == 0 || ($stat_drms[$idx]/$calib) > $SEFRAN3{STATUS_NOISE_CRITICAL}) { $status_noise = 2; } - printf("",1e6*$stat_median[$idx]/$calib); - printf("",100*$stat_offset[$idx]); - printf("",100*$stat_asymetry[$idx]); - printf("",1e6*$stat_drms[$idx]/$calib); - printf("",100*$stat_sampling[$idx]); - printf("",$stat_rate[$idx]); - printf("",$stat_fdom[$idx]) if ($sgramOK); - if ($status_offset == 0 && $status_noise == 0) { - $ch_nagios = 0; # Nagios 'OK' value - } elsif ($status_offset == 2 || $status_noise == 2) { - $ch_nagios = 2; # Nagios 'CRITICAL' value - } else { - $ch_nagios = 1; # Nagios 'WARNING' value - } - } else { - print ""; - } - - if (@chan) { - my ($start,$end) = split(/ - /,substr($chan[0],18)); - my $start_s = timegm(substr($start,17,2),substr($start,14,2),substr($start,11,2),substr($start,8,2),substr($start,5,2)-1,substr($start,0,4)-1900); - my $end_s = timegm(substr($end,17,2),substr($end,14,2),substr($end,11,2),substr($end,8,2),substr($end,5,2)-1,substr($end,0,4)-1900); - my $bl = int(($end_s - $start_s)/60); # ringbuffer length (in minutes) - my $dt = ($now_seconds - $end_s); - my $status_delay = 0; - if ($dt > $SEFRAN3{STATUS_DELAY_CRITICAL}) { - $status_delay = 2; - $ch_nagios = 2; - } elsif ($ch_nagios < 2 && $dt > $SEFRAN3{STATUS_DELAY_WARNING}) { - $status_delay = 1; - $ch_nagios = 1; - } - print "", - ""; - print ""; - #if ($dt > $SEFRAN3{ARCLINK_DELAY_HOURS}) { - } else { - print ""; - } - switch ($ch_nagios) { - case 0 { print ""; } - case 1 { print ""; } - case 2 { print ""; } - case 3 { print ""; } - } - print "\n"; - } - print "
    #AliasChannelCalibration
    (count/(m/s))    		FilterPeak-Peak
    (m/s)    		Signal statistics on last image
    $lmn    		SeedLink server $SEFRAN3{SEEDLINK_SERVER}Status
    Offset
    (μm/s)    		Asym.RMSΔ
    (μm/s)    		Acq.
    (%)    		Samp.
    (Hz)    		Freq
    (Hz)    		Oldest dataLast dataBufferΔT
    $i.$alias$codes$calib$offset$pp%1.4f%2.0f%%2.0f%%1.4f%1.0f%g%1.2fnot available$start$end" - .($bl < 60 ? "$bl mn":($bl < 1440 ? int($bl/60 + 0.5)." h":int($bl/1440 + 0.5)." d"))."" - .($dt < 60 ? "$dt s":($dt < 3600 ? int($dt/60 + 0.5)." mn":($dt < 86400 ? int($dt/3600 + 0.5)." h":int($dt/86400 + 0.5)." d")))."not availableOKPBHS?

    \n"; - } - - print "

    Sefran3 configuration file: $s3

    \n"; - print "

    Channels parameters file: $SEFRAN3{CHANNEL_CONF}

    \n"; - print "

    Update window: $SEFRAN3{UPDATE_HOURS} h

    \n"; - print "

    Datasource: ".($SEFRAN3{DATASOURCE} ne "" ? "$SEFRAN3{DATASOURCE}":"Not configured.")."

    \n"; - print "

    Broom wagon: ".($SEFRAN3{BROOMWAGON_ACTIVE} ? ("Active (delay = $SEFRAN3{BROOMWAGON_DELAY_HOURS} h," - ."update window = $SEFRAN3{BROOMWAGON_UPDATE_HOURS} h, " - ."maximum dead channels = $SEFRAN3{BROOMWAGON_MAX_DEAD_CHANNELS}, " - ."maximum gap = ".sprintf("%g%%",$SEFRAN3{BROOMWAGON_MAX_GAP_FACTOR}*100).")"):"Not active")."

    \n"; - - print "", - "\n", - "", - "\n", - "", - "\n", - "
    Virtual speed
    (inches/minute)    		Resolution
    (pixels/second)    		1-minute image width
    (pixels)    		Density \@100Hz
    (samples/pixel)
    Normal view$SEFRAN3{VALUE_SPEED}".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}/60)."", - "".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}))."
    High-speed view$SEFRAN3{VALUE_SPEED_HIGH}".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}/60)."", - "".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}))."
    \n"; - print "

    MC events: ".@mclist."

    \n"; - print "

    Last MC: $last_mc ($limit_lastmc h)

    \n" if ($limit==0); - - my @notes = readFile("$SEFRAN3{NOTES}"); - print WebObs::Wiki::wiki2html(join("",@notes)); - - print ""; + my $last_mc; + my $dt_lastmc; + my $limit_lastmc = $SEFRAN3{TIME_INTERVALS_DEFAULT_VALUE}; + if ($limit == 0) { + +# gets the N=$SEFRAN3{DISPLAY_LAST_MC} last MC event: from the 2 last monthly files, extracts the Nth last event non 'AUTO' and returns 'yyyy-mm-dd|HH' + $last_mc = qx(find $MC3{ROOT} -name "$MC3{FILE_PREFIX}*.txt" | sort | tail -n2 | xargs sort -t '|' -k2,3 | tail -n$SEFRAN3{DISPLAY_LAST_MC} | head -n1 |sed -nE "s/^[0-9]+\\|([0-9]{4}-[0-9]{2}-[0-9]{2}\\|[0-9]{2}):.*/\\1/p" | xargs echo -n); + my $dtn = timegm(gmtime); + $dt_lastmc = timegm(0,0,substr($last_mc,11,2),substr($last_mc,8,2),substr($last_mc,5,2)-1,substr($last_mc,0,4)); + $limit_lastmc = int(($dtn - $dt_lastmc)/3600); + $limit_lastmc = $SEFRAN3{DISPLAY_DAYS}*24 if ($limit_lastmc/24 > $SEFRAN3{DISPLAY_DAYS}); + } + +# builds the list of dates and loads associated MC events over the period (+ 1 day) + my @dates; + my @mclist; + for (0 .. ($limit>0?$limit:$limit_lastmc)) { + my $ymdh = strftime('%Y-%m-%d|%H',gmtime(timegm(0,0,$href,$dref,$mref-1,$yref-1900) - $_*3600)); + my $ymd = substr($ymdh,0,10); + push(@dates,$ymd) if (!grep(/^$ymd$/,@dates) && $_ < 24*$SEFRAN3{DISPLAY_DAYS}); + my $f = "$MC3{ROOT}/".substr($ymd,0,4)."/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}".substr($ymd,0,4).substr($ymd,5,2).".txt"; + if (-f $f) { + my @mchour = split(/\n/,qx(grep "|$ymdh:" $f)); + push(@mclist,@mchour); + } + } + my @listeHeures = reverse('00'..'23'); + + my $dt = 0; + my $last_mn; + my $lmn; + + # what's the last minute-image ? searches for it and computes realtime delta + my $last_d = qx(y=\$(find $SEFRAN3{ROOT} -maxdepth 1 -name "????" | sort | tail -n1);find \$y -maxdepth 1| sort | tail -n1 | xargs echo -n); + if ($last_d) { + $last_mn = qx/find $last_d -name "??????????????.png"|sort|tail -n1/; + if ($last_mn) { + $lmn = basename($last_mn); + my @lm = (substr($lmn,10,2),substr($lmn,8,2),substr($lmn,6,2),substr($lmn,4,2),substr($lmn,0,4)); + $dt = (timegm(gmtime) - timegm(0,$lm[0],$lm[1],$lm[2],$lm[3]-1,$lm[4]-1900) - 60); + } + } + + # title and current data/time + print ""; + if ($header) { + print ""; + if (!$ref || $SEFRAN3{REF_NORTC} == 0) { + print ""; + } + print ""; + } + +# form to display/select dates span (interval) and realtime vs start-date (reference) + print ""; + print "

    $titrePage".($userLevel == 4 ? " ":"")."

    ", + "

    »» [ ", + "", + " | "; + print "", + " | " if ($sgramOK); + print "$__{'Information'}", + " | $MC3{TITLE}", + " ]

    $Ya-$ma-$da
    $Ha:$Ma UTC

    ", + "ΔT ".($dt < 120 ? "= $dt s" : "< ".($dt < 7200 ? int($dt/60 +1)." mn" : int($dt/3600)." hr"))."
    "; + print "
    "; + + # hidden values to pass all parameters in the form + print ""; + print "$__{'Interval'}: "; + print "  $__{'Reference'}: \n"; + print ""; + print " "; + print ""; + print " ".$__{'Header'}; + print " ".$__{'Status'}; + print " ".$__{'Event Loc'}; + print " ".$__{'Trash'}; + print "
    "; + print "
    "; + if ($sgramOK) { + print "", + ""; + } + + print ""; + my $nb_heures = 0; + my $nb_vign = 0; + for (@dates) { + my $dd = $_; + my $da = substr($_,0,4); + my $dm = substr($_,5,2); + my $dj = substr($_,8,2); + my $ddd = "$da$dm$dj"; + my $dt = l2u(strftime('%A %-d %B %Y UTC',gmtime(timegm(0,0,0,$dj,$dm-1,$da-1900)))); + my $nb_heures_jour=0; + for (@listeHeures) { + my $hh = $_; + if (($today ne $dd)||($Ha ge $hh)) { + if (($limit != 0 && ++$nb_heures <= $limit) || ($limit == 0 && ($nb_heures++ <= $limit_lastmc))) { + $nb_heures_jour++; + $nb_vign++; + my $f = "$da/$ddd/$SEFRAN3{PATH_IMAGES_HOUR}/$ddd$hh"; + my $imgopt = "border=\"1\" onClick=\"window.open('$prog&date=$ddd$hh&trash=$trash')\""; + print ""; + if (-e "$SEFRAN3{ROOT}/$f.jpg") { + my $sgramimg = ""; + my $sgramalign = ""; + if ($sgramOK) { + my $fs = "$SEFRAN3{ROOT}/${f}s.jpg"; + if (-e $fs) { + if ($nb_vign > 1) { + my ($w, $h) = dim(image_info($fs)); + $sgramalign = ";left:".($SEFRAN3{HOURLY_WIDTH}-$w)."px !important"; + } + $sgramimg = ""; + } + } + print "\n"; + } + } + } + if ($nb_heures_jour > 0) { + print "\n"; + } + + } + + print "
     $da-$dm-$dj 
     $hhh UTC 
    "; + print "$sgramimg"; + } else { + print "
    no image"; + } + + # plots MC events over sefran + for (reverse @mclist) { + my %MC = mcinfo($_,$evtloc); + if (($MC{id} > 0 || ($userLevel >= 2 && $trash == 1)) && $userLevel >= 1) { + + # event start and end expressed in days + my $d0 = $MC{year}*10000 + $MC{month}*100 + $MC{day} + $MC{hour}/24 + $MC{minute}/1440 + $MC{second}/86400; + my $d1 = $d0 + $MC{duration}*$duration_s{$MC{unit}}/86400; + if ($d0 < $ddd + ($hh+1)/24 && $d1 >= $ddd + $hh/24) { + + # event start and duration expressed in hour + my $h0 = $MC{minute}/60 + $MC{second}/3600; + my $dh = $MC{duration}*$duration_s{$MC{unit}}/3600; + + # event start and duration expressed in pixels + my $deb_evt = 2 + int($SEFRAN3{HOURLY_WIDTH}*$h0); + my $dur_evt = 1 + int(0.5 + $SEFRAN3{HOURLY_WIDTH}*$dh); + + # case A: event starts in the current hour + if ($MC{hour} eq $hh) { + + # case A1: event duration exceeds current hour + if ($deb_evt + $dur_evt > $SEFRAN3{HOURLY_WIDTH}) { + $dur_evt = $SEFRAN3{HOURLY_WIDTH} - $deb_evt + 2; + } + + # case B: event has started in a previous hour + } else { + $deb_evt = 2; + my $hdeb = $MC{hour}; + $hdeb -= 24 if ($hdeb > $hh); # solves event crossover a day + + # case B1: more than 3 hours overlap = full width + if ($h0 + $dh > $hh - $hdeb + 1) { + $dur_evt = $SEFRAN3{HOURLY_WIDTH}; + } else { + $dur_evt = $SEFRAN3{HOURLY_WIDTH}*($h0 + $dh - ($hh-$hdeb)) + 1; + } + } + print "
    ", + "
    \n"; + } + } + } + print "
    ⇑  $dt  ⇑

    "; + + # table information about channel streams + print "

    Informations

    \n"; + if ($status) { + my $now_seconds = timegm(gmtime); + my $Q = qx($WEBOBS{PRGM_ALARM} $SEFRAN3{SEEDLINK_SERVER_TIMEOUT_SECONDS} $WEBOBS{SLINKTOOL_PRGM} -Q $SEFRAN3{SEEDLINK_SERVER}); + my @stream_server = split(/\n/,$Q); + + # read statistics + my @stat_streams = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:streams]" $last_mn/); + my @stat_offset = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:offset]" $last_mn/); + my @stat_median = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:median]" $last_mn/); + my @stat_rate = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:rate]" $last_mn/); + my @stat_sampling = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:sampling]" $last_mn/); + my @stat_drms = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:drms]" $last_mn/); + my @stat_asymetry = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:asymetry]" $last_mn/); + my @stat_fdom; + + if ($sgramOK) { + (my $last_sg = $last_mn) =~ s/$SEFRAN3{PATH_IMAGES_MINUTE}/$SEFRAN3{PATH_IMAGES_SGRAM}/; + $last_sg =~ s/\.png/s.png/; + @stat_fdom = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:freqdom]" $last_sg/); + } + + print "", + "", + "", + "", + "", + ($sgramOK ? "":""), + "\n"; + for (@channels) { + $i++; + my ($alias,$codes,$calib,$offset,$pp,$color) = split(/\s+/,$_); + $color =~ s/"//; + my ($net,$sta,$loc,$cha) = split(/\./,$codes); + my @chan = grep(/$net *$sta *$loc *$cha/,@stream_server); + my $idx = first { $stat_streams[$_] eq $codes } 0..$#stat_streams; + + print "", + "", + ""; + + my $ch_nagios = 3; # Nagios 'UNKNOWN' value + if ($idx ge 0) { + my ($status_offset,$status_noise) = (1,1); + if (abs($stat_offset[$idx]) < $SEFRAN3{STATUS_OFFSET_WARNING}) { $status_offset = 0; } + elsif (abs($stat_offset[$idx]) > $SEFRAN3{STATUS_OFFSET_CRITICAL}) { $status_offset = 2; } + if ($stat_drms[$idx] != 0 && ($stat_drms[$idx]/$calib) < $SEFRAN3{STATUS_NOISE_WARNING}) { $status_noise = 0; } + elsif ($stat_drms[$idx] == 0 || ($stat_drms[$idx]/$calib) > $SEFRAN3{STATUS_NOISE_CRITICAL}) { $status_noise = 2; } + printf("",1e6*$stat_median[$idx]/$calib); + printf("",100*$stat_offset[$idx]); + printf("",100*$stat_asymetry[$idx]); + printf("",1e6*$stat_drms[$idx]/$calib); + printf("",100*$stat_sampling[$idx]); + printf("",$stat_rate[$idx]); + printf("",$stat_fdom[$idx]) if ($sgramOK); + if ($status_offset == 0 && $status_noise == 0) { + $ch_nagios = 0; # Nagios 'OK' value + } elsif ($status_offset == 2 || $status_noise == 2) { + $ch_nagios = 2; # Nagios 'CRITICAL' value + } else { + $ch_nagios = 1; # Nagios 'WARNING' value + } + } else { + print ""; + } + + if (@chan) { + my ($start,$end) = split(/ - /,substr($chan[0],18)); + my $start_s = timegm(substr($start,17,2),substr($start,14,2),substr($start,11,2),substr($start,8,2),substr($start,5,2)-1,substr($start,0,4)-1900); + my $end_s = timegm(substr($end,17,2),substr($end,14,2),substr($end,11,2),substr($end,8,2),substr($end,5,2)-1,substr($end,0,4)-1900); + my $bl = int(($end_s - $start_s)/60); # ringbuffer length (in minutes) + my $dt = ($now_seconds - $end_s); + my $status_delay = 0; + if ($dt > $SEFRAN3{STATUS_DELAY_CRITICAL}) { + $status_delay = 2; + $ch_nagios = 2; + } elsif ($ch_nagios < 2 && $dt > $SEFRAN3{STATUS_DELAY_WARNING}) { + $status_delay = 1; + $ch_nagios = 1; + } + print "", + ""; + print ""; + + #if ($dt > $SEFRAN3{ARCLINK_DELAY_HOURS}) { + } else { + print ""; + } + switch ($ch_nagios) { + case 0 { print ""; } + case 1 { print ""; } + case 2 { print ""; } + case 3 { print ""; } + } + print "\n"; + } + print "
    #AliasChannelCalibration
    (count/(m/s))    		FilterPeak-Peak
    (m/s)    		Signal statistics on last image
    $lmn    		SeedLink server $SEFRAN3{SEEDLINK_SERVER}Status
    Offset
    (μm/s)    		Asym.RMSΔ
    (μm/s)    		Acq.
    (%)    		Samp.
    (Hz)    		Freq
    (Hz)    		Oldest dataLast dataBufferΔT
    $i.$alias$codes$calib$offset$pp%1.4f%2.0f%%2.0f%%1.4f%1.0f%g%1.2fnot available$start$end" + .($bl < 60 ? "$bl mn":($bl < 1440 ? int($bl/60 + 0.5)." h":int($bl/1440 + 0.5)." d"))."" + .($dt < 60 ? "$dt s":($dt < 3600 ? int($dt/60 + 0.5)." mn":($dt < 86400 ? int($dt/3600 + 0.5)." h":int($dt/86400 + 0.5)." d")))."not availableOKPBHS?

    \n"; + } + + print "

    Sefran3 configuration file: $s3

    \n"; + print "

    Channels parameters file: $SEFRAN3{CHANNEL_CONF}

    \n"; + print "

    Update window: $SEFRAN3{UPDATE_HOURS} h

    \n"; + print "

    Datasource: ".($SEFRAN3{DATASOURCE} ne "" ? "$SEFRAN3{DATASOURCE}":"Not configured.")."

    \n"; + print "

    Broom wagon: ".($SEFRAN3{BROOMWAGON_ACTIVE} ? ("Active (delay = $SEFRAN3{BROOMWAGON_DELAY_HOURS} h," + ."update window = $SEFRAN3{BROOMWAGON_UPDATE_HOURS} h, " + ."maximum dead channels = $SEFRAN3{BROOMWAGON_MAX_DEAD_CHANNELS}, " + ."maximum gap = ".sprintf("%g%%",$SEFRAN3{BROOMWAGON_MAX_GAP_FACTOR}*100).")"):"Not active")."

    \n"; + + print "", + "\n", + "", + "\n", + "", + "\n", + "
    Virtual speed
    (inches/minute)    		Resolution
    (pixels/second)    		1-minute image width
    (pixels)    		Density \@100Hz
    (samples/pixel)
    Normal view$SEFRAN3{VALUE_SPEED}".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}/60)."", + "".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}))."
    High-speed view$SEFRAN3{VALUE_SPEED_HIGH}".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}/60)."", + "".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}))."
    \n"; + print "

    MC events: ".@mclist."

    \n"; + print "

    Last MC: $last_mc ($limit_lastmc h)

    \n" if ($limit==0); + + my @notes = readFile("$SEFRAN3{NOTES}"); + print WebObs::Wiki::wiki2html(join("",@notes)); + + print ""; } # ----------------------------------------------------------------------------- # ---- Case: hour and analysis (depouillement) form page ------------------- # ----------------------------------------------------------------------------- if ($date) { - my ($Yc,$mc,$dc,$Hc,$Mc) = unpack("a4 a2 a2 a2 a2",$date); - - # read existing events from MC for current hour - my @mc_hlist; - my $f = "$MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$Yc$mc.txt"; - if (-e $f) { - @mc_hlist = split(/\n/,qx(grep "|$Yc-$mc-$dc|$Hc:" $f)); - } - - print "
    "; - my %MC; - my $fileMC = "$MC3{FILE_PREFIX}$Yc$mc.txt"; - my $date_deb; # starting date (relative) - my $date_nbm; # number of files - my $date_prec = my $dprec = ""; - my $date_suiv = my $dsuiv = ""; - my $idarg = ""; - - if ($dep) { - if ($id) { # read event ID from MC + set number of minute-files containing signal + 1 - my @mc_evt = qx(grep "^$id|" $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); - %MC = mcinfo($mc_evt[0],1); - $date_nbm = 1 + int(1 + ($MC{duration}*$duration_s{$MC{unit}} + $MC{second})/60); - } else { - $date_nbm = $MC3{WINDOW_LENGTH_MINUTE}; - } - $date_deb = 0; - $date_prec = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); - $dprec = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); - $date_suiv = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); - $dsuiv = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); - $idarg = "&id=$id"; - } else { - $date_deb = -1; - $date_nbm = 61; - $date_prec = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); - $dprec = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); - $date_suiv = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); - $dsuiv = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); - } - - # prev+next hour 'big arrows' - if (!$dep && defined($SEFRAN3{BIGARROWS})) { - print "
     
    "; - print "
     
    "; - } - - # control-panel fixed box (zoom,mctag toggle,next/prev buttons) - print "
    "; - print "Controls"; - print "
    "; - print "+\n"; - print "=\n"; - print "−\n"; - print "\n"; - print "←\n"; - print "→\n"; - print "\n"; - if ($sgramOK) { - print "
    ", - " ", - "
    \n", - ""; - } - print "
    "; - print "
    "; - - # image of channels - my $voies = "$SEFRAN3{PATH_WEB}/$Yc/$Yc$mc$dc/$SEFRAN3{PATH_IMAGES_HEADER}/$Yc$mc$dc$Hc\_voies.png"; - - # builds the list of minute images - my @liste_png; - for ($i = $date_deb; $i < $date_nbm; $i++) { - my ($Y,$m,$d,$H,$M) = split('/',strftime('%Y/%m/%d/%H/%M',gmtime(timegm(0,($dep ? "$Mc":"0"),$Hc,$dc,$mc-1,$Yc-1900) + $i*60))); - push(@liste_png,sprintf("%s/%4d/%04d%02d%02d/%s/%04d%02d%02d%02d%02d00", - $SEFRAN3{ROOT},$Y,$Y,$m,$d,$SEFRAN3{PATH_IMAGES_MINUTE},$Y,$m,$d,$H,$M)); - } - my $fin = 0; - my $reload = 0; - - if ($voies_classiques && !$dep) { - print "\n"; - } else { - print "\n"; - } - print "\n"; - print ""; - - for (reverse @mc_hlist) { - my %MC = mcinfo($_,1); - #DL-was: if (($MC{id} > 0 || $userLevel == 4) && $userLevel >= 1 && $MC{id} != $id && ($MC{minute} - $Mc) <= $date_nbm) { - if (($MC{id} > 0 || ($userLevel == 4 && $trash == 1)) && $userLevel >= 1 && ($MC{minute} - $Mc) <= $date_nbm) { - my $deb_evt; - if ($dep) { - $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} - $Mc + $MC{second}/60)); - } else { - $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} + 1 + $MC{second}/60)); - } - my $dur_evt = 1 + int(0.5 + $largeur_image*$MC{duration}*$duration_s{$MC{unit}}/60); - if ($MC{id} != $id) { - print "
    \n"; - } else { - my $dlstripes = "background: repeating-linear-gradient(120deg, white, white 7px, $types{$MC{type}}{Color} 7px, $types{$MC{type}}{Color} 14px);"; - print "
    "; - } - } - } - - print "
    "; - for (@liste_png) { - my $png = qx(basename $_); chomp $png; - my ($Y,$m,$d,$H,$M,$S) = unpack("a4 a2 a2 a2 a2 a2",$png); - my $timestamp = "$Y-$m-$d $H:$M UT"; - my $png_file = "$_".($high ? "_high":"").".png"; - if ( -f $png_file ) { - my $png_web = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_MINUTE}/$png".($high ? "_high":"").".png"; - my $png_sgram = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_SGRAM}/${png}s.png"; - my $mseed = "$mseedreq&t1=$Y,$m,$d,$H,$M,0&ds=60"; - - print "$timestamp', WIDTH, 200)\"", - " shape=rect coords=\"0,0,$largeur_image,$hauteur_label_haut\" alt=\"miniSEED $png\">", - "= 2) { - print " class=\"flyhour\" onMouseOver=\"flyhour(this,'$__{'Click to start input Main Courante'}')\"", - " href=\"$prog&date=$Y$m$d$H$M&s3=$s3\" target=\"_blank\" rel=\"opener\""; - } - print " shape=rect coords=\"0,".($hauteur_label_haut + 1).",$largeur_image,".($hauteur_image - $hauteur_label_haut)."\">"; - print "" if ($sgramOK); - print ""; - } elsif ( "$Y$m$d$H$M" >= "$Ya$ma$da$Ha$Ma") { - if (!$fin) { - print "
    Now
    $Ya-$ma-$da
    $Ha:$Ma:$Sa UTC
    		"; - if (!$reload && !$dep) { - print ""; - $reload = 1; - } - $fin = 1; - } - } elsif ( "$Y$m$d$H$M" >= "$Yr$mr$dr$Hr$Mr") { - print "

    In progress...
    $Y-$m-$d
    $H:$M:$S UTC
    		"; - if (!$reload && !$dep) { - print ""; - $reload = 1; - } - } else { - print "
    No image
    $Y-$m-$d
    $H:$M:$S UTC
    		"; - } - } - print "
    "; - print "
    "; - - if ($dep) { - # default values for mcform; - # case : editing an existing id or not - my $date_evt = ($id ? "$MC{date} $MC{hour}:$MC{minute}" : "$Yc-$mc-$dc $Hc:$Mc"); - my $seconde_evt = ($id ? $MC{second} : ""); - my $type_evt = ($id ? $MC{type} : "$MC3{DEFAULT_TYPE}"); - my $amplitude_evt = ($id ? $MC{amplitude} : "$MC3{DEFAULT_AMPLITUDE}"); - my $duree_evt = ($id ? $MC{duration} : ""); - my $unite_evt = ($id ? $MC{unit} : "s"); - my $duree_sat_evt = ($id ? $MC{overscale} : 0); - my $nb_evt = ($id ? $MC{amount} : 1); - my $s_moins_p_evt = ($id ? $MC{s_minus_p} : "");$s_moins_p_evt =~ s/^NA$//; - my $station = $MC{station}; - my $unique_evt = ($id ? $MC{unique} : 0); - my $operateur = $MC{operator}; - my $comment_evt = ($id ? htmlspecialchars(l2u($MC{comment})) : ""); - # case : 'replay mode' ('replay' and 'editing id' must be exclusive) - if ($replay && !$id) { - my @mcreplay = qx(awk -F'|' '\$1 == $replay {printf "\%s",\$0}' $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); - my %MCreplay = mcinfo($mcreplay[0]); - $type_evt = $MCreplay{type}; - $amplitude_evt = $MCreplay{amplitude}; - } - - my $modif = 0; - - if ((isok($MC3{LEVEL2_MODIFY_ALL_EVENTS}) && $userLevel ==2) || ($userLevel == 2 && ($operateur eq "" || $operateur eq $USERS{$CLIENT}{UID} || $type_evt eq "AUTO")) || $userLevel == 4 ) { - $modif = 1; - } - # --- mcform: edit form for Main Courante - print "
    ", - "
    ", - "", - "", - "", - "", - "", - "", - "", - "", # compatibilite MC2: nombre de fichiers - "", # pour compatibilite MC2: remplace par la version SEFRAN - "", - "", - "", - "", - "

    ".($id ? ($modif > 0 ? "$__{'Update'}":""):"$__{'Input'}")." $MC3{TITLE}

    "; - if ($id) { - print "
    "; - if ($modif) { - print ""; - } - print "
    ", - ""; - if ($userLevel == 4) { - print ""; - } - print "$__{'Event'}"; - if ($operateur eq "" || $operateur eq $MC3{SC3_USER}) { - print " $__{'not validated by operator (automatic)'}"; - } else { - print " $__{'identified by'} ".join(',',WebObs::Users::userName($operateur)).""; - } - if (length($MC{qml})>2) { - print "
    QML: $MC{qml}"; - } - print "
    "; - } - - # list of operators - print "

    $__{'Operator'}:

    "; - - # list of stations - print "

    $__{'Station of first arrival'}: "; - print "   Multiple", - "   Unique

    \n"; - - # date and time of first arrival - print "

    Date, HH:MM : "; - - # seconds of first arrival - print " $__{'Seconds'}:

    "; - - # duration - print "

    $__{'Duration'}: "; - print "\n"; - - # number of events - print "  $__{'Number of events'} =

    \n"; - - # S-P - print "

    S−P ($__{'Seconds'}): ", - "", - "", - "

    "; - - # amplitude and saturation - print "

    $__{'Max amplitude'}:

    \n"; - print "

    $__{'Overscale duration'} ($__{'Seconds'}): ", - " (0 = $__{'not overscale'})

    \n"; - - # type of event - print "

    $__{'Event type'}: \n"; - - # Prediction seismic-event - if ($MC3{PREDICT_EVENT_TYPE} ne "" && $MC3{PREDICT_EVENT_TYPE} ne "NO") { - print "\n"; - print "
    \n"; - print "

    $__{'PLEASE WAIT'}

    \n"; + my ($Yc,$mc,$dc,$Hc,$Mc) = unpack("a4 a2 a2 a2 a2",$date); + + # read existing events from MC for current hour + my @mc_hlist; + my $f = "$MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$Yc$mc.txt"; + if (-e $f) { + @mc_hlist = split(/\n/,qx(grep "|$Yc-$mc-$dc|$Hc:" $f)); + } + + print "
    "; + my %MC; + my $fileMC = "$MC3{FILE_PREFIX}$Yc$mc.txt"; + my $date_deb; # starting date (relative) + my $date_nbm; # number of files + my $date_prec = my $dprec = ""; + my $date_suiv = my $dsuiv = ""; + my $idarg = ""; + + if ($dep) { + if ($id) { # read event ID from MC + set number of minute-files containing signal + 1 + my @mc_evt = qx(grep "^$id|" $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); + %MC = mcinfo($mc_evt[0],1); + $date_nbm = 1 + int(1 + ($MC{duration}*$duration_s{$MC{unit}} + $MC{second})/60); + } else { + $date_nbm = $MC3{WINDOW_LENGTH_MINUTE}; + } + $date_deb = 0; + $date_prec = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); + $dprec = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); + $date_suiv = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); + $dsuiv = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); + $idarg = "&id=$id"; + } else { + $date_deb = -1; + $date_nbm = 61; + $date_prec = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); + $dprec = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); + $date_suiv = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); + $dsuiv = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); + } + + # prev+next hour 'big arrows' + if (!$dep && defined($SEFRAN3{BIGARROWS})) { + print "
     
    "; + print "
     
    "; + } + + # control-panel fixed box (zoom,mctag toggle,next/prev buttons) + print "
    "; + print "Controls"; + print "
    "; + print "+\n"; + print "=\n"; + print "−\n"; + print "\n"; + print "←\n"; + print "→\n"; + print "\n"; + if ($sgramOK) { + print "
    ", + " ", + "
    \n", + ""; + } + print "
    "; + print "
    "; + + # image of channels + my $voies = "$SEFRAN3{PATH_WEB}/$Yc/$Yc$mc$dc/$SEFRAN3{PATH_IMAGES_HEADER}/$Yc$mc$dc$Hc\_voies.png"; + + # builds the list of minute images + my @liste_png; + for ($i = $date_deb; $i < $date_nbm; $i++) { + my ($Y,$m,$d,$H,$M) = split('/',strftime('%Y/%m/%d/%H/%M',gmtime(timegm(0,($dep ? "$Mc":"0"),$Hc,$dc,$mc-1,$Yc-1900) + $i*60))); + push(@liste_png,sprintf("%s/%4d/%04d%02d%02d/%s/%04d%02d%02d%02d%02d00", + $SEFRAN3{ROOT},$Y,$Y,$m,$d,$SEFRAN3{PATH_IMAGES_MINUTE},$Y,$m,$d,$H,$M)); + } + my $fin = 0; + my $reload = 0; + + if ($voies_classiques && !$dep) { + print "\n"; + } else { + print "\n"; + } + print "\n"; + print ""; + + for (reverse @mc_hlist) { + my %MC = mcinfo($_,1); + +#DL-was: if (($MC{id} > 0 || $userLevel == 4) && $userLevel >= 1 && $MC{id} != $id && ($MC{minute} - $Mc) <= $date_nbm) { + if (($MC{id} > 0 || ($userLevel == 4 && $trash == 1)) && $userLevel >= 1 && ($MC{minute} - $Mc) <= $date_nbm) { + my $deb_evt; + if ($dep) { + $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} - $Mc + $MC{second}/60)); + } else { + $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} + 1 + $MC{second}/60)); + } + my $dur_evt = 1 + int(0.5 + $largeur_image*$MC{duration}*$duration_s{$MC{unit}}/60); + if ($MC{id} != $id) { + print "
    \n"; + } else { + my $dlstripes = "background: repeating-linear-gradient(120deg, white, white 7px, $types{$MC{type}}{Color} 7px, $types{$MC{type}}{Color} 14px);"; + print "
    "; + } + } + } + + print "
    "; + for (@liste_png) { + my $png = qx(basename $_); chomp $png; + my ($Y,$m,$d,$H,$M,$S) = unpack("a4 a2 a2 a2 a2 a2",$png); + my $timestamp = "$Y-$m-$d $H:$M UT"; + my $png_file = "$_".($high ? "_high":"").".png"; + if ( -f $png_file ) { + my $png_web = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_MINUTE}/$png".($high ? "_high":"").".png"; + my $png_sgram = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_SGRAM}/${png}s.png"; + my $mseed = "$mseedreq&t1=$Y,$m,$d,$H,$M,0&ds=60"; + + print "$timestamp', WIDTH, 200)\"", + " shape=rect coords=\"0,0,$largeur_image,$hauteur_label_haut\" alt=\"miniSEED $png\">", + "= 2) { + print " class=\"flyhour\" onMouseOver=\"flyhour(this,'$__{'Click to start input Main Courante'}')\"", + " href=\"$prog&date=$Y$m$d$H$M&s3=$s3\" target=\"_blank\" rel=\"opener\""; + } + print " shape=rect coords=\"0,".($hauteur_label_haut + 1).",$largeur_image,".($hauteur_image - $hauteur_label_haut)."\">"; + print "" if ($sgramOK); + print ""; + } elsif ( "$Y$m$d$H$M" >= "$Ya$ma$da$Ha$Ma") { + if (!$fin) { + print "
    Now
    $Ya-$ma-$da
    $Ha:$Ma:$Sa UTC
    		"; + if (!$reload && !$dep) { + print ""; + $reload = 1; } - - # link to USGS - my $ocl = "USGS"; - $ocl = $MC3{VISIT_LINK} if (defined($MC3{VISIT_LINK})); - print " → $__{'Visit'} $ocl

    \n"; - - # comment - print "

    $__{'Comment'}:

    \n"; - - # options for validation and reset - if ($modif > 0) { - print "
    "; - if (length($MC{qml}) < 3 && $types{$type_evt}{WO2SC3} != -1) { - print "

    " - ."

    \n"; - } - # print and replay - if ($id) { - print "

    $__{'Print signal'}

    \n"; - } else { - print "\n"; - print "" : ">"; # coming in with replay ==> keep replay as a default - print "

    \n"; - } - print "    		", - "  
    \n"; - } - # downloads miniseed - print "
    ", - "
    ", - "", - " $__{'Sefran channels'}
    ", - " $__{'Sefran stations (all components)'}
    ", - " $__{'SeedLink/ArcLink all available channels (!)'}", - "
    \n"; - - print "\n"; - - # vertical tag-lines for event-start, event-end and eventS-P - print "
    START
    \n", - "
    END
    \n"; - print "
     S 
    \n"; - } - - print ""; + $fin = 1; + } + } elsif ( "$Y$m$d$H$M" >= "$Yr$mr$dr$Hr$Mr") { + print "

    In progress...
    $Y-$m-$d
    $H:$M:$S UTC
    		"; + if (!$reload && !$dep) { + print ""; + $reload = 1; + } + } else { + print "
    No image
    $Y-$m-$d
    $H:$M:$S UTC
    		"; + } + } + print "
    "; + print "
    "; + + if ($dep) { + + # default values for mcform; + # case : editing an existing id or not + my $date_evt = ($id ? "$MC{date} $MC{hour}:$MC{minute}" : "$Yc-$mc-$dc $Hc:$Mc"); + my $seconde_evt = ($id ? $MC{second} : ""); + my $type_evt = ($id ? $MC{type} : "$MC3{DEFAULT_TYPE}"); + my $amplitude_evt = ($id ? $MC{amplitude} : "$MC3{DEFAULT_AMPLITUDE}"); + my $duree_evt = ($id ? $MC{duration} : ""); + my $unite_evt = ($id ? $MC{unit} : "s"); + my $duree_sat_evt = ($id ? $MC{overscale} : 0); + my $nb_evt = ($id ? $MC{amount} : 1); + my $s_moins_p_evt = ($id ? $MC{s_minus_p} : "");$s_moins_p_evt =~ s/^NA$//; + my $station = $MC{station}; + my $unique_evt = ($id ? $MC{unique} : 0); + my $operateur = $MC{operator}; + my $comment_evt = ($id ? htmlspecialchars(l2u($MC{comment})) : ""); + + # case : 'replay mode' ('replay' and 'editing id' must be exclusive) + if ($replay && !$id) { + my @mcreplay = qx(awk -F'|' '\$1 == $replay {printf "\%s",\$0}' $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); + my %MCreplay = mcinfo($mcreplay[0]); + $type_evt = $MCreplay{type}; + $amplitude_evt = $MCreplay{amplitude}; + } + + my $modif = 0; + + if ((isok($MC3{LEVEL2_MODIFY_ALL_EVENTS}) && $userLevel ==2) || ($userLevel == 2 && ($operateur eq "" || $operateur eq $USERS{$CLIENT}{UID} || $type_evt eq "AUTO")) || $userLevel == 4 ) { + $modif = 1; + } + + # --- mcform: edit form for Main Courante + print "
    ", + "
    ", + "", + "", + "", + "", + "", + "", + "", + "", # compatibilite MC2: nombre de fichiers + "", # pour compatibilite MC2: remplace par la version SEFRAN + "", + "", + "", + "", + "

    ".($id ? ($modif > 0 ? "$__{'Update'}":""):"$__{'Input'}")." $MC3{TITLE}

    "; + if ($id) { + print "
    "; + if ($modif) { + print ""; + } + print "
    ", + ""; + if ($userLevel == 4) { + print ""; + } + print "$__{'Event'}"; + if ($operateur eq "" || $operateur eq $MC3{SC3_USER}) { + print " $__{'not validated by operator (automatic)'}"; + } else { + print " $__{'identified by'} ".join(',',WebObs::Users::userName($operateur)).""; + } + if (length($MC{qml})>2) { + print "
    QML: $MC{qml}"; + } + print "
    "; + } + + # list of operators + print "

    $__{'Operator'}:

    "; + + # list of stations + print "

    $__{'Station of first arrival'}: "; + print "   Multiple", + "   Unique

    \n"; + + # date and time of first arrival + print "

    Date, HH:MM : "; + + # seconds of first arrival + print " $__{'Seconds'}:

    "; + + # duration + print "

    $__{'Duration'}: "; + print "\n"; + + # number of events + print "  $__{'Number of events'} =

    \n"; + + # S-P + print "

    S−P ($__{'Seconds'}): ", + "", + "", + "

    "; + + # amplitude and saturation + print "

    $__{'Max amplitude'}:

    \n"; + print "

    $__{'Overscale duration'} ($__{'Seconds'}): ", + " (0 = $__{'not overscale'})

    \n"; + + # type of event + print "

    $__{'Event type'}: \n"; + + # Prediction seismic-event + if ($MC3{PREDICT_EVENT_TYPE} ne "" && $MC3{PREDICT_EVENT_TYPE} ne "NO") { + print "\n"; + print "
    \n"; + print "

    $__{'PLEASE WAIT'}

    \n"; + } + + # link to USGS + my $ocl = "USGS"; + $ocl = $MC3{VISIT_LINK} if (defined($MC3{VISIT_LINK})); + print " → $__{'Visit'} $ocl

    \n"; + + # comment + print "

    $__{'Comment'}:

    \n"; + + # options for validation and reset + if ($modif > 0) { + print "
    "; + if (length($MC{qml}) < 3 && $types{$type_evt}{WO2SC3} != -1) { + print "

    " + ."

    \n"; + } + + # print and replay + if ($id) { + print "

    $__{'Print signal'}

    \n"; + } else { + print "\n"; + print "" : ">"; # coming in with replay ==> keep replay as a default + print "

    \n"; + } + print "    		", + "  
    \n"; + } + + # downloads miniseed + print "
    ", + "
    ", + "", + " $__{'Sefran channels'}
    ", + " $__{'Sefran stations (all components)'}
    ", + " $__{'SeedLink/ArcLink all available channels (!)'}", + "
    \n"; + + print "
    \n"; + + # vertical tag-lines for event-start, event-end and eventS-P + print "
    START
    \n", + "
    END
    \n"; + print "
     S 
    \n"; + } + + print ""; } # ---- helpers # ---------------------------------------------------------------------------- sub mcinfo { - my %MC; - - ($MC{id},$MC{date},$MC{time},$MC{type},$MC{amplitude},$MC{duration},$MC{unit},$MC{overscale},$MC{amount},$MC{s_minus_p},$MC{station},$MC{unique},$MC{sefran},$MC{qml},$MC{image},$MC{signature},$MC{comment}) = split(/\|/,$_[0]); - - ($MC{operator},$MC{timestamp}) = split('/',$MC{signature}); - $MC{firstarrival} = "$MC{date} $MC{time} UT"; - $MC{duration} ||= 10; - - my $comment = htmlspecialchars(l2u($MC{comment})); - $comment =~ s/'/\\'/g; # this is needed by overlib() - - ($MC{year},$MC{month},$MC{day}) = split(/-/,$MC{date}); - ($MC{hour},$MC{minute},$MC{second}) = split(/:/,$MC{time}); - - $MC{edit} = "&date=$MC{year}$MC{month}$MC{day}$MC{hour}$MC{minute}&id=$MC{id}"; - - $MC{info} = "":">") - ."by ".join('',WebObs::Users::userName($MC{operator}))."
    " - ."Duration: $MC{duration} $MC{unit}
    " - ."Type: $types{$MC{type}}{Name}
    " - ."Station: $MC{station}".($MC{unique} ? " (unique)":"")."
    " - .($MC{amplitude} ? "Amplitude: $nomAmp{$MC{amplitude}}
    ":"") - ."Comment: $comment" - .""; - - if ($_[1] ne "" && length($MC{qml}) > 2) { - $MC{info} .= "
    SC3 ID: $MC{qml}"; - if (not $hideloc) { - my %QML; - if ($MC3{SC3_EVENTS_ROOT} ne "" && $MC{qml} =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { - my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$MC{qml}); - %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$MC{qml}/$sc3id.last.xml"); - } - elsif ($MC{qml} =~ /:\/\//) { - my ($fdsnws_src,$evt_id) = split(/:\/\//,$MC{qml}); - my $fdsnws_url = ""; - if (defined($MC3{FDSNWS_EVENTS_URL})) { - $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; - } - if (length($fdsnws_src) > 0) { - my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; - $fdsnws_url = "$MC3{$varname}"; - } - %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); - } - $MC{origin} = ($QML{latitude} < 0 ? sprintf("%2.2f°S",-$QML{latitude}):sprintf("%2.2f°N",$QML{latitude})) - ." / ".($QML{longitude} < 0 ? sprintf("%2.2f°W",-$QML{longitude}):sprintf("%2.2f°E",$QML{longitude})) - .($QML{depth} ? " / ".sprintf("%1.1f km",$QML{depth}):""); - - $MC{info} .= "
    Quality: $QML{phases} phases / M":"red>A").($QML{status} ne "" ? " ($QML{status})":"")."
    " - ."Time: $QML{time}
    " - ."Origin: $MC{origin}
    " - .($QML{magtype} && $QML{magnitude} ? "$QML{magtype} = $QML{magnitude}":""); - } - } - - return (%MC); + my %MC; + + ($MC{id},$MC{date},$MC{time},$MC{type},$MC{amplitude},$MC{duration},$MC{unit},$MC{overscale},$MC{amount},$MC{s_minus_p},$MC{station},$MC{unique},$MC{sefran},$MC{qml},$MC{image},$MC{signature},$MC{comment}) = split(/\|/,$_[0]); + + ($MC{operator},$MC{timestamp}) = split('/',$MC{signature}); + $MC{firstarrival} = "$MC{date} $MC{time} UT"; + $MC{duration} ||= 10; + + my $comment = htmlspecialchars(l2u($MC{comment})); + $comment =~ s/'/\\'/g; # this is needed by overlib() + + ($MC{year},$MC{month},$MC{day}) = split(/-/,$MC{date}); + ($MC{hour},$MC{minute},$MC{second}) = split(/:/,$MC{time}); + + $MC{edit} = "&date=$MC{year}$MC{month}$MC{day}$MC{hour}$MC{minute}&id=$MC{id}"; + + $MC{info} = "":">") + ."by ".join('',WebObs::Users::userName($MC{operator}))."
    " + ."Duration: $MC{duration} $MC{unit}
    " + ."Type: $types{$MC{type}}{Name}
    " + ."Station: $MC{station}".($MC{unique} ? " (unique)":"")."
    " + .($MC{amplitude} ? "Amplitude: $nomAmp{$MC{amplitude}}
    ":"") + ."Comment: $comment" + .""; + + if ($_[1] ne "" && length($MC{qml}) > 2) { + $MC{info} .= "
    SC3 ID: $MC{qml}"; + if (not $hideloc) { + my %QML; + if ($MC3{SC3_EVENTS_ROOT} ne "" && $MC{qml} =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { + my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$MC{qml}); + %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$MC{qml}/$sc3id.last.xml"); + } + elsif ($MC{qml} =~ /:\/\//) { + my ($fdsnws_src,$evt_id) = split(/:\/\//,$MC{qml}); + my $fdsnws_url = ""; + if (defined($MC3{FDSNWS_EVENTS_URL})) { + $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; + } + if (length($fdsnws_src) > 0) { + my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; + $fdsnws_url = "$MC3{$varname}"; + } + %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); + } + $MC{origin} = ($QML{latitude} < 0 ? sprintf("%2.2f°S",-$QML{latitude}):sprintf("%2.2f°N",$QML{latitude})) + ." / ".($QML{longitude} < 0 ? sprintf("%2.2f°W",-$QML{longitude}):sprintf("%2.2f°E",$QML{longitude})) + .($QML{depth} ? " / ".sprintf("%1.1f km",$QML{depth}):""); + + $MC{info} .= "
    Quality: $QML{phases} phases / M":"red>A").($QML{status} ne "" ? " ($QML{status})":"")."
    " + ."Time: $QML{time}
    " + ."Origin: $MC{origin}
    " + .($QML{magtype} && $QML{magnitude} ? "$QML{magtype} = $QML{magnitude}":""); + } + } + + return (%MC); } __END__ diff --git a/CODE/cgi-bin/showBOJAP.pl b/CODE/cgi-bin/showBOJAP.pl index e827c8a7..56e36537 100755 --- a/CODE/cgi-bin/showBOJAP.pl +++ b/CODE/cgi-bin/showBOJAP.pl @@ -99,20 +99,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -126,6 +126,7 @@ =head1 Query string parameters my @csv; my $s = ""; my $i = 0; + #D my %stationsBojap; #D my @codesBojap; @@ -141,12 +142,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamUnite = ("ppm|en ppm","mmol|en mmol/l"); my @cleParamSite; @@ -156,31 +157,32 @@ =head1 Query string parameters my $nbRap = 0; my @rapCalc; -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "Tout"; -$QryParm->{'site'} ||= "Tout"; -$QryParm->{'affiche'} ||= ""; -$QryParm->{'unite'} ||= "ppm"; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "Tout"; +$QryParm->{'site'} ||= "Tout"; +$QryParm->{'affiche'} ||= ""; +$QryParm->{'unite'} ||= "ppm"; # ---- a site requested as {name} means "all nodes for proc 'name'" # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } $i = 0; for (@rapports) { - $i++; - my $rapn = "rap$i"; - #djl-was: if ($valParams =~ /$rapn/) { - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } + $i++; + my $rapn = "rap$i"; + + #djl-was: if ($valParams =~ /$rapn/) { + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } } # ---- Lecture du fichier data dans tableau @lignes @@ -196,67 +198,67 @@ =head1 Query string parameters # ---- html page setup # push(@html,"Content-type: text/html\n\n", - "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n\n", - "\n", - "
    \n", - "\n", - "\n"); + "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n\n", + "\n", + "
    \n", + "\n", + "\n"); # ---- Debut du formulaire pour la selection de l'affichage # push(@html,"
    conf('CGI_SHOW')."\" method=\"get\">", - "

    ", - "Sélectionner: \n"); +for ("Tout|Tout",reverse(@cleParamAnnee)) { + my ($val,$cle)=split (/\|/,$_); + if ("$val" eq "$QryParm->{'annee'}") { push(@html,"\n"); } + else { push(@html,"\n"); } } push(@html,"\n", - ""); +for ("Tout|Toute l'année",@cleParamMois) { + my ($val,$cle)=split (/\|/,$_); + if ("$val" eq "$QryParm->{'mois'}") { + push(@html,"\n"); + $afficheMois = $cle; + } else { + push(@html,"\n"); + } } push(@html,"\n", - ""); +for ("Tout|Tous les sites",@NODESSelList) { + my ($val,$cle)=split (/\|/,$_); + if ("$val" eq "$QryParm->{'site'}") { + push(@html,"\n"); + $afficheSite = "$cle ($val)"; + } else { + push(@html,"\n"); + } } push(@html,"\n", - ""); +for (@cleParamUnite) { + my ($val,$cle) = split (/\|/,$_); + if ("$val" eq "$QryParm->{'unite'}") { push(@html,"\n"); } + else { push(@html,"\n"); } } push(@html,"", - " "); + " "); if ($displayOnly ne 1) { - push(@html,"conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + push(@html,"conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); } push(@html,"
    \nRapports calculés: "); $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - $i++; - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - push(@html,"$nhtm/$dhtm  "); + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + $i++; + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + push(@html,"$nhtm/$dhtm  "); } push(@html,"

    \n"); push(@html,"

    ".$FORM->conf('TITLE')."

    "); @@ -270,133 +272,133 @@ =head1 Query string parameters my $unite; my $fmt = "%0.2f"; if ($QryParm->{'unite'} eq "ppm") { - $unite = "ppm = mg/l"; + $unite = "ppm = mg/l"; } else { - $unite = "mmol/l"; + $unite = "mmol/l"; } my $aliasSite; $entete = "
    PériodeSiteSolution initialeMasse échantillon (g)Concentrations ($unite) Calculs
    DuAuNb
    jours    		H20
    (ml)    		KOH
    (mol/l)    		M1M2M3M4TotalCl-CO2-SO4--Flux Cl
    (g/j)    		Flux C
    (g/j)    		Flux S
    (g/j)    		Flux H2O
    (g/j)    		Solution initialeMasse échantillon (g)Concentrations ($unite) Calculs
    DuAuNb
    jours    		H20
    (ml)    		KOH
    (mol/l)    		M1M2M3M4TotalCl-CO2-SO4--Flux Cl
    (g/j)    		Flux C
    (g/j)    		Flux S
    (g/j)    		Flux H2O
    (g/j)
    $nhtm
    $dthm
    $nhtm
    $dthm
    $rapv[$iv]
    $modif$date1$date2$nj$lien$h2o$koh$m1$m2$m3$m4$mtot$cCl_mmol$cCO2_mmol$cSO4_mmol$cCl$cCO2$cSO4$f_Cl$f_C$f_S$f_H2O"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."
    $rapv[$iv]
    $modif$date1$date2$nj$lien$h2o$koh$m1$m2$m3$m4$mtot$cCl_mmol$cCO2_mmol$cSO4_mmol$cCl$cCO2$cSO4$f_Cl$f_C$f_S$f_H2O"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."
    $entete\n$texte\n$entete\n
    "); + push(@html,"$entete\n$texte\n$entete\n
    "); } # Time to display (or download csv) # push(@html,"
    \n\n\n"); if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; + print @html; } __END__ diff --git a/CODE/cgi-bin/showDISTANCE.pl b/CODE/cgi-bin/showDISTANCE.pl index cfc59de8..c292eb93 100755 --- a/CODE/cgi-bin/showDISTANCE.pl +++ b/CODE/cgi-bin/showDISTANCE.pl @@ -88,20 +88,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -148,10 +148,10 @@ =head1 Query string parameters # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/csv\n\n"); @@ -159,62 +159,62 @@ =head1 Query string parameters # ---- start html if not csv output requested if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
    Recherche des données, merci de patienter.
    ", - "
    \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "
    \n", + "\n", + "\n"; } # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print("
    conf('CGI_SHOW')."\" method=\"get\">", - "

    ", - "Sélectionner: \n", - "\n", - "", - " "); - if ($editOK) { - print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); - } - print "

    \n", - "

    ".$FORM->conf('TITLE')."

    \n", - "

    Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
    ", - "Sites sélectionnés: $afficheSite
    "; + print("

    conf('CGI_SHOW')."\" method=\"get\">", + "

    ", + "Sélectionner: \n", + "\n", + "", + " "); + if ($editOK) { + print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + } + print "

    \n", + "

    ".$FORM->conf('TITLE')."

    \n", + "

    Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
    ", + "Sites sélectionnés: $afficheSite
    "; } # ---- Lecture du fichier data dans tableau @lignes @@ -238,113 +238,114 @@ =head1 Query string parameters $entete = "

    DateSiteAEMDInfos TourelleMesures de distance: D0 (m) + dn (mm)Moyenne (m)
    Patm
    (mmHg)    		Tair
    (°C)    		H.R.
    (%)    		NébulVitreD0
    (m)"; + ."    		AEMDInfos TourelleMesures de distance: D0 (m) + dn (mm)Moyenne (m)
    Patm
    (mmHg)    		Tair
    (°C)    		H.R.
    (%)    		NébulVitreD0
    (m)"; for ("01".."20") { $entete = $entete."    		d$_x2σ
    $modif$date $heure$lien$aemd$pAtm$tAir$HR$nebul$vitre$d0$d[$_]".sprintf("%1.3f",$DM).""; - } elsif ($DS > 0.02 ) { - $texte .= ""; - } else { - $texte .= ""; - } - $texte .= sprintf("%1.3f",$DS).""; - $txt = "$date;$heure;$site;$aliasSite;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;$DM;$DS;"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."
    $modif$date $heure$lien$aemd$pAtm$tAir$HR$nebul$vitre$d0$d[$_]".sprintf("%1.3f",$DM).""; + } elsif ($DS > 0.02 ) { + $texte .= ""; + } else { + $texte .= ""; + } + $texte .= sprintf("%1.3f",$DS).""; + $txt = "$date;$heure;$site;$aliasSite;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;$DM;$DS;"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."
    $entete\n$texte\n$entete\n
    ", - "

    Types de Distancemètres: "); - for (@types) { - my ($tpi,$tpn) = split(/\|/,$_); - push(@html,"$tpi = $tpn, "); - } - push(@html,"\n

    Nébulosité: "); - for (@meteo) { - my ($tpi,$tpn) = split(/\|/,$_); - push(@html,"$tpi = $tpn, "); - } - push(@html,"

    \n"); + push(@html,"$entete\n$texte\n$entete\n
    ", + "

    Types de Distancemètres: "); + for (@types) { + my ($tpi,$tpn) = split(/\|/,$_); + push(@html,"$tpi = $tpn, "); + } + push(@html,"\n

    Nébulosité: "); + for (@meteo) { + my ($tpi,$tpn) = split(/\|/,$_); + push(@html,"$tpi = $tpn, "); + } + push(@html,"

    \n"); } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/showEAUX.pl b/CODE/cgi-bin/showEAUX.pl index 6ac00e91..f2128ea1 100755 --- a/CODE/cgi-bin/showEAUX.pl +++ b/CODE/cgi-bin/showEAUX.pl @@ -128,21 +128,21 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (sort keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # ---- DateTime inits ---------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $day = strftime('%d',@tod); -my $month = strftime('%m',@tod); +my $day = strftime('%d',@tod); +my $month = strftime('%m',@tod); my $year = strftime('%Y',@tod); my $endDate = strftime('%F',@tod); my $delay = $FORM->conf('DEFAULT_DAYS') // 30; @@ -171,12 +171,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$year) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamUnite = ("ppm|en ppm","mmol|en mmol/l"); my @cleParamSite; @@ -186,18 +186,18 @@ =head1 Query string parameters my $nbRap = 0; my @rapCalc; -$QryParm->{'y1'} //= $y1; -$QryParm->{'m1'} //= $m1; -$QryParm->{'d1'} //= $d1; -$QryParm->{'y2'} //= $year; -$QryParm->{'m2'} //= $month; -$QryParm->{'d2'} //= $day; -$QryParm->{'node'} //= "All"; -$QryParm->{'iode'} //= ""; -$QryParm->{'sio2'} //= ""; -$QryParm->{'isotopes'} //= ""; -$QryParm->{'affiche'} //= ""; -$QryParm->{'unite'} //= "ppm"; +$QryParm->{'y1'} //= $y1; +$QryParm->{'m1'} //= $m1; +$QryParm->{'d1'} //= $d1; +$QryParm->{'y2'} //= $year; +$QryParm->{'m2'} //= $month; +$QryParm->{'d2'} //= $day; +$QryParm->{'node'} //= "All"; +$QryParm->{'iode'} //= ""; +$QryParm->{'sio2'} //= ""; +$QryParm->{'isotopes'} //= ""; +$QryParm->{'affiche'} //= ""; +$QryParm->{'unite'} //= "ppm"; if ($QryParm->{'unite'} eq "ppm") {$unite = "ppm = mg/l"} else {$unite = "mmol/l"} $startDate = "$QryParm->{'y1'}-$QryParm->{'m1'}-$QryParm->{'d1'}"; @@ -207,20 +207,20 @@ =head1 Query string parameters # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } $i = 0; for (@rapports) { - $i++; - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } + $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } } # ---- @@ -230,87 +230,87 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
    Recherche des données, merci de patienter.
    ", - "
    \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "
    \n", + "\n", + "\n"; } # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'affiche'} ne "csv") { - print "
    conf('CGI_SHOW')."\" method=\"get\">", - "

    ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  \n", - "", - " ", - " "); - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('return_url' => $return_url); - print qq(); - } - print("
    \n"); - print("{'iode'} ne ""? " checked":"").">Iode  "); - print("{'sio2'} ne ""? " checked":"").">SiO2  "); - print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); - print("  \n$__{'Ratios'}: "); - - $i = 0; - for (@rapports) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - $i++; - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print("$nhtm/$dhtm  "); - } - print "

    \n", - "

    ".$FORM->conf('TITLE')."

    \n", - "

    "; + print "

    conf('CGI_SHOW')."\" method=\"get\">", + "

    ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  \n", + "", + " ", + " "); + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('return_url' => $return_url); + print qq(); + } + print("
    \n"); + print("{'iode'} ne ""? " checked":"").">Iode  "); + print("{'sio2'} ne ""? " checked":"").">SiO2  "); + print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); + print("  \n$__{'Ratios'}: "); + + $i = 0; + for (@rapports) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + $i++; + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print("$nhtm/$dhtm  "); + } + print "

    \n", + "

    ".$FORM->conf('TITLE')."

    \n", + "

    "; } # ---- Read the data file @@ -330,185 +330,186 @@ =head1 Query string parameters $entete = ""; if ($clientAuth > 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."Date" - ."Site
    (Type)" - ."Mesures sur site" - ."Cations ($unite)" - ."Anions ($unite)" - .($QryParm->{'sio2'} ne "" ? "Autres":"") - .($QryParm->{'isotopes'} ne "" ? "Isotopes":"") - ." Calculs" - ."\n" - ."T air
    (°C)" - ."T eau
    (°C)" - ."pH" - ."Débit
    (l/min)" - ."Cond
    (µS)" - ."Niveau
    (m)" - ."Li+" - ."Na+" - ."K+" - ."Mg++" - ."Ca++" - ."F-" - ."Cl-" - ."Br-" - ."NO3-" - ."SO4--" - ."HCO3-" - .($QryParm->{'iode'} ne "" ? "I-".($QryParm->{'unite'} ne "mmol" ? "
    (ppb)":"")."":"") - .($QryParm->{'sio2'} ne "" ? "SiO2".($QryParm->{'unite'} ne "mmol" ? "
    (ppb)":"")."":"") - .($QryParm->{'isotopes'} ne "" ? "δ13Cδ18OδD":"") - ."Cond25
    (μS)" - ."NICB
    (%)"; + ."Site
    (Type)" + ."Mesures sur site" + ."Cations ($unite)" + ."Anions ($unite)" + .($QryParm->{'sio2'} ne "" ? "Autres":"") + .($QryParm->{'isotopes'} ne "" ? "Isotopes":"") + ." Calculs" + ."\n" + ."T air
    (°C)" + ."T eau
    (°C)" + ."pH" + ."Débit
    (l/min)" + ."Cond
    (µS)" + ."Niveau
    (m)" + ."Li+" + ."Na+" + ."K+" + ."Mg++" + ."Ca++" + ."F-" + ."Cl-" + ."Br-" + ."NO3-" + ."SO4--" + ."HCO3-" + .($QryParm->{'iode'} ne "" ? "I-".($QryParm->{'unite'} ne "mmol" ? "
    (ppb)":"")."":"") + .($QryParm->{'sio2'} ne "" ? "SiO2".($QryParm->{'unite'} ne "mmol" ? "
    (ppb)":"")."":"") + .($QryParm->{'isotopes'} ne "" ? "δ13Cδ18OδD":"") + ."Cond25
    (μS)" + ."NICB
    (%)"; $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - $i++; - if ($rap[$i] == 1) { - $entete = $entete."
    $nhtm
    $dthm
    "; - } + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + $i++; + if ($rap[$i] == 1) { + $entete = $entete."
    $nhtm
    $dthm
    "; + } } - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date;$heure;Code Site;$site;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;$d13C;$d18O;$dD;Cond25;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) - && ($id > 0 || $clientAuth == 4) - && ($date le $endDate) && ($date ge $startDate)) { - - my ($cLi_mmol,$cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cF_mmol,$cCl_mmol,$cBr_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol,$cI_mmol,$cSiO2_mmol); - $cLi_mmol=$cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cF_mmol=$cCl_mmol=$cBr_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=$cI_mmol=$cSiO2_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; - my $cond25 = ""; - my $nicb = ""; - my @rapv; - my $iv = 0; - my $rapport = ""; - - if ($cLi ne "") { $cLi_mmol = $cLi/$GMOL{Li}; }; - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cF ne "") { $cF_mmol = $cF/$GMOL{F}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cBr ne "") { $cBr_mmol = $cBr/$GMOL{Br}; }; - if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($cI ne "") { $cI_mmol = 0.001*$cI/$GMOL{I}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - if (($cond ne "") && ($tSource ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tSource - 25))); }; - $tzp = $cLi_mmol + $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; - if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cF_mmol + $cCl_mmol + $cBr_mmol + $cNO3_mmol + 2*$cSO4_mmol + $cHCO3_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - for (@rapports) { - my ($num,$den,$nrp) = split(/\|/,$_); - $iv++; - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - if ($rap[$iv] == 1) { - $rapport = $rapport."$rapv[$iv]"; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { - $lien = "$aliasSite"; - } - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('id' => $id, 'return_url' => $return_url); - $modif = qq(); - $efface = qq(); - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$date $heure$lien $type$tAir$tSource$pH$debit$cond$niveau"; - $txt = "$date;$heure;$site;$aliasSite;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;"; - if ($QryParm->{'unite'} eq "mmol") { - for ("Li","Na","K","Mg","Ca","F","Cl","Br","NO3","SO4","HCO3","I","SiO2") { - if ($QryParm->{'iode'} ne "" || $_ ne "I") { - $texte .= ""; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= ""; - } - } - $txt .= "$cLi_mmol;$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cF_mmol;$cCl_mmol;$cBr_mmol;$cNO3_mmol;$cSO4_mmol;$cHCO3_mmol;$cI_mmol;$cSiO2_mmol;"; - } else { - $texte .= "$cLi$cNa$cK$cMg$cCa$cF$cCl$cBr$cNO3$cSO4$cHCO3" - .($QryParm->{'iode'} ne ""?"$cI":"") - .($QryParm->{'sio2'} ne ""?"$cSiO2":""); - $txt .= "$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;"; - } - if ($QryParm->{'isotopes'} ne "") { - $texte .= "$d13C$d18O$dD"; - } - $texte .= "$cond25"; - if ($nicb and ($nicb < -20) || ($nicb > 20)) { - $texte .= ""; - } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= "$rapport"; - #$texte = $texte."$so4_cl$hco3_cl$ca_cl"; - $txt = $txt."$d13C;$d18O;$dD;$cond25;$nicb;\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date;$heure;Code Site;$site;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;$d13C;$d18O;$dD;Cond25;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) + && ($id > 0 || $clientAuth == 4) + && ($date le $endDate) && ($date ge $startDate)) { + + my ($cLi_mmol,$cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cF_mmol,$cCl_mmol,$cBr_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol,$cI_mmol,$cSiO2_mmol); + $cLi_mmol=$cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cF_mmol=$cCl_mmol=$cBr_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=$cI_mmol=$cSiO2_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + my $cond25 = ""; + my $nicb = ""; + my @rapv; + my $iv = 0; + my $rapport = ""; + + if ($cLi ne "") { $cLi_mmol = $cLi/$GMOL{Li}; }; + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cF ne "") { $cF_mmol = $cF/$GMOL{F}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cBr ne "") { $cBr_mmol = $cBr/$GMOL{Br}; }; + if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($cI ne "") { $cI_mmol = 0.001*$cI/$GMOL{I}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + if (($cond ne "") && ($tSource ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tSource - 25))); }; + $tzp = $cLi_mmol + $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cF_mmol + $cCl_mmol + $cBr_mmol + $cNO3_mmol + 2*$cSO4_mmol + $cHCO3_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + for (@rapports) { + my ($num,$den,$nrp) = split(/\|/,$_); + $iv++; + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + if ($rap[$iv] == 1) { + $rapport = $rapport."$rapv[$iv]"; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { + $lien = "$aliasSite"; + } + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('id' => $id, 'return_url' => $return_url); + $modif = qq(); + $efface = qq(); + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$date $heure$lien $type$tAir$tSource$pH$debit$cond$niveau"; + $txt = "$date;$heure;$site;$aliasSite;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;"; + if ($QryParm->{'unite'} eq "mmol") { + for ("Li","Na","K","Mg","Ca","F","Cl","Br","NO3","SO4","HCO3","I","SiO2") { + if ($QryParm->{'iode'} ne "" || $_ ne "I") { + $texte .= ""; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= ""; + } + } + $txt .= "$cLi_mmol;$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cF_mmol;$cCl_mmol;$cBr_mmol;$cNO3_mmol;$cSO4_mmol;$cHCO3_mmol;$cI_mmol;$cSiO2_mmol;"; + } else { + $texte .= "$cLi$cNa$cK$cMg$cCa$cF$cCl$cBr$cNO3$cSO4$cHCO3" + .($QryParm->{'iode'} ne ""?"$cI":"") + .($QryParm->{'sio2'} ne ""?"$cSiO2":""); + $txt .= "$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;"; + } + if ($QryParm->{'isotopes'} ne "") { + $texte .= "$d13C$d18O$dD"; + } + $texte .= "$cond25"; + if ($nicb and ($nicb < -20) || ($nicb > 20)) { + $texte .= ""; + } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= "$rapport"; + +#$texte = $texte."$so4_cl$hco3_cl$ca_cl"; + $txt = $txt."$d13C;$d18O;$dD;$cond25;$nicb;\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Number of records = $nbLignesRetenues / $nbData.

    \n", - "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}\">$fileCSV

    \n"); + "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
    ", - "

    Types of sites: "); - for (sort(keys(%types))) { - push(@html,"$_ = $types{$_}{name}, "); - } - push(@html,"

    "); + push(@html,"$entete\n$texte\n$entete\n
    ", + "

    Types of sites: "); + for (sort(keys(%types))) { + push(@html,"$_ = $types{$_}{name}, "); + } + push(@html,"

    "); } push(@html,@notes); if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/showEXTENSO.pl b/CODE/cgi-bin/showEXTENSO.pl index c452c8c2..acebb067 100755 --- a/CODE/cgi-bin/showEXTENSO.pl +++ b/CODE/cgi-bin/showEXTENSO.pl @@ -91,18 +91,18 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -144,23 +144,23 @@ =head1 Query string parameters # ---- Get most recent date, needed when using default dates range my (@dd) = split(/\|/,$lignes[$#lignes - 1]); my $lastDate = $dd[1]; -my ($lastY,$lastM,$lastD) = split(/-/,$lastDate); +my ($lastY,$lastM,$lastD) = split(/-/,$lastDate); # get query-string parameters # --------------------------------------------------------------- if ($QP->{y1} && $QP->{m1} && $QP->{d1} && $QP->{y2} && $QP->{m2} && $QP->{d2} ) { - $dateStart = "$QP->{y1}-$QP->{m1}-$QP->{d1}" ; - $dateEnd = "$QP->{y2}-$QP->{m2}-$QP->{d2}"; - my $nbJours = sprintf("%1.0f",(qx(date -d "$dateEnd" +%s) - qx(date -d "$dateStart" +%s))/86400 + 1); - $afficheDates = "$dateStart à $dateEnd ($nbJours jours)"; + $dateStart = "$QP->{y1}-$QP->{m1}-$QP->{d1}" ; + $dateEnd = "$QP->{y2}-$QP->{m2}-$QP->{d2}"; + my $nbJours = sprintf("%1.0f",(qx(date -d "$dateEnd" +%s) - qx(date -d "$dateStart" +%s))/86400 + 1); + $afficheDates = "$dateStart à $dateEnd ($nbJours jours)"; } else { - my $u = $FORM->conf('DELAY'); - $dateEnd = $lastDate; - $dateStart = qx(date -d "$dateEnd $u days ago" +"%Y-%m-%d"); - chomp($dateStart); - ($QP->{y1},$QP->{m1},$QP->{d1}) = split(/-/,$dateStart); - ($QP->{y2},$QP->{m2},$QP->{d2}) = split(/-/,$dateEnd); - $afficheDates = "$dateStart à $dateEnd (défaut = ".$FORM->conf('DELAY')." derniers jours de mesures)"; + my $u = $FORM->conf('DELAY'); + $dateEnd = $lastDate; + $dateStart = qx(date -d "$dateEnd $u days ago" +"%Y-%m-%d"); + chomp($dateStart); + ($QP->{y1},$QP->{m1},$QP->{d1}) = split(/-/,$dateStart); + ($QP->{y2},$QP->{m2},$QP->{d2}) = split(/-/,$dateEnd); + $afficheDates = "$dateStart à $dateEnd (défaut = ".$FORM->conf('DELAY')." derniers jours de mesures)"; } $QP->{'site'} ||= "Tout"; @@ -171,10 +171,10 @@ =head1 Query string parameters # my @gridsites; if ($QP->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -182,21 +182,21 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QP->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
    Recherche des données, merci de patienter.
    ", - "
    \n", - "\n", - "\n"; - - # Javascript for selection's form - print <<"FIN"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "
    \n", + "\n", + "\n"; + + # Javascript for selection's form + print <<"FIN"; \n", + "\n", + + print <<"FIN"; \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "$titrePage\n", + "", + "\n"; + + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "\n", + "
    \n", + "\n", + "\n", + "\n"; } # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print "
    conf('CGI_SHOW')."\" method=\"get\">", - "

    ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  \n", - " ", - " "; - if ($clientAuth > 1) { - print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; - } - print("
    \n"); - print "Sampling type:   "); - print("{'radon'} ne ""? " checked":"").">Rn  "); - print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); - print "

    \n", - "

    ".$FORM->conf('TITLE')."

    \n", - "

    "; + print "

    conf('CGI_SHOW')."\" method=\"get\">", + "

    ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  \n", + " ", + " "; + if ($clientAuth > 1) { + print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; + } + print("
    \n"); + print "Sampling type:   "); + print("{'radon'} ne ""? " checked":"").">Rn  "); + print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); + print "

    \n", + "

    ".$FORM->conf('TITLE')."

    \n", + "

    "; } # ---- Read the data file @@ -283,95 +283,95 @@ =head1 Query string parameters $entete = ""; if ($clientAuth > 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."DateSite" - ."On-site measurementsTypeConcentrations (%)" - .($QryParm->{'radon'} ne "" ? "Rn
    (cp/mn)":"") - .($QryParm->{'isotopes'} ne "" ? "Isotopes":"") - ."S/C\n" - ."T (°C)pHFlux" - ."H2HeCOCH4N2H2SArCO2SO2O2" - .($QryParm->{'isotopes'} ne ""? "δ13Cδ18O":""); - + ."On-site measurementsTypeConcentrations (%)" + .($QryParm->{'radon'} ne "" ? "Rn
    (cp/mn)":"") + .($QryParm->{'isotopes'} ne "" ? "Isotopes":"") + ."S/C\n" + ."T (°C)pHFlux" + ."H2HeCOCH4N2H2SArCO2SO2O2" + .($QryParm->{'isotopes'} ne ""? "δ13Cδ18O":""); + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$site,$tFum,$pH,$debit,$Rn,$type,$H2,$He,$CO,$CH4,$N2,$H2S,$Ar,$CO2,$SO2,$O2,$d13C,$d18O,$rem,$val) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,u2l("$date;$heure;Code Site;$site;$tFum;$pH;$debit;$type;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;S/C;\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) - && ($QryParm->{'ampoule'} eq "" || $type eq $QryParm->{'ampoule'}) - && ($id > 0 || $clientAuth == 4) - && ($date le $endDate) && ($date ge $startDate)) { - - my $S_C = ""; - if (($CO2 != 0) && ($type ne "NaOH")) { - $S_C = sprintf("%1.2f",($SO2 + $H2S)/$CO2); - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$date $heure$lien" - ."$tFum$pH$debit$types{$type}{name}" - ."$H2$He$CO$CH4" - ."$N2$H2S$Ar$CO2" - ."$SO2$O2" - .($QryParm->{'radon'} ne "" ? "$Rn":"") - .($QryParm->{'isotopes'} ne "" ? "$d13C$d18O":"") - ."$S_C"; - $txt = "$date;$heure;$site;$aliasSite;$tFum;$pH;$debit;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;$S_C"; - $txt = $txt."\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $rem = l2u($rem); - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$site,$tFum,$pH,$debit,$Rn,$type,$H2,$He,$CO,$CH4,$N2,$H2S,$Ar,$CO2,$SO2,$O2,$d13C,$d18O,$rem,$val) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,u2l("$date;$heure;Code Site;$site;$tFum;$pH;$debit;$type;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;S/C;\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) + && ($QryParm->{'ampoule'} eq "" || $type eq $QryParm->{'ampoule'}) + && ($id > 0 || $clientAuth == 4) + && ($date le $endDate) && ($date ge $startDate)) { + + my $S_C = ""; + if (($CO2 != 0) && ($type ne "NaOH")) { + $S_C = sprintf("%1.2f",($SO2 + $H2S)/$CO2); + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$date $heure$lien" + ."$tFum$pH$debit$types{$type}{name}" + ."$H2$He$CO$CH4" + ."$N2$H2S$Ar$CO2" + ."$SO2$O2" + .($QryParm->{'radon'} ne "" ? "$Rn":"") + .($QryParm->{'isotopes'} ne "" ? "$d13C$d18O":"") + ."$S_C"; + $txt = "$date;$heure;$site;$aliasSite;$tFum;$pH;$debit;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;$S_C"; + $txt = $txt."\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $rem = l2u($rem); + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Number of records = $nbLignesRetenues / $nbData.

    \n", - "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&oule=$QryParm->{'ampoule'}\">$fileCSV

    \n"); + "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&oule=$QryParm->{'ampoule'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
    ", - "

    Types d'Ampoules: "); - for (keys(%types)) { - push(@html,"$types{$_}{name} = $_, "); - } - push(@html,"\n

    Débits: "); - for (keys(%debits)) { - push(@html,"$debits{$_} = $_, "); - } - push(@html,"

    \n"); + push(@html,"$entete\n$texte\n$entete\n
    ", + "

    Types d'Ampoules: "); + for (keys(%types)) { + push(@html,"$types{$_}{name} = $_, "); + } + push(@html,"\n

    Débits: "); + for (keys(%debits)) { + push(@html,"$debits{$_} = $_, "); + } + push(@html,"

    \n"); } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/showGENFORM.pl b/CODE/cgi-bin/showGENFORM.pl index d5c44b0a..3c6406d9 100755 --- a/CODE/cgi-bin/showGENFORM.pl +++ b/CODE/cgi-bin/showGENFORM.pl @@ -1,6 +1,5 @@ #!/usr/bin/perl - =head1 NAME showGENFORM.pl @@ -62,7 +61,6 @@ =head1 Query string parameters use Locale::TextDomain('webobs'); use WebObs::Form; - # Keep the URL where the user should be returned after edition # (this will keep the filters selected by the user) my $return_url = $cgi->url(-query_string => 1); @@ -79,8 +77,8 @@ =head1 Query string parameters # ---- DateTime inits ---------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $day = strftime('%d',@tod); -my $month = strftime('%m',@tod); +my $day = strftime('%d',@tod); +my $month = strftime('%m',@tod); my $year = strftime('%Y',@tod); my $today = strftime('%F',@tod); my $default_days = $FORM{DEFAULT_DAYS} // 30; @@ -88,31 +86,31 @@ =head1 Query string parameters # ---- get CGI parameters my $QryParm = $cgi->Vars; -$QryParm->{'y1'} //= $y1; -$QryParm->{'m1'} //= $m1; -$QryParm->{'d1'} //= $d1; -$QryParm->{'y2'} //= $year; -$QryParm->{'m2'} //= $month; -$QryParm->{'d2'} //= $day; -$QryParm->{'node'} //= ""; +$QryParm->{'y1'} //= $y1; +$QryParm->{'m1'} //= $m1; +$QryParm->{'d1'} //= $d1; +$QryParm->{'y2'} //= $year; +$QryParm->{'m2'} //= $month; +$QryParm->{'d2'} //= $day; +$QryParm->{'node'} //= ""; $QryParm->{'trash'} //= "0"; -$QryParm->{'dump'} //= ""; -$QryParm->{'debug'} //= ""; +$QryParm->{'dump'} //= ""; +$QryParm->{'debug'} //= ""; -my $re = $QryParm->{'filter'}; +my $re = $QryParm->{'filter'}; my %Ns; my @NODESSelList; my %Ps = $F->procs; for my $p (sort keys(%Ps)) { - if ($QryParm->{'node'} =~ /^$|^PROC\.$p(\.|$)/) { - push(@NODESSelList,"PROC.$p|-- {PROC.$p} $Ps{$p} --"); - my %N = $F->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"PROC.$p.$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); - } + if ($QryParm->{'node'} =~ /^$|^PROC\.$p(\.|$)/) { + push(@NODESSelList,"PROC.$p|-- {PROC.$p} $Ps{$p} --"); + my %N = $F->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"PROC.$p.$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); + } } my @validity = split(/[, ]/, ($FORM{VALIDITY_COLORS} ? $FORM{VALIDITY_COLORS}:"#66FF66,#FFD800,#FFAAAA")); @@ -121,12 +119,12 @@ =head1 Query string parameters my @formulas; my @thresh; foreach (sort keys %FORM) { - if ($_ =~ /^OUTPUT.*_TYPE/ && $FORM{$_} =~ /^formula/) { - push(@formulas, (split /_TYPE/, $_)[0]); - } - if ($_ =~ /^(IN|OUT)PUT.*_THRESHOLD/) { - push(@thresh, (split /_THRESHOLD/, $_)[0]); - } + if ($_ =~ /^OUTPUT.*_TYPE/ && $FORM{$_} =~ /^formula/) { + push(@formulas, (split /_TYPE/, $_)[0]); + } + if ($_ =~ /^(IN|OUT)PUT.*_THRESHOLD/) { + push(@thresh, (split /_THRESHOLD/, $_)[0]); + } } # ---- specific FORMS inits ---------------------------------- @@ -146,36 +144,35 @@ =head1 Query string parameters my $delay = datediffdays($startDate,$endDate); # ---- a site requested as PROC.name means "all nodes for proc 'name'" - + my @procnodes; if ($QryParm->{'node'} =~ /^PROC\.([^.]*)$/) { - my %tmpN = $F->nodes($1); - for (keys(%tmpN)) { - push(@procnodes,"$_"); - } + my %tmpN = $F->nodes($1); + for (keys(%tmpN)) { + push(@procnodes,"$_"); + } } if ($QryParm->{'node'} =~ /^PROC\.[^.]*\.(.*)$/) { - push(@procnodes,"$1"); + push(@procnodes,"$1"); } - # ---- start html if not CSV output if ($QryParm->{'dump'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM{TITLE}."\n", - "", - "\n"; - - print "\n", - "\n", - "
    $__{'Searching for data, please wait.'}
    \n", - "
    \n", - "\n", - "\n"; - - print <<"EOF"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM{TITLE}."\n", + "", + "\n"; + + print "\n", + "\n", + "
    $__{'Searching for data, please wait.'}
    \n", + "
    \n", + "\n", + "\n"; + + print <<"EOF"; EOF } else { - push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/csv\n\n"); + push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/csv\n\n"); } # ---- Read the data file @@ -215,20 +212,20 @@ =head1 Query string parameters # make an hash of hash of input type lists my %lists; foreach my $k (@rownames) { - my $list = $FORM{uc("$k")."_TYPE"}; - if ($list =~ /^list:/) { - my %l = extract_list($list,$form); - $lists{$k} = {%l}; - } + my $list = $FORM{uc("$k")."_TYPE"}; + if ($list =~ /^list:/) { + my %l = extract_list($list,$form); + $lists{$k} = {%l}; + } } # get the requested data my $filter = "((sdate BETWEEN '$startDate' AND '$endDate') OR (edate BETWEEN '$startDate' AND '$endDate'))"; $filter .= " AND trash = false" if (!$QryParm->{'trash'}); -$filter .= " AND node IN ('".join("','",@procnodes)."')" if ($#procnodes >= 0); +$filter .= " AND node IN ('".join("','",@procnodes)."')" if ($#procnodes >= 0); foreach (keys %lists) { - my $sel_list = $QryParm->{$_}; - $filter .= " AND $_ = \"$sel_list\"" if ($sel_list ne ""); + my $sel_list = $QryParm->{$_}; + $filter .= " AND $_ = \"$sel_list\"" if ($sel_list ne ""); } $filter .= " AND comment REGEXP '$re'" if ($re ne ""); $stmt = qq(SELECT * FROM $tbl WHERE $filter ORDER BY edate DESC;); @@ -237,7 +234,7 @@ =head1 Query string parameters my @rows; while(my @row = $sth->fetchrow_array()) { - push(@rows, \@row); + push(@rows, \@row); } $dbh->disconnect(); @@ -250,100 +247,100 @@ =head1 Query string parameters my @field_names; foreach(@fieldsets) { - push(@fs_names, $FORM{"$_\_NAME"}); - my @fieldset; - for (my $i = 0; $i <= $FORM{"$_\_CELLS"}; $i++) { - my @fields; - foreach (split(/,/, $FORM{sprintf("$_\_C%02d",$i)})) { - my ($size, $default) = extract_type($FORM{$_."_TYPE"}); - if ($size ne "0" && ! ($_ =~ /^OUTPUT/ && $FORM{$_."_TYPE"} =~ /^text/)) { - push(@fields, $_); - } - } - push(@fieldset, @fields); - } - push(@field_names, \@fieldset); + push(@fs_names, $FORM{"$_\_NAME"}); + my @fieldset; + for (my $i = 0; $i <= $FORM{"$_\_CELLS"}; $i++) { + my @fields; + foreach (split(/,/, $FORM{sprintf("$_\_C%02d",$i)})) { + my ($size, $default) = extract_type($FORM{$_."_TYPE"}); + if ($size ne "0" && ! ($_ =~ /^OUTPUT/ && $FORM{$_."_TYPE"} =~ /^text/)) { + push(@fields, $_); + } + } + push(@fieldset, @fields); + } + push(@field_names, \@fieldset); } # ---- Form for display selection # if ($QryParm->{'dump'} ne "csv") { - print "
    ", - ""; - print "

    ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  "; - print " "; - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); - $form_url->query_form('form' => $form, 'return_url' => $return_url, 'action' => 'new'); - print qq(); - } - print "
    \n"; - print " "; - if ($re ne "") { - print ""; - } - print " \n"; - foreach my $i (sort keys %lists) { - if (isok($FORM{uc($i)."_FILT"})) { - my @key = keys %{$lists{$i}}; - print "".$FORM{uc($i)."_NAME"}.": \n"; - } - } - foreach (@fieldsets) { - if (isok($FORM{$_.'_TOGGLE'})) { - my $fs = lc($_); - print " {$fs} ? " checked":"")."> $FORM{$_.'_NAME'}"; - } - } - - if ($clientAuth > 1) { - print " {'trash'} ? " checked":"")."> $__{'Trash'}"; - } else { - print " "; - } - print "

    \n", - "

    ".$FORM{TITLE}."$editForm

    \n", - "

    "; + print "

    ", + ""; + print "

    ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  "; + print " "; + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); + $form_url->query_form('form' => $form, 'return_url' => $return_url, 'action' => 'new'); + print qq(); + } + print "
    \n"; + print " "; + if ($re ne "") { + print ""; + } + print " \n"; + foreach my $i (sort keys %lists) { + if (isok($FORM{uc($i)."_FILT"})) { + my @key = keys %{$lists{$i}}; + print "".$FORM{uc($i)."_NAME"}.": \n"; + } + } + foreach (@fieldsets) { + if (isok($FORM{$_.'_TOGGLE'})) { + my $fs = lc($_); + print " {$fs} ? " checked":"")."> $FORM{$_.'_NAME'}"; + } + } + + if ($clientAuth > 1) { + print " {'trash'} ? " checked":"")."> $__{'Trash'}"; + } else { + print " "; + } + print "

    \n", + "

    ".$FORM{TITLE}."$editForm

    \n", + "

    "; } # ---- Displaying data @@ -360,151 +357,153 @@ =head1 Query string parameters my @colnam2; my %colspan; if ($starting_date) { - $colspan{"Sampling Date"} = 2; - push(@colnam2,("Start","End")); - $csvTxt .= '"'.join('","', @colnam2, @colnam[1,2]).'"'; + $colspan{"Sampling Date"} = 2; + push(@colnam2,("Start","End")); + $csvTxt .= '"'.join('","', @colnam2, @colnam[1,2]).'"'; } else { - $csvTxt .= '"'.join('","', @colnam).'"'; + $csvTxt .= '"'.join('","', @colnam).'"'; } for (my $i = 0; $i <= $#fs_names; $i++) { - my $fs = $fieldsets[$i]; - my $showfs = ((!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}) ? "1":"0"); - push(@colnam, $fs_names[$i]) if ($showfs); - my $nb_fields = $#{$field_names[$i]}; - $colspan{$fs_names[$i]} = $nb_fields+1; - for (my $j = 0; $j <= $nb_fields; $j++) { - my $field = $field_names[$i][$j]; - my $name_field = htm2frac($FORM{"$field\_NAME"}); - my $unit_field = $FORM{"$field\_UNIT"}; - push(@colnam2, "$name_field".($unit_field ne "" ? " ($unit_field)":"")) if ($showfs); - $name_field =~ s/(|<\/su[bp]>|\&[^;]*;)//g; - $csvTxt .= ',"'.u2l($name_field).'"'; - } + my $fs = $fieldsets[$i]; + my $showfs = ((!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}) ? "1":"0"); + push(@colnam, $fs_names[$i]) if ($showfs); + my $nb_fields = $#{$field_names[$i]}; + $colspan{$fs_names[$i]} = $nb_fields+1; + for (my $j = 0; $j <= $nb_fields; $j++) { + my $field = $field_names[$i][$j]; + my $name_field = htm2frac($FORM{"$field\_NAME"}); + my $unit_field = $FORM{"$field\_UNIT"}; + push(@colnam2, "$name_field".($unit_field ne "" ? " ($unit_field)":"")) if ($showfs); + $name_field =~ s/(|<\/su[bp]>|\&[^;]*;)//g; + $csvTxt .= ',"'.u2l($name_field).'"'; + } } $csvTxt .= "\n"; $header = "".($clientAuth > 1 ? "\n":""); -foreach(@colnam) { - $header .= "$_\n"; +foreach(@colnam) { + $header .= "$_\n"; } $header .= "\n"; foreach(@colnam2) { - $header .= "".$_."\n"; + $header .= "".$_."\n"; } $header .= "\n"; for (my $j = 0; $j <= $#rows; $j++) { - my ($id, $trash, $site, $edate0, $edate1, $sdate0, $sdate1, $opers, $rem, $ts0, $user) = ($rows[$j][0],$rows[$j][1],$rows[$j][2],$rows[$j][3],$rows[$j][4],$rows[$j][5],$rows[$j][6],$rows[$j][7],$rows[$j][-3],$rows[$j][-2],$rows[$j][-1]); - - # makes a hash of all fields values (input and output) - my %fields; - # stores input db rows - for (my $i = 8; $i <= $#{$rows[$j]}; $i++) { - $fields{$rownames[$i]} = $rows[$j][$i]; - } - # stores formulas - foreach (@formulas) { - my ($formula, $size, @x) = extract_formula($FORM{$_."_TYPE"}); - my $nan = 0; - foreach (@x) { - my $f = lc($_); - $formula =~ s/$_/\$fields{$f}/g; - } - my $res = eval($formula); - if ($res ne "") { - if ($size > 0) { - $fields{lc($_)} = roundsd($res, $size - 3); # results is rounded with $size-3 digits - } else { - $fields{lc($_)} = $res; # hidden formula - } - } else { - $fields{lc($_)} = ""; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $edate = simplify_date($edate0,$edate1); - my $sdate = simplify_date($sdate0,$sdate1); - - my $nameSite = htmlspecialchars(getNodeString(node=>$site,style=>'html')); - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $nodelink = "$aliasSite"; - } else { - $nodelink = "$aliasSite"; - } - my @operators = split(/,/,$opers); - my @nameOper; - foreach (@operators) { - push(@nameOper, "$_: ".join('',WebObs::Users::userName($_))); - } - my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); - $form_url->query_form('form' => $form, 'id' => $id, 'return_url' => $return_url, 'action' => 'edit'); - $edit = qq(); - $delete = qq(); - - $text .= ""; - if ($clientAuth > 1) { - $text .= "$edit"; - } - $text .= ($starting_date ? "$sdate":"")."$edate"; - $text .= "$nodelink \n"; - $text .= "',@nameOper)."')\">".join(', ',@operators)."\n"; - $csvTxt .= "$id,$sdate,$edate,\"$aliasSite\",\"$opers\","; - for (my $f = 0; $f <= $#fieldsets; $f++) { - my $fs = $fieldsets[$f]; - my $nb_fields = $#{$field_names[$f]}; - for (my $n = 0; $n <= $nb_fields; $n++) { - my $Field = $field_names[$f][$n]; - my $field = lc($Field); - my $opt; - my $val = $fields{$field}; - my $hlp; - if (defined $lists{$field}) { - if (ref $lists{$field}{$fields{$field}}) { - my %v = %{$lists{$field}{$fields{$field}}}; # list is a HoH - $hlp = "$fields{$field}: $v{name}"; - if ($v{icon}) { - $val = ""; - } - } else { - $hlp = "$fields{$field}: $lists{$field}{$fields{$field}}"; - } - $hlp = "$__{'unknown key list!'}" if ($val eq ""); - $opt = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$hlp')\""; - } - if (grep(/^$field$/i, @formulas)) { - $opt = " class=\"tdResult\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$field:')\""; - } - if (grep(/^$Field$/, @thresh) ) { - my @tv = split(/[, ]/,$FORM{$Field."_THRESHOLD"}); - if (abs($fields{$field}) >= $tv[0] && abs($fields{$field}) < $tv[1]) { - $opt .= " style=\"background-color:$validity[1]\""; - } elsif (abs($fields{$field}) >= $tv[1]) { - $opt .= " style=\"background-color:$validity[2]\""; - } - } - $text .= "$val\n" if (!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}); - $csvTxt .= "$fields{$field},"; - } - } - $csvTxt .= ",\"".u2l($rem)."\"\n"; - my $remTxt = ""; - if ($rem ne "") { - $remTxt = ""; - } - $text .= "$remTxt\n"; + my ($id, $trash, $site, $edate0, $edate1, $sdate0, $sdate1, $opers, $rem, $ts0, $user) = ($rows[$j][0],$rows[$j][1],$rows[$j][2],$rows[$j][3],$rows[$j][4],$rows[$j][5],$rows[$j][6],$rows[$j][7],$rows[$j][-3],$rows[$j][-2],$rows[$j][-1]); + + # makes a hash of all fields values (input and output) + my %fields; + + # stores input db rows + for (my $i = 8; $i <= $#{$rows[$j]}; $i++) { + $fields{$rownames[$i]} = $rows[$j][$i]; + } + + # stores formulas + foreach (@formulas) { + my ($formula, $size, @x) = extract_formula($FORM{$_."_TYPE"}); + my $nan = 0; + foreach (@x) { + my $f = lc($_); + $formula =~ s/$_/\$fields{$f}/g; + } + my $res = eval($formula); + if ($res ne "") { + if ($size > 0) { + $fields{lc($_)} = roundsd($res, $size - 3); # results is rounded with $size-3 digits + } else { + $fields{lc($_)} = $res; # hidden formula + } + } else { + $fields{lc($_)} = ""; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $edate = simplify_date($edate0,$edate1); + my $sdate = simplify_date($sdate0,$sdate1); + + my $nameSite = htmlspecialchars(getNodeString(node=>$site,style=>'html')); + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $nodelink = "$aliasSite"; + } else { + $nodelink = "$aliasSite"; + } + my @operators = split(/,/,$opers); + my @nameOper; + foreach (@operators) { + push(@nameOper, "$_: ".join('',WebObs::Users::userName($_))); + } + my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); + $form_url->query_form('form' => $form, 'id' => $id, 'return_url' => $return_url, 'action' => 'edit'); + $edit = qq(); + $delete = qq(); + + $text .= ""; + if ($clientAuth > 1) { + $text .= "$edit"; + } + $text .= ($starting_date ? "$sdate":"")."$edate"; + $text .= "$nodelink \n"; + $text .= "',@nameOper)."')\">".join(', ',@operators)."\n"; + $csvTxt .= "$id,$sdate,$edate,\"$aliasSite\",\"$opers\","; + for (my $f = 0; $f <= $#fieldsets; $f++) { + my $fs = $fieldsets[$f]; + my $nb_fields = $#{$field_names[$f]}; + for (my $n = 0; $n <= $nb_fields; $n++) { + my $Field = $field_names[$f][$n]; + my $field = lc($Field); + my $opt; + my $val = $fields{$field}; + my $hlp; + if (defined $lists{$field}) { + if (ref $lists{$field}{$fields{$field}}) { + my %v = %{$lists{$field}{$fields{$field}}}; # list is a HoH + $hlp = "$fields{$field}: $v{name}"; + if ($v{icon}) { + $val = ""; + } + } else { + $hlp = "$fields{$field}: $lists{$field}{$fields{$field}}"; + } + $hlp = "$__{'unknown key list!'}" if ($val eq ""); + $opt = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$hlp')\""; + } + if (grep(/^$field$/i, @formulas)) { + $opt = " class=\"tdResult\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$field:')\""; + } + if (grep(/^$Field$/, @thresh) ) { + my @tv = split(/[, ]/,$FORM{$Field."_THRESHOLD"}); + if (abs($fields{$field}) >= $tv[0] && abs($fields{$field}) < $tv[1]) { + $opt .= " style=\"background-color:$validity[1]\""; + } elsif (abs($fields{$field}) >= $tv[1]) { + $opt .= " style=\"background-color:$validity[2]\""; + } + } + $text .= "$val\n" if (!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}); + $csvTxt .= "$fields{$field},"; + } + } + $csvTxt .= ",\"".u2l($rem)."\"\n"; + my $remTxt = ""; + if ($rem ne "") { + $remTxt = ""; + } + $text .= "$remTxt\n"; } if ($QryParm->{'debug'}) { - print("

    y1 = ".$QryParm->{'y1'}.", m1 = ".$QryParm->{'m1'}.", d1 = ".$QryParm->{'d1'}."

    \n"); - print("

    startDate = $startDate, endDate = $endDate, default days = $FORM{DEFAULT_DAYS}

    \n"); - print("

    Columns = ".join(',',@rownames)."

    \n"); - print("

    Formulas = ".join(',',@formulas)."

    \n"); - print("

    Filter = $filter

    \n"); + print("

    y1 = ".$QryParm->{'y1'}.", m1 = ".$QryParm->{'m1'}.", d1 = ".$QryParm->{'d1'}."

    \n"); + print("

    startDate = $startDate, endDate = $endDate, default days = $FORM{DEFAULT_DAYS}

    \n"); + print("

    Columns = ".join(',',@rownames)."

    \n"); + print("

    Formulas = ".join(',',@formulas)."

    \n"); + print("

    Filter = $filter

    \n"); } push(@html,"

    $__{'Genform code'}: FORM.$form
    \n"); push(@html,"$__{'Date interval'} = $delay days.
    \n"); @@ -512,44 +511,42 @@ =head1 Query string parameters push(@html,"

    $__{'Download a CSV text file of these data'}: {'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&trash=$QryParm->{'trash'}&form=$form\">$fileCSV

    \n"); if ($text ne "") { - push(@html,"$header\n$text\n$header\n
    \n"); + push(@html,"$header\n$text\n$header\n
    \n"); } if ($QryParm->{'dump'} eq "csv") { - push(@csv,l2u($csvTxt)); - print @csv; + push(@csv,l2u($csvTxt)); + print @csv; } else { - print @html; - print "\n
    \n\n\n"; } - - sub simplify_date { - my $date0 = shift; - my $date1 = shift; - my ($y0,$m0,$d0,$H0,$M0) = split(/[-: ]/,$date0); - my ($y1,$m1,$d1,$H1,$M1) = split(/[-: ]/,$date1); - my $date = "$y1-$m1-$d1 $H1:$M1"; - if ($date0 eq $date1 || $date1 eq "") { return $date0; } - if ($y1 ne $y0) { $date = "$y0-$y1"; } - elsif ($m1 ne $m0) { $date = "$y1"; } - elsif ($d1 ne $d0) { $date = "$y1-$m1"; } - elsif ($H1 ne $H0) { $date = "$y1-$m1-$d1"; } - elsif ($M1 ne $M0) { $date = "$y1-$m1-$d1 $H1"; } - return $date; + my $date0 = shift; + my $date1 = shift; + my ($y0,$m0,$d0,$H0,$M0) = split(/[-: ]/,$date0); + my ($y1,$m1,$d1,$H1,$M1) = split(/[-: ]/,$date1); + my $date = "$y1-$m1-$d1 $H1:$M1"; + if ($date0 eq $date1 || $date1 eq "") { return $date0; } + if ($y1 ne $y0) { $date = "$y0-$y1"; } + elsif ($m1 ne $m0) { $date = "$y1"; } + elsif ($d1 ne $d0) { $date = "$y1-$m1"; } + elsif ($H1 ne $H0) { $date = "$y1-$m1-$d1"; } + elsif ($M1 ne $M0) { $date = "$y1-$m1-$d1 $H1"; } + return $date; } # Open an SQLite connection to the forms database sub connectDbForms { - return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; + return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; } __END__ diff --git a/CODE/cgi-bin/showGRID.pl b/CODE/cgi-bin/showGRID.pl index 268f83b6..5ace91f1 100755 --- a/CODE/cgi-bin/showGRID.pl +++ b/CODE/cgi-bin/showGRID.pl @@ -76,7 +76,6 @@ =head1 Query string parameters use WebObs::Mapping; use Locale::TextDomain('webobs'); - # ---- init general-use variables on the way and quit if something's wrong # my $cgi = new CGI; @@ -90,37 +89,37 @@ =head1 Query string parameters my $theiaAuth = isok($WEBOBS{THEIA_USER_FLAG}); my @GID = split(/[\.\/]/, trim(checkParam($cgi->param('grid'), - qr{^(VIEW|PROC)(\.|/)|[a-zA-Z0-9]+$}, "grid") // '')); + qr{^(VIEW|PROC)(\.|/)|[a-zA-Z0-9]+$}, "grid") // '')); my $usrNodes = checkParam($cgi->param('nodes'), qr/^[a-zA-Z]*$/, 'nodes') - // $GRIDS{DEFAULT_NODES_FILTER}; + // $GRIDS{DEFAULT_NODES_FILTER}; my $usrCoord = checkParam($cgi->param('coord'), qr/^[a-zA-Z]*$/, 'coord') - // $GRIDS{DEFAULT_COORDINATES}; + // $GRIDS{DEFAULT_COORDINATES}; my $usrProject = checkParam($cgi->param('project'), qr/^(on|off)?$/, 'project') - // $GRIDS{DEFAULT_PROJECT_FILTER}; + // $GRIDS{DEFAULT_PROJECT_FILTER}; my $usrProcparam = checkParam($cgi->param('procparam'), - qr/^(on|off)?$/, 'procparam') - // $GRIDS{DEFAULT_PROCPARAM_FILTER}; + qr/^(on|off)?$/, 'procparam') + // $GRIDS{DEFAULT_PROCPARAM_FILTER}; my $usrSortby = checkParam($cgi->param('sortby'), qr/^[a-z]*$/, 'sortby') - // "event"; + // "event"; my $usrMap = checkParam($cgi->param('map'), qr/^[0-9]*$/, 'map') // ''; my $usrInvalid = checkParam($cgi->param('invalid'), qr/^(on|off)?$/, 'invalid') // "off"; if (scalar(@GID) == 2) { - ($GRIDType, $GRIDName) = @GID; - my %G; - if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } - elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } - if (%G) { - %GRID = %{$G{$GRIDName}} ; - if ( WebObs::Users::clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $editOK = 1; - } - if ( WebObs::Users::clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $admOK = 1; - } - } else { die "You cannot display $GRIDType.$GRIDName"} - } else { die "Couldn't get $GRIDType.$GRIDName configuration." } + ($GRIDType, $GRIDName) = @GID; + my %G; + if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } + elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } + if (%G) { + %GRID = %{$G{$GRIDName}} ; + if ( WebObs::Users::clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $editOK = 1; + } + if ( WebObs::Users::clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $admOK = 1; + } + } else { die "You cannot display $GRIDType.$GRIDName"} + } else { die "Couldn't get $GRIDType.$GRIDName configuration." } } else { die "No valid GRID requested (NOT gridtype.gridname)." } # ---- good, passed all checkings above @@ -131,13 +130,13 @@ =head1 Query string parameters my $procOUTG; my %authUsers; if ($isProc) { - %authUsers = WebObs::Users::resListAuth(type=>'authprocs',name=>$GRIDName); - $procOUTG = '1' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}" ); - $procOUTG = 'events' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_EVENTS}" ); - @procTS = split(/,/,$GRID{TIMESCALELIST}); + %authUsers = WebObs::Users::resListAuth(type=>'authprocs',name=>$GRIDName); + $procOUTG = '1' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}" ); + $procOUTG = 'events' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_EVENTS}" ); + @procTS = split(/,/,$GRID{TIMESCALELIST}); } else { - %authUsers = WebObs::Users::resListAuth(type=>'authviews',name=>$GRIDName); - $usrProcparam = ''; + %authUsers = WebObs::Users::resListAuth(type=>'authviews',name=>$GRIDName); + $usrProcparam = ''; } my @domain = split(/\|/,$GRID{DOMAIN}); @@ -152,13 +151,13 @@ =head1 Query string parameters my $localCS = $UTM{GEODETIC_DATUM_LOCAL_NAME}; my $showType = (defined($GRIDS{SHOW_TYPE}) - && ($GRIDS{SHOW_TYPE} eq 'N') - || (defined($GRID{TYPE}) && $GRID{TYPE} eq "")) - ? 0 : 1; + && ($GRIDS{SHOW_TYPE} eq 'N') + || (defined($GRID{TYPE}) && $GRID{TYPE} eq "")) + ? 0 : 1; my $showOwnr = (defined($GRIDS{SHOW_OWNER}) - && ($GRIDS{SHOW_OWNER} eq 'N') - || (defined($GRID{OWNCODE}) && $GRID{OWNCODE} eq "")) - ? 0 : 1; + && ($GRIDS{SHOW_OWNER} eq 'N') + || (defined($GRID{OWNCODE}) && $GRID{OWNCODE} eq "")) + ? 0 : 1; my $today = strftime("%Y-%m-%d", localtime); @@ -171,19 +170,19 @@ =head1 Query string parameters my $statusDB = $NODES{SQL_DB_STATUS} || "$WEBOBS{PATH_DATA_DB}/NODESSTATUS.db"; my $statusNODES; if (-e $statusDB) { - my $dbh = DBI->connect("dbi:SQLite:$statusDB", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $statusDB: $DBI::errstr"; - $statusNODES = $dbh->selectall_arrayref( - "select * from status where NODE like ? order by UPDATED asc", - undef, "%$grid%"); - if (@$statusNODES == 0) { - $overallStatus = 0; - } + my $dbh = DBI->connect("dbi:SQLite:$statusDB", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $statusDB: $DBI::errstr"; + $statusNODES = $dbh->selectall_arrayref( + "select * from status where NODE like ? order by UPDATED asc", + undef, "%$grid%"); + if (@$statusNODES == 0) { + $overallStatus = 0; + } } else { - $overallStatus = 0; + $overallStatus = 0; } # ---- Start HTML page @@ -218,11 +217,11 @@ =head1 Query string parameters $ilinks .= " | "; $ilinks .= " | + .($WEBOBS{OSM_WIDTH_VALUE}+15).",height=" + .($WEBOBS{OSM_HEIGHT_VALUE}+15).",toolbar=no,menubar=no,location=no')\"> "; if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - $ilinks .= " | \"KML\"\n"; } @@ -245,142 +244,152 @@ =head1 Query string parameters my $fileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDType.$GRIDName"."$GRIDS{DESCRIPTION_SUFFIX}"; my $legacyfileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDName"."$GRIDS{DESCRIPTION_SUFFIX}"; if (-e $legacyfileDesc) { - copy($legacyfileDesc, $fileDesc); + copy($legacyfileDesc, $fileDesc); } if (-e $fileDesc) { - @desc = readFile($fileDesc); + @desc = readFile($fileDesc); } $htmlcontents = "
       "; - $htmlcontents .= "$__{'Purpose'}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= "

    "; - if ($#desc >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@desc))."

    \n" } - $htmlcontents .= "
    "; +$htmlcontents .= "$__{'Purpose'}"; +if ($editOK == 1) { $htmlcontents .= "  " } +$htmlcontents .= "

    "; +if ($#desc >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@desc))."

    \n" } +$htmlcontents .= "
    "; print $htmlcontents; - # ---- GRID's characteristics # print "
    "; $htmlcontents = ""; $htmlcontents .= "
       "; - $htmlcontents .= "$__{'Specifications'} $go2top"; - $htmlcontents .= "
    "; - # should 'nodes' be called differently (than 'nodes'!) ? - my $snm = defined($GRID{NODE_NAME}) ? $GRID{NODE_NAME} : "$__{'node'}"; - $htmlcontents .= "\n"; + +# ----------- +# only for PROCs: link to output pages and time scale parameters +if ($isProc) { + if (grep(/^FID_/,keys(%GRID))) { + $htmlcontents .= "\n"; + } + if ($procOUTG) { + my $urn = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName"; + $htmlcontents .= "\n"; + } + $htmlcontents .= "\n"; +} +$htmlcontents .= "
      "; - # ----------- - foreach (@domain) { - $htmlcontents .= "
    • $__{'Domain'}: $DOMAINS{$_}{NAME}
      • \n"; - } - # ----------- - $htmlcontents .= "
    • $__{'Description'}: $GRID{DESCRIPTION}
      • \n" if ($GRID{DESCRIPTION}); - # ----------- - $htmlcontents .= "
    • $__{'Grid code'}: $grid
      • \n"; +$htmlcontents .= "$__{'Specifications'} $go2top"; +$htmlcontents .= "
      "; + +# should 'nodes' be called differently (than 'nodes'!) ? +my $snm = defined($GRID{NODE_NAME}) ? $GRID{NODE_NAME} : "$__{'node'}"; +$htmlcontents .= "\n"; - # ----------- - # only for PROCs: link to output pages and time scale parameters - if ($isProc) { - if (grep(/^FID_/,keys(%GRID))) { - $htmlcontents .= "\n"; - } - if ($procOUTG) { - my $urn = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName"; - $htmlcontents .= "\n"; - } - $htmlcontents .= "\n"; - } - $htmlcontents .= "
        "; + +# ----------- +foreach (@domain) { + $htmlcontents .= "
      • $__{'Domain'}: $DOMAINS{$_}{NAME}
        • \n"; +} + +# ----------- +$htmlcontents .= "
      • $__{'Description'}: $GRID{DESCRIPTION}
        • \n" if ($GRID{DESCRIPTION}); + +# ----------- +$htmlcontents .= "
      • $__{'Grid code'}: $grid
        • \n"; + +# ----------- +if ($showOwnr && defined($GRID{OWNCODE})) { + $htmlcontents .= "
      • $__{'Owner'}: ".(defined($OWNRS{$GRID{OWNCODE}}) ? $OWNRS{$GRID{OWNCODE}}:$GRID{OWNCODE})."
        • \n" +} +if ($showType && $GRID{TYPE} ne "") { + $htmlcontents .= "
      • $__{'Type'}: $GRID{TYPE}
        • \n"; +} + +# ----------- +# only for PROCs +if ($isProc) { + + # 'old' ddb-key superseeded: use FORM (FORMS) definitions instead! + if (defined($GRID{'FORM'})) { + my %FORM = readCfg("$WEBOBS{'PATH_FORMS'}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); + if (%FORM) { + my $urnData = "/cgi-bin/".($FORM{'CGI_SHOW'} !~ /GENFORM/ ? "$FORM{'CGI_SHOW'}?form=$GRID{'FORM'}&node={$GRIDName}" : "showGENFORM.pl?form=$GRID{'FORM'}&node=PROC.$GRIDName"); + my $txtData = (defined($FORM{'TITLE'})) ? $FORM{'TITLE'} : ""; + $htmlcontents .= "
      • $__{'Access to data'}: $txtData
        • \n"; + } + } else { + + # ----------- + $htmlcontents .= "
      • $__{'Default data format'}: " + .($GRID{RAWFORMAT} // '')."
        • \n"; + $htmlcontents .= "
      • $__{'Default data source'}: " + .($GRID{RAWDATA} // '')."
        • \n"; + if (defined($GRID{URNDATA})) { + my $urnData = "$GRID{URNDATA}"; + $htmlcontents .= "
      • $__{'Access to rawdata'}: $urnData
        • \n"; + } + } + # ----------- - if ($showOwnr && defined($GRID{OWNCODE})) { - $htmlcontents .= "
      • $__{'Owner'}: ".(defined($OWNRS{$GRID{OWNCODE}}) ? $OWNRS{$GRID{OWNCODE}}:$GRID{OWNCODE})."
        • \n" - } - if ($showType && $GRID{TYPE} ne "") { - $htmlcontents .= "
      • $__{'Type'}: $GRID{TYPE}
        • \n"; - } - # ----------- - # only for PROCs - if ($isProc) { - # 'old' ddb-key superseeded: use FORM (FORMS) definitions instead! - if (defined($GRID{'FORM'})) { - my %FORM = readCfg("$WEBOBS{'PATH_FORMS'}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); - if (%FORM) { - my $urnData = "/cgi-bin/".($FORM{'CGI_SHOW'} !~ /GENFORM/ ? "$FORM{'CGI_SHOW'}?form=$GRID{'FORM'}&node={$GRIDName}" : "showGENFORM.pl?form=$GRID{'FORM'}&node=PROC.$GRIDName"); - my $txtData = (defined($FORM{'TITLE'})) ? $FORM{'TITLE'} : ""; - $htmlcontents .= "
      • $__{'Access to data'}: $txtData
        • \n"; - } - } else { - # ----------- - $htmlcontents .= "
      • $__{'Default data format'}: " - .($GRID{RAWFORMAT} // '')."
        • \n"; - $htmlcontents .= "
      • $__{'Default data source'}: " - .($GRID{RAWDATA} // '')."
        • \n"; - if (defined($GRID{URNDATA})) { - my $urnData = "$GRID{URNDATA}"; - $htmlcontents .= "
      • $__{'Access to rawdata'}: $urnData
        • \n"; - } - } - # ----------- - if (defined($GRID{EVENTS_FILE})) { - $htmlcontents .= "
      • $__{'Events File(s)'}:"; - foreach (split(/,/,$GRID{EVENTS_FILE})) { - my $evtFile = basename("$_"); - my $dir = dirname("$_"); - my $loc = ""; - $loc = "DATA" if ($dir =~ /^$WEBOBS{ROOT_DATA}/); - $loc = "CONF" if ($dir =~ /^$WEBOBS{ROOT_CONF}/); - # will be editable only if located in DATA/ or CONF/ (xedit policy) - if ($loc ne "" && $editOK == 1) { - $htmlcontents .= " $loc/$evtFile"; - } else { - $htmlcontents .= " $evtFile"; - } - } - $htmlcontents .= "
        • \n"; - } - } - # ----------- - if (defined($GRID{URL})) { - my @links = split(/;/,$GRID{URL}); - foreach (@links) { - my @txt = split(/,/,$_); - push(@txt,$txt[0]) if (index($_, ",") == -1); - $htmlcontents .= "
      • $__{'External link'}: $txt[0]<\/A>
        • \n"; - } - } - $htmlcontents .= "
      		\n"; - foreach (grep(/^FID_/,sort(keys(%GRID)))) { - $htmlcontents .= "\n"; - } - $htmlcontents .= "
      $__{'Nodes Default FIDs'}
      $_$GRID{$_}
      		\n"; - if ($procOUTG eq "events") { - $htmlcontents .= "\n"; - } else { - foreach my $g ("",split(/,/,$GRID{SUMMARYLIST})) { - my $outg = join('',map {$_ = ""} split(/,/,$GRID{TIMESCALELIST})); - $htmlcontents .= "$outg\n"; - } - } - if ($theiaAuth) { - $htmlcontents .= ""; - } - $htmlcontents .= "
      $__{'Proc Graphs'}".join("",@procTS)."
      Events
      ".($g eq ""?"Overview":"$g")."
      $__{'Send to Theia'}\n"; - $htmlcontents .= join('', map { checkingTS($_,$GRID{THEIA_SELECTED_TS}) } @procTS); - $htmlcontents .= "
      		\n"; - foreach ("Decimate","Cumulate","DateStr","MarkerSize","LineWidth","Status") { - my @tsp = split(/,/,$GRID{uc($_)."LIST"}); - my $cells; - if ($#tsp < 0) { - $cells = "$cells\n"; - } - $htmlcontents .= "
      $__{'Proc Param.'}".join("",@procTS)."
      $__{'undefined'}"; - } else { - push(@tsp, ' ' x ($#procTS-$#tsp)) if ($#tsp < $#procTS); - $cells = "".join("",@tsp).""; - } - $htmlcontents .= "
      $_
      \n"; - $htmlcontents .= "
      "; -print $htmlcontents; + if (defined($GRID{EVENTS_FILE})) { + $htmlcontents .= "
    • $__{'Events File(s)'}:"; + foreach (split(/,/,$GRID{EVENTS_FILE})) { + my $evtFile = basename("$_"); + my $dir = dirname("$_"); + my $loc = ""; + $loc = "DATA" if ($dir =~ /^$WEBOBS{ROOT_DATA}/); + $loc = "CONF" if ($dir =~ /^$WEBOBS{ROOT_CONF}/); + + # will be editable only if located in DATA/ or CONF/ (xedit policy) + if ($loc ne "" && $editOK == 1) { + $htmlcontents .= " $loc/$evtFile"; + } else { + $htmlcontents .= " $evtFile"; + } + } + $htmlcontents .= "
      • \n"; + } +} +# ----------- +if (defined($GRID{URL})) { + my @links = split(/;/,$GRID{URL}); + foreach (@links) { + my @txt = split(/,/,$_); + push(@txt,$txt[0]) if (index($_, ",") == -1); + $htmlcontents .= "
    • $__{'External link'}: $txt[0]<\/A>
      • \n"; + } +} +$htmlcontents .= "
    		\n"; + foreach (grep(/^FID_/,sort(keys(%GRID)))) { + $htmlcontents .= "\n"; + } + $htmlcontents .= "
    $__{'Nodes Default FIDs'}
    $_$GRID{$_}
    		\n"; + if ($procOUTG eq "events") { + $htmlcontents .= "\n"; + } else { + foreach my $g ("",split(/,/,$GRID{SUMMARYLIST})) { + my $outg = join('',map {$_ = ""} split(/,/,$GRID{TIMESCALELIST})); + $htmlcontents .= "$outg\n"; + } + } + if ($theiaAuth) { + $htmlcontents .= ""; + } + $htmlcontents .= "
    $__{'Proc Graphs'}".join("",@procTS)."
    Events
    ".($g eq ""?"Overview":"$g")."
    $__{'Send to Theia'}\n"; + $htmlcontents .= join('', map { checkingTS($_,$GRID{THEIA_SELECTED_TS}) } @procTS); + $htmlcontents .= "
    		\n"; + foreach ("Decimate","Cumulate","DateStr","MarkerSize","LineWidth","Status") { + my @tsp = split(/,/,$GRID{uc($_)."LIST"}); + my $cells; + if ($#tsp < 0) { + $cells = "$cells\n"; + } + $htmlcontents .= "
    $__{'Proc Param.'}".join("",@procTS)."
    $__{'undefined'}"; + } else { + push(@tsp, ' ' x ($#procTS-$#tsp)) if ($#tsp < $#procTS); + $cells = "".join("",@tsp).""; + } + $htmlcontents .= "
    $_
    \n"; +$htmlcontents .= "
    "; +print $htmlcontents; # ---- Now the GRID's NODE(s) # ---- first, submenu line for selections (list Active nodes, All,..., Coordinates type, etc....) @@ -388,291 +397,296 @@ =head1 Query string parameters print "
    "; $htmlcontents = ""; $htmlcontents .= "
       "; - $htmlcontents .= "$nbNodes $snm(s) $go2top"; - $htmlcontents .= "
    "; - - $htmlcontents .= "

    "; - - my $procParm = ''; - if ($isProc) { - $procParm = "&procparam=$usrProcparam"; - } - - # -- Nodes list submenu Nodes - $htmlcontents .= "$__{'Nodes'} [ "; - $htmlcontents .= ($usrNodes eq "active" ? "$__{'Active'}":"$__{'Active'}"); - $htmlcontents .= " | "; - $htmlcontents .= ($usrNodes eq "inactive" ? "$__{'Inactive'}":"$__{'Inactive'}"); - $htmlcontents .= " | "; - $htmlcontents .= ($usrNodes eq "all" ? "$__{'All'}":"$__{'All'}"); - if ( $admOK ) { - $htmlcontents .= " | ".($usrInvalid eq "on" ? "$__{'Hide invalid'}" - :"$__{'Show invalid'}"); - } - $htmlcontents .= " ] "; - - # -- Nodes list submenu Coordinates - $htmlcontents .= "- $__{Coordinates} [ " - .($usrCoord eq "latlon" ? "Lat/Lon":"Lat/Lon")." | " - .($usrCoord eq "utm" ? "UTM":"UTM"); - if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { - $htmlcontents .= " | ".($usrCoord eq "local" ? "$localCS":"$localCS"); - } - $htmlcontents .= " | " - .($usrCoord eq "xyz" ? "XYZ":"XYZ"); - $htmlcontents .= " ] - $__{Export} ["; - $htmlcontents .= " TXT |"; - $htmlcontents .= " CSV"; - if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - $htmlcontents .= " | KML"; - } - $htmlcontents .= " ] "; - - # -- Nodes list submenu Proc paramaters - if ($isProc) { - $htmlcontents .= "- $__{'Proc parameters'} [ " - .($usrProcparam eq "on" ? "On" :"On")." | " - .($usrProcparam ne "on" ? "Off":"Off")." ] "; - } - - # -- Nodes list submenu Project - if ( $CLIENT ne 'guest' ) { - $htmlcontents .= "- $__{Project} [ " - .($usrProject eq "on" ? "On" :"On")." | " - .($usrProject eq "off" ? "Off":"Off")." ] "; - } - $htmlcontents .= "

    \n"; - - # ---- then, the Nodes' table - # - my $nbValides = 0; - my $nbNonValides = 0; - my $tcolor; - my %NODE; - my $newNODE = ""; - - #$htmlcontents .= ""; - $htmlcontents .= "
    "; - $htmlcontents .= ""; - $htmlcontents .= ($editOK ? "":"") - ."" - ."" - ."" - .""; - if ($CLIENT ne 'guest') { - $htmlcontents .= ""; - $htmlcontents .= "" if ($usrProject eq "on"); - } - $htmlcontents .= "" if ($usrProcparam eq 'on'); - $htmlcontents .= "" if ($procOUTG); - if ($overallStatus) { - my @tsp = split(/,/,$GRID{"STATUSLIST"}); - $htmlcontents .= ""; - } - $htmlcontents .= "\n"; - if ($usrCoord eq "utm") { - $htmlcontents .= ""; - } elsif ($usrCoord eq "local") { - $htmlcontents .= ""; - } elsif ($usrCoord eq "xyz") { - $htmlcontents .= ""; - } else { - $htmlcontents .= ""; - } - $htmlcontents .= ""; - $htmlcontents .= "" if ($usrProcparam eq 'on'); - if ($procOUTG eq "events") { - $htmlcontents .= ""; - } elsif ($procOUTG) { - $htmlcontents .= ""; - } - if ($overallStatus) { - $htmlcontents .= ""; - } - $htmlcontents .= "\n"; - - for (@{$GRID{NODESLIST}}) { - my $displayNode = 1; - my $NODEName = $_; - my $NODENameLower = lc($NODEName); - - my %N = readNode($NODEName); - %NODE = %{$N{$NODEName}}; - - if (%NODE) { - - # is VALID ? do we display INVALID ? - if (!isok($NODE{VALID})) { - $tcolor="node-disabled"; - if ($usrInvalid ne "on") { - $nbNonValides++; - $displayNode = 0; - } - } else { - $tcolor="node-active"; - $nbValides++; - } - - # is NOT active if already 'ended' OR not yet 'installed' ? do we display ? - if (isok($NODE{VALID}) && ($NODE{END_DATE} ne "NA" && $NODE{END_DATE} lt $today) || ($NODE{INSTALL_DATE} ne "NA" && $NODE{INSTALL_DATE} gt $today)) { - $tcolor="node-inactive"; - if ($usrNodes eq "active") { - $displayNode = 0; - } - } else { - if ($usrNodes eq "inactive") { - $displayNode = 0; - } - } - - # trick: execute display logic even if we don't display, but html-comment out first - $htmlcontents .= (!$displayNode ? "":""); - } - } - $htmlcontents .= "
    ".($admOK ? $newNODE:"")."$__{'Alias'}$__{'Name'}$__{'Coordinates'}$__{'Lifetime and Validity'}" - ."$__{'Type'}$__{'Nb
    Evnt'}    		$__{'Project'}$__{'Proc Parameters'}$__{'Proc Graphs'}$__{'Proc Status'} (".$procTS[first { $tsp[$_] eq '1' } reverse(0..$#tsp)].")
    UTM Eastern (m)UTM Northern (m)$__{'Elev.'} (m)Local TM Eastern (m)Local TM Northern (m)$__{'Elev.'} (m)X (m)Y (m)Z (m)$__{'Lat.'} (WGS84)$__{'Lon.'} (WGS84)$__{'Elev.'} (m)$__{'Start / Installation'}$__{'End / Stop'}$__{'FID'}$__{'Raw Format'}$__{'Chan.'}Events".join("",@procTS)."$__{'Last Data'} (TZ $GRID{TZ})$__{'Sampl.'}$__{'Status'}
    "; - $htmlcontents .= "
    "; -print $htmlcontents; +$htmlcontents .= "$nbNodes $snm(s) $go2top"; +$htmlcontents .= "
    "; + +$htmlcontents .= "

    "; +my $procParm = ''; +if ($isProc) { + $procParm = "&procparam=$usrProcparam"; +} + +# -- Nodes list submenu Nodes +$htmlcontents .= "$__{'Nodes'} [ "; +$htmlcontents .= ($usrNodes eq "active" ? "$__{'Active'}":"$__{'Active'}"); +$htmlcontents .= " | "; +$htmlcontents .= ($usrNodes eq "inactive" ? "$__{'Inactive'}":"$__{'Inactive'}"); +$htmlcontents .= " | "; +$htmlcontents .= ($usrNodes eq "all" ? "$__{'All'}":"$__{'All'}"); +if ( $admOK ) { + $htmlcontents .= " | ".($usrInvalid eq "on" ? "$__{'Hide invalid'}" + :"$__{'Show invalid'}"); +} +$htmlcontents .= " ] "; + +# -- Nodes list submenu Coordinates +$htmlcontents .= "- $__{Coordinates} [ " + .($usrCoord eq "latlon" ? "Lat/Lon":"Lat/Lon")." | " + .($usrCoord eq "utm" ? "UTM":"UTM"); +if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { + $htmlcontents .= " | ".($usrCoord eq "local" ? "$localCS":"$localCS"); +} +$htmlcontents .= " | " + .($usrCoord eq "xyz" ? "XYZ":"XYZ"); +$htmlcontents .= " ] - $__{Export} ["; +$htmlcontents .= " TXT |"; +$htmlcontents .= " CSV"; +if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { + $htmlcontents .= " | KML"; +} +$htmlcontents .= " ] "; + +# -- Nodes list submenu Proc paramaters +if ($isProc) { + $htmlcontents .= "- $__{'Proc parameters'} [ " + .($usrProcparam eq "on" ? "On" :"On")." | " + .($usrProcparam ne "on" ? "Off":"Off")." ] "; +} + +# -- Nodes list submenu Project +if ( $CLIENT ne 'guest' ) { + $htmlcontents .= "- $__{Project} [ " + .($usrProject eq "on" ? "On" :"On")." | " + .($usrProject eq "off" ? "Off":"Off")." ] "; +} +$htmlcontents .= "

    \n"; + +# ---- then, the Nodes' table +# +my $nbValides = 0; +my $nbNonValides = 0; +my $tcolor; +my %NODE; +my $newNODE = ""; + +#$htmlcontents .= ""; +$htmlcontents .= "
    "; +$htmlcontents .= ""; +$htmlcontents .= ($editOK ? "":"") + ."" + ."" + ."" + .""; +if ($CLIENT ne 'guest') { + $htmlcontents .= ""; + $htmlcontents .= "" if ($usrProject eq "on"); +} +$htmlcontents .= "" if ($usrProcparam eq 'on'); +$htmlcontents .= "" if ($procOUTG); +if ($overallStatus) { + my @tsp = split(/,/,$GRID{"STATUSLIST"}); + $htmlcontents .= ""; +} +$htmlcontents .= "\n"; +if ($usrCoord eq "utm") { + $htmlcontents .= ""; +} elsif ($usrCoord eq "local") { + $htmlcontents .= ""; +} elsif ($usrCoord eq "xyz") { + $htmlcontents .= ""; +} else { + $htmlcontents .= ""; +} +$htmlcontents .= ""; +$htmlcontents .= "" if ($usrProcparam eq 'on'); +if ($procOUTG eq "events") { + $htmlcontents .= ""; +} elsif ($procOUTG) { + $htmlcontents .= ""; +} +if ($overallStatus) { + $htmlcontents .= ""; +} +$htmlcontents .= "\n"; + +for (@{$GRID{NODESLIST}}) { + my $displayNode = 1; + my $NODEName = $_; + my $NODENameLower = lc($NODEName); + + my %N = readNode($NODEName); + %NODE = %{$N{$NODEName}}; + + if (%NODE) { + + # is VALID ? do we display INVALID ? + if (!isok($NODE{VALID})) { + $tcolor="node-disabled"; + if ($usrInvalid ne "on") { + $nbNonValides++; + $displayNode = 0; + } + } else { + $tcolor="node-active"; + $nbValides++; + } + + # is NOT active if already 'ended' OR not yet 'installed' ? do we display ? + if (isok($NODE{VALID}) && ($NODE{END_DATE} ne "NA" && $NODE{END_DATE} lt $today) || ($NODE{INSTALL_DATE} ne "NA" && $NODE{INSTALL_DATE} gt $today)) { + $tcolor="node-inactive"; + if ($usrNodes eq "active") { + $displayNode = 0; + } + } else { + if ($usrNodes eq "inactive") { + $displayNode = 0; + } + } + +# trick: execute display logic even if we don't display, but html-comment out first + $htmlcontents .= (!$displayNode ? "":""); + } +} +$htmlcontents .= "
    ".($admOK ? $newNODE:"")."$__{'Alias'}$__{'Name'}$__{'Coordinates'}$__{'Lifetime and Validity'}" + ."$__{'Type'}$__{'Nb
    Evnt'}    		$__{'Project'}$__{'Proc Parameters'}$__{'Proc Graphs'}$__{'Proc Status'} (".$procTS[first { $tsp[$_] eq '1' } reverse(0..$#tsp)].")
    UTM Eastern (m)UTM Northern (m)$__{'Elev.'} (m)Local TM Eastern (m)Local TM Northern (m)$__{'Elev.'} (m)X (m)Y (m)Z (m)$__{'Lat.'} (WGS84)$__{'Lon.'} (WGS84)$__{'Elev.'} (m)$__{'Start / Installation'}$__{'End / Stop'}$__{'FID'}$__{'Raw Format'}$__{'Chan.'}Events".join("",@procTS)."$__{'Last Data'} (TZ $GRID{TZ})$__{'Sampl.'}$__{'Status'}
    "; +$htmlcontents .= "
    "; +print $htmlcontents; # ---- now the grid's MAPs # only 1 map : *.png and its corresponding *.map @@ -681,40 +695,40 @@ =head1 Query string parameters my $mapfile = $grid."_map".$usrMap; if ( -e "$MAPpath/$mapfile.png" ) { - my @maps; - my $i = 0; - my @htmlarea; - ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - if (opendir(my $dh, $MAPpath)) { - @maps = grep { /.*_map\d*.png/ } readdir($dh); - closedir($dh); - } - print "
    "; - print ""; - print "
       "; - print "$__{'Location'} $go2top"; - print "
    "; - print "

    $__{Maps} [ "; - foreach (sort @maps) { - print "| " if ($i++); - my @v = split(/_map|\./,$_); - if ("$mapfile.png" eq $_) { - print "MAP$v[2] "; - } elsif ( $v[2] eq "" || exists $GRID{"MAP$v[2]_XYLIM"} ) { - print "MAP$v[2] "; - } - } - print " ] - Export [ PNG | EPS"; - if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - print " | KML"; - } - print " ]

    \n"; - print "

    \n"; - if (-e "$MAPpath/$grid"."_map.map") { - @htmlarea = readFile("$MAPpath/$mapfile.map"); - print "@htmlarea\n"; - } - print "
    \n"; + my @maps; + my $i = 0; + my @htmlarea; + ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + if (opendir(my $dh, $MAPpath)) { + @maps = grep { /.*_map\d*.png/ } readdir($dh); + closedir($dh); + } + print "
    "; + print ""; + print "
       "; + print "$__{'Location'} $go2top"; + print "
    "; + print "

    $__{Maps} [ "; + foreach (sort @maps) { + print "| " if ($i++); + my @v = split(/_map|\./,$_); + if ("$mapfile.png" eq $_) { + print "MAP$v[2] "; + } elsif ( $v[2] eq "" || exists $GRID{"MAP$v[2]_XYLIM"} ) { + print "MAP$v[2] "; + } + } + print " ] - Export [ PNG | EPS"; + if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { + print " | KML"; + } + print " ]

    \n"; + print "

    \n"; + if (-e "$MAPpath/$grid"."_map.map") { + @htmlarea = readFile("$MAPpath/$mapfile.map"); + print "@htmlarea\n"; + } + print "
    \n"; } # ----- Protocole @@ -723,19 +737,19 @@ =head1 Query string parameters my $legacyfileProtocole = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDName"."$GRIDS{PROTOCOLE_SUFFIX}"; my @protocole = (""); if (-e $legacyfileProtocole) { - copy($legacyfileProtocole, $fileProtocole); + copy($legacyfileProtocole, $fileProtocole); } if (-e $fileProtocole) { - @protocole = readFile($fileProtocole); + @protocole = readFile($fileProtocole); } print "
    "; print "\n"; $htmlcontents = "
       "; - $htmlcontents .= "$__{'Information'}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= " $go2top

    "; - if ($#protocole >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@protocole))."

    \n" } - $htmlcontents .= "
    "; +$htmlcontents .= "$__{'Information'}"; +if ($editOK == 1) { $htmlcontents .= "  " } +$htmlcontents .= " $go2top

    "; +if ($#protocole >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@protocole))."

    \n" } +$htmlcontents .= "
    "; print $htmlcontents; # ---- Project @@ -760,7 +774,7 @@ =head1 Query string parameters if ($editOK) { print "  " } print " $go2top

    "; print " $__{'Sort by'} [ ".($usrSortby ne "event" ? "$__{'Event'}":"$__{'Event'}")." | " - .($usrSortby ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
    \n"; + .($usrSortby ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
    \n"; my $htmlEvents = ($usrSortby =~ /event/i) ? eventsShow("events","$GRIDType.$GRIDName", $editOK) : eventsShow("date","$GRIDType.$GRIDName", $editOK); print $htmlEvents; print "
    "; @@ -771,19 +785,19 @@ =head1 Query string parameters my $legacyfileBib = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDName"."$GRIDS{BIBLIO_SUFFIX}"; my @bib = (""); if (-e $legacyfileBib) { - copy($legacyfileBib, $fileBib); + copy($legacyfileBib, $fileBib); } if (-e $fileBib) { - @bib = readFile($fileBib); + @bib = readFile($fileBib); } print "
    "; print "\n"; $htmlcontents = "
       "; - $htmlcontents .= "$__{'References'}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= " $go2top

    "; - if ($#bib >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@bib))."

    \n" } - $htmlcontents .= "
    "; +$htmlcontents .= "$__{'References'}"; +if ($editOK == 1) { $htmlcontents .= "  " } +$htmlcontents .= " $go2top

    "; +if ($#bib >= 0) { $htmlcontents .= "

    ".WebObs::Wiki::wiki2html(join("",@bib))."

    \n" } +$htmlcontents .= "
    "; print $htmlcontents; # ----- Authorization access ------ @@ -796,19 +810,19 @@ =head1 Query string parameters print "\n\n"; sub checkingTS { - if ( $_[0] eq $_[1] ) { - return ""; - } else { - return ""; - } + if ( $_[0] eq $_[1] ) { + return ""; + } else { + return ""; + } } sub checkingNODELIST { - if ( $_[1] =~ /$_[0]/ ) { - return ""; - } else { - return ""; - } + if ( $_[1] =~ /$_[0]/ ) { + return ""; + } else { + return ""; + } } __END__ diff --git a/CODE/cgi-bin/showNODE.pl b/CODE/cgi-bin/showNODE.pl index eedbba4b..83218628 100755 --- a/CODE/cgi-bin/showNODE.pl +++ b/CODE/cgi-bin/showNODE.pl @@ -37,7 +37,6 @@ =head1 Query string parameters =cut - use strict; use warnings; use Time::Local; @@ -68,6 +67,7 @@ =head1 Query string parameters my $fileProjet=""; my $fileProjetName=""; my $fileMap=""; + #OLD:my @listeFileInterventions; my @listeDocumentsHsV=(""); my $pathVisu=""; @@ -87,29 +87,29 @@ =head1 Query string parameters my $QryParm = $cgi->Vars; my @NID = split(/[\.\/]/, trim($QryParm->{'node'})); if (scalar(@NID) == 3) { - ($GRIDType, $GRIDName, $NODEName) = @NID; - %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); - if ("@{$allNodeGrids{$NODEName}}" =~ /\b$GRIDType\.$GRIDName\b/) { - my %G; - my %S = readNode($NODEName); - %NODE = %{$S{$NODEName}}; - if (%NODE) { - if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } - elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } - if (%G) { - %GRID = %{$G{$GRIDName}} ; - if ( clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $RESOURCE = "auth".lc($GRIDType)."s/$GRIDName"; - if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $editOK = 1; - } - if ( clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $editOK = 2; - } - } else { die "You cannot view $NODEName in $GRIDType.$GRIDName context"} - } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } - } else { die "$__{'Could not read'} $__{'Node Configuration'}"} - } else { die "$GRIDType.$GRIDName.$NODEName $__{'unknown'}" } + ($GRIDType, $GRIDName, $NODEName) = @NID; + %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); + if ("@{$allNodeGrids{$NODEName}}" =~ /\b$GRIDType\.$GRIDName\b/) { + my %G; + my %S = readNode($NODEName); + %NODE = %{$S{$NODEName}}; + if (%NODE) { + if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } + elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } + if (%G) { + %GRID = %{$G{$GRIDName}} ; + if ( clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $RESOURCE = "auth".lc($GRIDType)."s/$GRIDName"; + if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $editOK = 1; + } + if ( clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $editOK = 2; + } + } else { die "You cannot view $NODEName in $GRIDType.$GRIDName context"} + } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } + } else { die "$__{'Could not read'} $__{'Node Configuration'}"} + } else { die "$GRIDType.$GRIDName.$NODEName $__{'unknown'}" } } else { die "$__{'Not a fully qualified node name (gridtype.gridname.nodename)'}" } # ---- Looking for THEIA user flag @@ -148,8 +148,8 @@ =head1 Query string parameters my $fdsn = trim($NODE{"$GRIDType.$GRIDName.FDSN_NETWORK_CODE"} // $NODE{FDSN_NETWORK_CODE}); my $fid = $NODE{"$GRIDType.$GRIDName.FID"} // $NODE{FID}; my $fids = join(" - ", map { my $v; ($v = $_) =~ s/$GRIDType\.$GRIDName\.//; - "$v: $NODE{$_} "; } - sort grep(/$GRIDType\.$GRIDName\.FID_|^FID_/, keys(%NODE))); + "$v: $NODE{$_} "; } + sort grep(/$GRIDType\.$GRIDName\.FID_|^FID_/, keys(%NODE))); my $rawformat = $NODE{"$GRIDType.$GRIDName.RAWFORMAT"} // $NODE{RAWFORMAT}; my $rawdata = $NODE{"$GRIDType.$GRIDName.RAWDATA"} // $NODE{RAWDATA}; $rawdata =~ s/\$FID/$fid/g; @@ -162,8 +162,8 @@ =head1 Query string parameters if ($statusDB eq "") { $statusDB = "$WEBOBS{PATH_DATA_DB}/NODESSTATUS.db" }; my $statusNODE; if (-e $statusDB) { - $statusNODE = qx(sqlite3 $statusDB "select * from status where NODE like '%$QryParm->{'node'}%';"); - chomp($statusNODE); + $statusNODE = qx(sqlite3 $statusDB "select * from status where NODE like '%$QryParm->{'node'}%';"); + chomp($statusNODE); } $GRID{UTM_LOCAL} //= ''; @@ -226,23 +226,23 @@ =head1 Query string parameters print ""; print "
    \n"; print "

    $nodeName".($editOK ? " ":"") - .($editOK > 1 ? " ":"") - ."

    \n"; + .($editOK > 1 ? " ":"") + ."\n"; print "

    »» ["; if (uc($GRIDType) eq 'VIEW' || uc($GRIDType) eq 'PROC') { - print " $DOMAINS{$GRID{DOMAIN}}{NAME} / " - ."$GRID{NAME} |"; + print " $DOMAINS{$GRID{DOMAIN}}{NAME} / " + ."$GRID{NAME} |"; } print " $__{Project} | $__{Events} " - ."| ]

    "; + ."| ]

    "; print "    		".qrcode($WEBOBS{QRCODE_SIZE})."
    \n"; my %CLBS = readCfg("$WEBOBS{ROOT_CODE}/etc/clb.conf"); print "
    " - ."" - .""; + ."" + .""; # ---- start of node table ---------------------------------------------------- # @@ -253,32 +253,31 @@ =head1 Query string parameters print "Grids"; print "$QryParm->{'node'}"; for (@{$allNodeGrids{$NODEName}}) { - my $fullnode = "$_.$NODEName"; - print "
    $fullnode" if ($fullnode ne $QryParm->{'node'}); + my $fullnode = "$_.$NODEName"; + print "
    $fullnode" if ($fullnode ne $QryParm->{'node'}); } print "\n"; - # Row "type" ------------------------------------------------------------------ # print ""; if ($editOK) { - print "Type"; + print "Type"; } else { - print "Type"; + print "Type"; } print "$NODE{TYPE}\n"; # Row "GNSS 9-code" ---------------------------------------------------- # if ($NODE{GNSS_9CHAR}) { - print ""; - if ($editOK) { - print "GNSS 9-code"; - } else { - print "GNSS 9-code"; - } - print "$NODE{GNSS_9CHAR}\n"; + print ""; + if ($editOK) { + print "GNSS 9-code"; + } else { + print "GNSS 9-code"; + } + print "$NODE{GNSS_9CHAR}\n"; } # Row "Lifetime" ---------------------------------------------------- @@ -288,366 +287,364 @@ =head1 Query string parameters my $txt = "$__{'Lifetime'}"; print "".($editOK ? "$txt":$txt).""; print "" - ."$__{'Started on'}: ".($installDate ne "NA" ? "$installDate":"?") - ." / ".($endDate ne "NA" ? "$__{'Ended on'}: $endDate":"Active") - ."\n"; + ."$__{'Started on'}: ".($installDate ne "NA" ? "$installDate":"?") + ." / ".($endDate ne "NA" ? "$__{'Ended on'}: $endDate":"Active") + ."\n"; # Row "coordinates" and localization map -------------------------------------- # if (!($NODE{LAT_WGS84}=="" && $NODE{LON_WGS84}=="" && $NODE{ALTITUDE}=="")) { - my $lat = $NODE{LAT_WGS84}; - my $lon = $NODE{LON_WGS84}; - my $alt = $NODE{ALTITUDE}; - my ($e_utm,$n_utm,$utmzone) = geo2utm($lat,$lon); - my $e_utml; - my $n_utml; - my $utml0; - my $utml1; - my $utml2; - if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { - ($e_utml,$n_utml) = geo2utml($lat,$lon,$alt); - $utml0 = "
    $UTM{GEODETIC_DATUM_LOCAL_NAME}:"; - $utml1 = sprintf("
    %6.0f",$e_utml); - $utml2 = sprintf("
    %6.0f",$n_utml); - } - my $txt = $__{'Location'}; - - # ---- link to OpenStreetMap - # ------------------------ - my $map = "" - .""; - - # --- link KML Google Earth - # ------------------------- - if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - $map .= " \"KML\"\n"; - } - - # ---- link to interactive map - IGN (A. Bosson) - # ---------------------------------------------- - if ($WEBOBS{IGN_MAPI_LINK} eq 1) { - $map .= " \"".l2u($WEBOBS{IGN_MAPI_LINK_INFO})."\"\n"; - } - - print "".($editOK ? "$txt":$txt).""; - print ""; - print "" - ."" - ."" - .""; - my $alat = abs($lat); - my $alon = abs($lon); - print "\n" - ."" - .sprintf("",$alat,int($alat),($alat-int($alat))*60,$alat,($alat-int($alat))*60,($alat*60-int($alat*60))*60) - .sprintf("",$alon,int($alon),($alon-int($alon))*60,$alon,($alon-int($alon))*60,($alon*60-int($alon*60))*60) - ."" - ."" - .sprintf("",$e_utm,$n_utm) - ."
    $__{'Date'}$__{'Type'}$__{'Lat.'} ".($lat >= 0 ? "N":"S")." (WGS84)$__{'Lon.'} ".($lon >= 0 ? "E":"W")." (WGS84)$__{'Alt.'} (m)Transverse Mercator$__{'East'} (m)$__{'North'} (m)
    $NODE{POS_DATE}".u2l($typePos{$NODE{POS_TYPE}})." %9.6f °
    %02d ° %07.4f '
    %02d ° %02d ' %05.2f \"    		 %9.6f °
    %02d ° %07.4f '
    %02d ° %02d ' %05.2f \"    		$NODE{ALTITUDE}UTM$utmzone WGS84:$utml0%6.0f$utml1%6.0f$utml2$map
    \n"; - print "
    "; - if (-e $fileMap) { - my $tmp = basename($fileMap); - print ""; - } - # ---- Neighbour nodes - # ---------------------------------------------- - if ($NODES{NEIGHBOUR_NODES_MAX} > 0) { - # loads all existing nodes - my %dist; - my %deniv; - my %bear; - my %proj; - for (keys(%allNodes)) { - my %N = %{$allNodes{$_}}; - if (isok($N{VALID}) && (!isok($NODES{NEIGHBOUR_NODES_ACTIVE_ONLY}) || (($N{END_DATE} ge $today || $N{END_DATE} eq "NA") - && ($N{INSTALL_DATE} le $today || $N{INSTALL_DATE} eq "NA")))) { - ($dist{$_},$bear{$_}) = greatcircle($lat,$lon,$N{LAT_WGS84},$N{LON_WGS84}); - if ($alt != 0 && $N{ALTITUDE} != 0) { - $deniv{$_} = $N{ALTITUDE} - $alt; - $dist{$_} = sqrt($dist{$_}**2 + ($deniv{$_}/1000)**2); - } - $proj{$_} = $N{PROJECT}; - } - } - print "\n"; - } - print "
    \"$__{'Location" - ."" - ."\n"; - my $n = 1; - foreach (sort { $dist{$a} <=> $dist{$b} or $a cmp $b } keys %dist) { - if ($_ ne $NODEName) { - my $d = ($dist{$_}<1 ? sprintf("%8.0f m",1000*$dist{$_}):sprintf("%7.3f km",$dist{$_})); - my $p = ($proj{$_} ? " ":""); - print "" - ."" - ."\n"; - last if ($n++ == $NODES{NEIGHBOUR_NODES_MAX}); - } - } - print "
    $__{'Distance (beeline)'}$__{'Elev. gain'}$__{'Neighbour nodes'}
    $d".sprintf("%+1.0f m ",$deniv{$_})."".getNodeString(node=>$_, link=>'node')."$p
    \n\n"; + my $lat = $NODE{LAT_WGS84}; + my $lon = $NODE{LON_WGS84}; + my $alt = $NODE{ALTITUDE}; + my ($e_utm,$n_utm,$utmzone) = geo2utm($lat,$lon); + my $e_utml; + my $n_utml; + my $utml0; + my $utml1; + my $utml2; + if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { + ($e_utml,$n_utml) = geo2utml($lat,$lon,$alt); + $utml0 = "
    $UTM{GEODETIC_DATUM_LOCAL_NAME}:"; + $utml1 = sprintf("
    %6.0f",$e_utml); + $utml2 = sprintf("
    %6.0f",$n_utml); + } + my $txt = $__{'Location'}; + + # ---- link to OpenStreetMap + # ------------------------ + my $map = "" + .""; + + # --- link KML Google Earth + # ------------------------- + if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { + $map .= " \"KML\"\n"; + } + + # ---- link to interactive map - IGN (A. Bosson) + # ---------------------------------------------- + if ($WEBOBS{IGN_MAPI_LINK} eq 1) { + $map .= " \"".l2u($WEBOBS{IGN_MAPI_LINK_INFO})."\"\n"; + } + + print "".($editOK ? "$txt":$txt).""; + print ""; + print "" + ."" + ."" + .""; + my $alat = abs($lat); + my $alon = abs($lon); + print "\n" + ."" + .sprintf("",$alat,int($alat),($alat-int($alat))*60,$alat,($alat-int($alat))*60,($alat*60-int($alat*60))*60) + .sprintf("",$alon,int($alon),($alon-int($alon))*60,$alon,($alon-int($alon))*60,($alon*60-int($alon*60))*60) + ."" + ."" + .sprintf("",$e_utm,$n_utm) + ."
    $__{'Date'}$__{'Type'}$__{'Lat.'} ".($lat >= 0 ? "N":"S")." (WGS84)$__{'Lon.'} ".($lon >= 0 ? "E":"W")." (WGS84)$__{'Alt.'} (m)Transverse Mercator$__{'East'} (m)$__{'North'} (m)
    $NODE{POS_DATE}".u2l($typePos{$NODE{POS_TYPE}})." %9.6f °
    %02d ° %07.4f '
    %02d ° %02d ' %05.2f \"    		 %9.6f °
    %02d ° %07.4f '
    %02d ° %02d ' %05.2f \"    		$NODE{ALTITUDE}UTM$utmzone WGS84:$utml0%6.0f$utml1%6.0f$utml2$map
    \n"; + print "
    "; + if (-e $fileMap) { + my $tmp = basename($fileMap); + print ""; + } + + # ---- Neighbour nodes + # ---------------------------------------------- + if ($NODES{NEIGHBOUR_NODES_MAX} > 0) { + + # loads all existing nodes + my %dist; + my %deniv; + my %bear; + my %proj; + for (keys(%allNodes)) { + my %N = %{$allNodes{$_}}; + if (isok($N{VALID}) && (!isok($NODES{NEIGHBOUR_NODES_ACTIVE_ONLY}) || (($N{END_DATE} ge $today || $N{END_DATE} eq "NA") + && ($N{INSTALL_DATE} le $today || $N{INSTALL_DATE} eq "NA")))) { + ($dist{$_},$bear{$_}) = greatcircle($lat,$lon,$N{LAT_WGS84},$N{LON_WGS84}); + if ($alt != 0 && $N{ALTITUDE} != 0) { + $deniv{$_} = $N{ALTITUDE} - $alt; + $dist{$_} = sqrt($dist{$_}**2 + ($deniv{$_}/1000)**2); + } + $proj{$_} = $N{PROJECT}; + } + } + print "\n"; + } + print "
    \"$__{'Location" + ."" + ."\n"; + my $n = 1; + foreach (sort { $dist{$a} <=> $dist{$b} or $a cmp $b } keys %dist) { + if ($_ ne $NODEName) { + my $d = ($dist{$_}<1 ? sprintf("%8.0f m",1000*$dist{$_}):sprintf("%7.3f km",$dist{$_})); + my $p = ($proj{$_} ? " ":""); + print "" + ."" + ."\n"; + last if ($n++ == $NODES{NEIGHBOUR_NODES_MAX}); + } + } + print "
    $__{'Distance (beeline)'}$__{'Elev. gain'}$__{'Neighbour nodes'}
    $d".sprintf("%+1.0f m ",$deniv{$_})."".getNodeString(node=>$_, link=>'node')."$p
    \n\n"; } - # Row "transmission" type and link to relay / data acquisition # if ($NODE{TRANSMISSION} ne "NA" && $NODE{TRANSMISSION} ne "") { - my @trans = split(/ |,|\|/,$NODE{TRANSMISSION}); - chomp(@trans); - my $txt = $__{'Transmission'}; - print "".($editOK ? "$txt":$txt).""; - my ($utype,$ujunk) = split(/\|/,$typeTele{$trans[0]}{name}); - print ""; - for (@trans[1 .. $#trans]) { - my $distelev = ""; - my $nodelink = "$_ ($__{'unknown'})"; - if (exists $allNodes{$_}) { - my %N = %{$allNodes{$_}}; - if (!($N{LAT_WGS84}=="" && $N{LON_WGS84}=="")) { - my ($dist,$bear) = greatcircle($NODE{LAT_WGS84},$NODE{LON_WGS84},$N{LAT_WGS84},$N{LON_WGS84}); - my $deniv = ""; - if ($NODE{ALTITUDE} != 0 && $N{ALTITUDE} != 0) { - $deniv = $N{ALTITUDE} - $NODE{ALTITUDE}; - $dist = sqrt($dist**2 + ($deniv/1000)**2); - } - my $d = ($dist<1 ? sprintf("%8.0f m",1000*$dist):sprintf("%7.3f km",$dist)); - $distelev = "" - .""; - } - $nodelink = getNodeString(node=>$_,link=>'node').($N{PROJECT} ? " ":""); - } - print "$distelev\n"; - } - print "
    Type: ".u2l($utype)."
      $d(Δh ".sprintf("%+1.0f m",$deniv).") 
    $nodelink
    \n"; - print "\n"; + my @trans = split(/ |,|\|/,$NODE{TRANSMISSION}); + chomp(@trans); + my $txt = $__{'Transmission'}; + print "".($editOK ? "$txt":$txt).""; + my ($utype,$ujunk) = split(/\|/,$typeTele{$trans[0]}{name}); + print ""; + for (@trans[1 .. $#trans]) { + my $distelev = ""; + my $nodelink = "$_ ($__{'unknown'})"; + if (exists $allNodes{$_}) { + my %N = %{$allNodes{$_}}; + if (!($N{LAT_WGS84}=="" && $N{LON_WGS84}=="")) { + my ($dist,$bear) = greatcircle($NODE{LAT_WGS84},$NODE{LON_WGS84},$N{LAT_WGS84},$N{LON_WGS84}); + my $deniv = ""; + if ($NODE{ALTITUDE} != 0 && $N{ALTITUDE} != 0) { + $deniv = $N{ALTITUDE} - $NODE{ALTITUDE}; + $dist = sqrt($dist**2 + ($deniv/1000)**2); + } + my $d = ($dist<1 ? sprintf("%8.0f m",1000*$dist):sprintf("%7.3f km",$dist)); + $distelev = "" + .""; + } + $nodelink = getNodeString(node=>$_,link=>'node').($N{PROJECT} ? " ":""); + } + print "$distelev\n"; + } + print "
    Type: ".u2l($utype)."
      $d(Δh ".sprintf("%+1.0f m",$deniv).") 
    $nodelink
    \n"; + print "\n"; } - # Row "proc": codes, status, data... ----------------- # if (uc($GRIDType) eq 'PROC') { - print ""; - if ($editOK) { print "Proc" } - else { print "Proc" } - printf ""; - - # --- parameters - my $txt = "$__{'Parameters'}"; - if ($editOK > 1) { print "$txt" } - elsif ($editOK) { print "$txt" } - else { print "$txt" } - print ""; - #print "ID: $NODEName"; - print "FID: ".($fid ne "" ? "$fid":"$__{undefined}")."\n"; - print "
    Network: $fdsn ($FDSN{$fdsn})\n" if ($fdsn ne ""); - print "
    $fids" if ($fids ne ""); - print "
    Raw Format: $rawFormats{$rawformat}{supfmt} / $rawformat ($rawFormats{$rawformat}{name})" if ($rawformat ne ""); - print "
    Raw Data Source: $rawdata" if ($rawdata ne ""); - print "\n"; - - # --- description - print "$__{'Description'}$desc\n"; - - # --- status - print "$__{'Status'}" - .""; # Date de l'analyse de l'etat - if ($endDate eq "NA") { - print ""; - print ""; - } - } - print "
    "; - print "Acquisition Period: ".($acqrate ne "" ? "$acqrate days":"not set")."
    "; - print "Acquisition Delay: ".($acqdelay ne "" ? "$acqdelay days":"not set")."
    "; - if ($statusNODE ne "") { - my @status = split(/\|/,$statusNODE); - my $bgcolEt = ""; - my $bgcolA = ""; - if ($status[1] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolEt = "status-standby"; $status[1] = "Standby"; } # grey/gray - elsif ($status[1] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolEt = "status-critical"; $status[1] .= "%"; } - elsif ($status[1] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolEt = "status-ok"; $status[1] .= "%"; } - else { $bgcolEt="status-warning"; $status[1] .= "%"; } - if ($status[2] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolA = "status-standby"; $status[2] = "Standby"; } - elsif ($status[2] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolA = "status-critical"; $status[2] .= "%"; } - elsif ($status[2] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolA = "status-ok"; $status[2] .= "%"; } - else { $bgcolA="status-warning"; $status[2] .= "%"; } - print "    		$__{'Last status check on'} $status[4]$__{'Sampl.'}: $status[2]$__{'Status'}: $status[1]
    \n"; - - # data (data & graphs from proc) - my $OUTG = ""; - if (-d "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName" ) { - $OUTG = "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName"; - } - my (@glist) = map { "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/$NODENameLower\_$_.png" } @procTS; - my (@dlist) = map { "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/$NODENameLower\_$_.txt" } @procTS; - - print "$__{'Data'}"; - if ($OUTG ne "" && isok($NODE{VALID}) && ($GRID{'URLDATA'} ne "" || $GRID{'FORM'} ne "" || $#glist >= 0 || $#dlist >= 0)) { - print "\n"; - print "
    "; - if ($GRID{'FORM'} ne "") { - %FORM = readCfg("$WEBOBS{PATH_FORMS}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); - my $txt = $FORM{TITLE} // "$__{'Data bank'}"; - my $url = "/cgi-bin/$FORM{CGI_SHOW}"; - print "$__{'Form'}: $txt
    "; - } - if ($GRID{'URLDATA'} ne "") { - my $rep = "$GRID{'RAWDATA'}"; - print "$__{'Raw data'}: $rep
    "; - if ($#dlist >= 0) { - print "$__{'ASCII data file(s)'}"; - for (@dlist) { - my $z = basename $_; - print "$z "; # ??? type# - } - print "
    "; - } - } - if ($#glist >= 0) { - print "$__{'Outputs'}: $GRIDName
    "; - } - print "    		"; - for (@glist) { - my $tmp = basename $_; - chomp($tmp); - my ($name,$ext) = split(/\./,$tmp); - my ($node,$time) = split(/_/,$name); - my $vignette = "PROC.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}/$name.jpg"; - if (-e "$WEBOBS{ROOT_OUTG}/$vignette") { - $vignette = "$WEBOBS{URN_OUTG}/$vignette"; - my $tmp2 = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName&ts=$time&g=$node"; - my $message = "$__{'Click to enlarge'}
    "; - $message = $message."Image=$tmp
    "; - print "\"$vignette\""; - } - } - print "
    \n"; - } - print "\n"; - - # channels (calibration file) - my %carCLB = readCLB("$GRIDType.$GRIDName.$NODEName"); - print ""; - my $txt = $__{'Channels'}; - if ($editOK) { - if (scalar(keys %carCLB) > 0) { - print "$txt"; - } else { - print "$txt"; - } - } else { - print "$txt"; - } - print ""; - if (scalar(keys %carCLB) > 0) { - my @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); - my %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); - unless ( isok($theiaAuth) ) { delete($fieldCLB{"THEIA_CATEGORY"}); } - my @params; - foreach my $k (sort { $fieldCLB{$a}{'_SO_'} <=> $fieldCLB{$b}{'_SO_'} } keys %fieldCLB) { push(@params, $k); } - - print ""; - foreach my $k ( @params ) { - print ""; - } - print "\n"; - my @select = split(/,/,$chanlist); - my $dateCLB = ""; - my $sepCLB; - foreach my $k (sort keys %carCLB) { - my @chpCLB; - foreach my $p ( @params ) { push(@chpCLB, $carCLB{$k}{$p}) } - if ($#chpCLB < $#params) { - push(@chpCLB, ("") x ($#params - $#chpCLB)); - } - pop(@chpCLB) if ( !$theiaAuth && $#chpCLB > $#params ); - if ($dateCLB ne "" && $dateCLB ne $chpCLB[0]) { - $sepCLB = "\n"; - print $sepCLB; - } - $dateCLB = $chpCLB[0]; - my $active = "style=\"".($chpCLB[2] ~~ @select || $chanlist == "" ? "font-weight:bold":"color:gray")."\""; - print ""; - } - print "$sepCLB
    ",$fieldCLB{$k}{"Name"}."
    ".join("",@chpCLB)."
    \n"; - print "
    @clbNote"; - } else { - print "no channel defined"; - } - print "\n"; + print ""; + if ($editOK) { print "Proc" } + else { print "Proc" } + printf ""; + + # --- parameters + my $txt = "$__{'Parameters'}"; + if ($editOK > 1) { print "$txt" } + elsif ($editOK) { print "$txt" } + else { print "$txt" } + print ""; + + #print "ID: $NODEName"; + print "FID: ".($fid ne "" ? "$fid":"$__{undefined}")."\n"; + print "
    Network: $fdsn ($FDSN{$fdsn})\n" if ($fdsn ne ""); + print "
    $fids" if ($fids ne ""); + print "
    Raw Format: $rawFormats{$rawformat}{supfmt} / $rawformat ($rawFormats{$rawformat}{name})" if ($rawformat ne ""); + print "
    Raw Data Source: $rawdata" if ($rawdata ne ""); + print "\n"; + + # --- description + print "$__{'Description'}$desc\n"; + + # --- status + print "$__{'Status'}" + .""; # Date de l'analyse de l'etat + if ($endDate eq "NA") { + print ""; + print ""; + } + } + print "
    "; + print "Acquisition Period: ".($acqrate ne "" ? "$acqrate days":"not set")."
    "; + print "Acquisition Delay: ".($acqdelay ne "" ? "$acqdelay days":"not set")."
    "; + if ($statusNODE ne "") { + my @status = split(/\|/,$statusNODE); + my $bgcolEt = ""; + my $bgcolA = ""; + if ($status[1] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolEt = "status-standby"; $status[1] = "Standby"; } # grey/gray + elsif ($status[1] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolEt = "status-critical"; $status[1] .= "%"; } + elsif ($status[1] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolEt = "status-ok"; $status[1] .= "%"; } + else { $bgcolEt="status-warning"; $status[1] .= "%"; } + if ($status[2] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolA = "status-standby"; $status[2] = "Standby"; } + elsif ($status[2] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolA = "status-critical"; $status[2] .= "%"; } + elsif ($status[2] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolA = "status-ok"; $status[2] .= "%"; } + else { $bgcolA="status-warning"; $status[2] .= "%"; } + print "    		$__{'Last status check on'} $status[4]$__{'Sampl.'}: $status[2]$__{'Status'}: $status[1]
    \n"; + + # data (data & graphs from proc) + my $OUTG = ""; + if (-d "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName" ) { + $OUTG = "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName"; + } + my (@glist) = map { "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/$NODENameLower\_$_.png" } @procTS; + my (@dlist) = map { "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/$NODENameLower\_$_.txt" } @procTS; + + print "$__{'Data'}"; + if ($OUTG ne "" && isok($NODE{VALID}) && ($GRID{'URLDATA'} ne "" || $GRID{'FORM'} ne "" || $#glist >= 0 || $#dlist >= 0)) { + print "\n"; + print "
    "; + if ($GRID{'FORM'} ne "") { + %FORM = readCfg("$WEBOBS{PATH_FORMS}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); + my $txt = $FORM{TITLE} // "$__{'Data bank'}"; + my $url = "/cgi-bin/$FORM{CGI_SHOW}"; + print "$__{'Form'}: $txt
    "; + } + if ($GRID{'URLDATA'} ne "") { + my $rep = "$GRID{'RAWDATA'}"; + print "$__{'Raw data'}: $rep
    "; + if ($#dlist >= 0) { + print "$__{'ASCII data file(s)'}"; + for (@dlist) { + my $z = basename $_; + print "$z "; # ??? type# + } + print "
    "; + } + } + if ($#glist >= 0) { + print "$__{'Outputs'}: $GRIDName
    "; + } + print "    		"; + for (@glist) { + my $tmp = basename $_; + chomp($tmp); + my ($name,$ext) = split(/\./,$tmp); + my ($node,$time) = split(/_/,$name); + my $vignette = "PROC.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}/$name.jpg"; + if (-e "$WEBOBS{ROOT_OUTG}/$vignette") { + $vignette = "$WEBOBS{URN_OUTG}/$vignette"; + my $tmp2 = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName&ts=$time&g=$node"; + my $message = "$__{'Click to enlarge'}
    "; + $message = $message."Image=$tmp
    "; + print "\"$vignette\""; + } + } + print "
    \n"; + } + print "\n"; + + # channels (calibration file) + my %carCLB = readCLB("$GRIDType.$GRIDName.$NODEName"); + print ""; + my $txt = $__{'Channels'}; + if ($editOK) { + if (scalar(keys %carCLB) > 0) { + print "$txt"; + } else { + print "$txt"; + } + } else { + print "$txt"; + } + print ""; + if (scalar(keys %carCLB) > 0) { + my @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); + my %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); + unless ( isok($theiaAuth) ) { delete($fieldCLB{"THEIA_CATEGORY"}); } + my @params; + foreach my $k (sort { $fieldCLB{$a}{'_SO_'} <=> $fieldCLB{$b}{'_SO_'} } keys %fieldCLB) { push(@params, $k); } + + print ""; + foreach my $k ( @params ) { + print ""; + } + print "\n"; + my @select = split(/,/,$chanlist); + my $dateCLB = ""; + my $sepCLB; + foreach my $k (sort keys %carCLB) { + my @chpCLB; + foreach my $p ( @params ) { push(@chpCLB, $carCLB{$k}{$p}) } + if ($#chpCLB < $#params) { + push(@chpCLB, ("") x ($#params - $#chpCLB)); + } + pop(@chpCLB) if ( !$theiaAuth && $#chpCLB > $#params ); + if ($dateCLB ne "" && $dateCLB ne $chpCLB[0]) { + $sepCLB = "\n"; + print $sepCLB; + } + $dateCLB = $chpCLB[0]; + my $active = "style=\"".($chpCLB[2] ~~ @select || $chanlist == "" ? "font-weight:bold":"color:gray")."\""; + print ""; + } + print "$sepCLB
    ",$fieldCLB{$k}{"Name"}."
    ".join("",@chpCLB)."
    \n"; + print "
    @clbNote"; + } else { + print "no channel defined"; + } + print "\n"; } - # Row "installation" # my $RinfoInstallFile = "installation.txt"; my $infoInstallFile = "$NODES{PATH_NODES}/$NODEName/$RinfoInstallFile"; my @infosInstallNode = (""); if ((-e $infoInstallFile) && (-s $infoInstallFile != 0)) { - @infosInstallNode = grep(!/^$/,readFile($infoInstallFile)); + @infosInstallNode = grep(!/^$/,readFile($infoInstallFile)); } if ($editOK || $#infosInstallNode >=0) { - print ""; - my $txt = $__{'Installation'}; - print ($editOK ? "$txt":$txt); - print "".wiki2html(join("",@infosInstallNode))."\n"; + print ""; + my $txt = $__{'Installation'}; + print ($editOK ? "$txt":$txt); + print "".wiki2html(join("",@infosInstallNode))."\n"; } # Row "M3G" # if ( $NODE{GNSS_9CHAR} && $NODE{M3G_AVAIABLE} ) { - print ""; - my $txt = $__{'M3G GNSS Metadata'}; - my $gnss9char = $NODE{GNSS_9CHAR}; - my $gmlfile = "$NODES{PATH_NODES}/$NODEName/$gnss9char.xml"; - my $m3g_url_sitelog = $WEBOBS{'M3G_EXPORTLOG'}.$gnss9char; - my $m3g_url_gml = $WEBOBS{'M3G_EXPORTXML'}.$gnss9char; - my @rec; - my $txt_rec = "Receiver history feature"; - my @ant; - my $txt_ant = "Antenna history feature"; - - my $m3g_link_sitelog = "Download $gnss9char sitelog on your local disk"; - my $m3g_link_gml = "Download $gnss9char GeodesyML on your local disk"; - - if (-e $gmlfile) { - @rec = gml2mmdtable($gmlfile,"gnssrec"); - chomp(@rec); - $txt_rec = join("\n",@rec); - @ant = gml2mmdtable($gmlfile,"gnssant"); - chomp(@ant); - $txt_ant = join("\n",@ant); - } - - #### get geodesyML from M3G - my $GetGml = "/cgi-bin/get_gml_m3g.pl"; - my $m3g_xml = "Import GNSS metadata from M3G"; - - if ($editOK) { - print "$txt"; - } else { - print "M3G GNSS Metadata"; - } #print "".join("
    ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml,$txt_rec,$txt_ant)."\n"; - print "".join("
    ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml)."
    \n"; - print "
    Receiver history featureAntenna history feature
    ".wiki2html($txt_rec)."".wiki2html($txt_ant)."
    "; + print ""; + my $txt = $__{'M3G GNSS Metadata'}; + my $gnss9char = $NODE{GNSS_9CHAR}; + my $gmlfile = "$NODES{PATH_NODES}/$NODEName/$gnss9char.xml"; + my $m3g_url_sitelog = $WEBOBS{'M3G_EXPORTLOG'}.$gnss9char; + my $m3g_url_gml = $WEBOBS{'M3G_EXPORTXML'}.$gnss9char; + my @rec; + my $txt_rec = "Receiver history feature"; + my @ant; + my $txt_ant = "Antenna history feature"; + + my $m3g_link_sitelog = "Download $gnss9char sitelog on your local disk"; + my $m3g_link_gml = "Download $gnss9char GeodesyML on your local disk"; + + if (-e $gmlfile) { + @rec = gml2mmdtable($gmlfile,"gnssrec"); + chomp(@rec); + $txt_rec = join("\n",@rec); + @ant = gml2mmdtable($gmlfile,"gnssant"); + chomp(@ant); + $txt_ant = join("\n",@ant); + } + + #### get geodesyML from M3G + my $GetGml = "/cgi-bin/get_gml_m3g.pl"; + my $m3g_xml = "Import GNSS metadata from M3G"; + + if ($editOK) { + print "$txt"; + } else { + print "M3G GNSS Metadata"; + } #print "".join("
    ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml,$txt_rec,$txt_ant)."\n"; + print "".join("
    ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml)."
    \n"; + print "
    Receiver history featureAntenna history feature
    ".wiki2html($txt_rec)."".wiki2html($txt_ant)."
    "; } - - # Row "infos" # my $RinfoFile = "info.txt"; my $infoFile = "$NODES{PATH_NODES}/$NODEName/$RinfoFile"; my @txt = (""); if ((-e $infoFile) && (-s $infoFile != 0)) { - @txt = readFile("$infoFile"); + @txt = readFile("$infoFile"); } if ($editOK) { - print "$__{Information}".wiki2html(join("",@txt))."\n"; + print "$__{Information}".wiki2html(join("",@txt))."\n"; } elsif ($#txt >= 0) { - print "$__{Information}".wiki2html(join("",@txt))."\n"; + print "$__{Information}".wiki2html(join("",@txt))."\n"; } # Row "access" @@ -656,15 +653,14 @@ =head1 Query string parameters my $accessFile="$NODES{PATH_NODES}/$NODEName/$RaccessFile"; @txt = (""); if ((-e $accessFile) && (-s $accessFile != 0)) { - @txt = readFile("$accessFile"); + @txt = readFile("$accessFile"); } if ($editOK) { - print "$__{Access}".wiki2html(join("",@txt))."\n"; + print "$__{Access}".wiki2html(join("",@txt))."\n"; } elsif ($#txt >= 0) { - print "$__{Access}".wiki2html(join("",@txt))."\n"; + print "$__{Access}".wiki2html(join("",@txt))."\n"; } - # Rows "Features" # my @listeFinaleCarFiles=(""); @@ -675,43 +671,44 @@ =head1 Query string parameters # first insert 'parent' features from $NODES{FILE_NODES2NODES} for NODEName my $pseudoFileName = ""; for my $key_link (keys %node2node) { - my @children_node_list = split(/\|/,$node2node{$key_link}); - for (@children_node_list) { - if ( $_ eq $NODEName ) { - my @data = split(/\|/,$key_link); - my $parent_node = $data[0]; - my $feature = $data[1]; - $pseudoFileName = "ISOF:$feature"; - $lienNode{$pseudoFileName} .= (exists($lienNode{$pseudoFileName}) ? "
    ":"").getNodeString(node=>$parent_node, link=>'node'); - } - } + my @children_node_list = split(/\|/,$node2node{$key_link}); + for (@children_node_list) { + if ( $_ eq $NODEName ) { + my @data = split(/\|/,$key_link); + my $parent_node = $data[0]; + my $feature = $data[1]; + $pseudoFileName = "ISOF:$feature"; + $lienNode{$pseudoFileName} .= (exists($lienNode{$pseudoFileName}) ? "
    ":"").getNodeString(node=>$parent_node, link=>'node'); + } + } } push(@listeFinaleCarFiles,keys(%lienNode)) ; # now add features defined in the $NODEName cnf file my @listeCarFiles=split(/\||,/,$NODE{FILES_FEATURES}); for (@listeCarFiles) { - my $carFileName = $_; - my $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; - my $key_link = $NODEName."|".$carFileName; - $lienNode{$carFileName} = ""; - $lien_car = 0; - if ( exists($node2node{$key_link}) ) { - my @liste_liens=split(/\|/,$node2node{$key_link}); - for (@liste_liens) { - if ( length($_) > 0 ) { - $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "
    ").getNodeString(node=>$_, style=>'html', link=>'features').""; - } - } - if ( $lienNode{$carFileName} ne "" ) { - $lienNode{$carFileName} .= "

    "; - } - $lien_car = 1; - } - #FB-was: if ((-e $carFile && (-s $carFile || $editOK)) || $lien_car == 1) { - if ((-e $carFile || $editOK) || $lien_car == 1) { - push(@listeFinaleCarFiles,$carFileName); - } + my $carFileName = $_; + my $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; + my $key_link = $NODEName."|".$carFileName; + $lienNode{$carFileName} = ""; + $lien_car = 0; + if ( exists($node2node{$key_link}) ) { + my @liste_liens=split(/\|/,$node2node{$key_link}); + for (@liste_liens) { + if ( length($_) > 0 ) { + $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "
    ").getNodeString(node=>$_, style=>'html', link=>'features').""; + } + } + if ( $lienNode{$carFileName} ne "" ) { + $lienNode{$carFileName} .= "

    "; + } + $lien_car = 1; + } + + #FB-was: if ((-e $carFile && (-s $carFile || $editOK)) || $lien_car == 1) { + if ((-e $carFile || $editOK) || $lien_car == 1) { + push(@listeFinaleCarFiles,$carFileName); + } } # 2) build output from 'final' list of features @@ -719,37 +716,37 @@ =head1 Query string parameters my @carNode; my $carFile; if ($lignes > 0) { - print ""; - if ($editOK) { - print "$__{Features}"; - } else { - print "$__{Features}"; - } - print ""; - @listeFinaleCarFiles = grep(!/^$/, @listeFinaleCarFiles); - for (@listeFinaleCarFiles) { - my $carFileName = $_; - if ( /^ISOF:/ ) { - @carNode = $lienNode{$_}; - s/^ISOF://g; - $carFileName = $_." of"; - } else { - $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; - @carNode = readFile($carFile); - if ( "@carNode" eq "") { - @carNode = (" "); - } - @carNode = (wiki2html(join("",@carNode))); - } - print "" if ($_ ne $listeFinaleCarFiles[0]); - if ($editOK && !($carFileName =~ / of$/)) { - print "$carFileName\n"; - } else { - print "$carFileName\n"; - } - my $lien = (exists($lienNode{$carFileName}) ? $lienNode{$carFileName}:""); - print "$lien@carNode\n"; - } + print ""; + if ($editOK) { + print "$__{Features}"; + } else { + print "$__{Features}"; + } + print ""; + @listeFinaleCarFiles = grep(!/^$/, @listeFinaleCarFiles); + for (@listeFinaleCarFiles) { + my $carFileName = $_; + if ( /^ISOF:/ ) { + @carNode = $lienNode{$_}; + s/^ISOF://g; + $carFileName = $_." of"; + } else { + $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; + @carNode = readFile($carFile); + if ( "@carNode" eq "") { + @carNode = (" "); + } + @carNode = (wiki2html(join("",@carNode))); + } + print "" if ($_ ne $listeFinaleCarFiles[0]); + if ($editOK && !($carFileName =~ / of$/)) { + print "$carFileName\n"; + } else { + print "$carFileName\n"; + } + my $lien = (exists($lienNode{$carFileName}) ? $lienNode{$carFileName}:""); + print "$lien@carNode\n"; + } } # ---- PHOTOS,SCHEMAS,DOCUMENTS common stuff @@ -762,115 +759,124 @@ =head1 Query string parameters # Row "PHOTOS" ---------------------------------------------------------------- # $Fpath = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_PHOTOS}"; + #FB-was: ( $Furn = $Fpath) =~ s/$WEBOBS{ROOT_SITE}/../g; ( $Furn = $Fpath) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; $Tpath = "$Fpath/$NODES{SPATH_THUMBNAILS}"; qx(mkdir -p $Tpath) if (!-d $Tpath); my @listePhotos = <$Fpath/*.{jpg,jpeg,JPG,JPEG,HEIC}*> ; + #DL-was:my $uploadPHOTOS = "$WEBOBS{CGI_UPLOAD}?node=$GRIDType.$GRIDName.$NODEName&doc=$NODES{SPATH_PHOTOS}"; my $uploadPHOTOS = "$WEBOBS{CGI_UPLOAD}?object=$GRIDType.$GRIDName.$NODEName&doc=SPATH_PHOTOS"; if ($editOK) { - print "$__{Photos}"; + print "$__{Photos}"; } elsif ($#listePhotos >= 0) { - print "$__{Photos}"; + print "$__{Photos}"; } chomp(@listePhotos); if ($#listePhotos >= 0) { - for (@listePhotos) { - $Fn = basename($_); - $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); - ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); - #FB-was: ( $Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; - ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $olmsg = htmlspecialchars(__x("Click to enlarge
    Image={image}
    Date=$Fts
    Size=$Fwh",image=>$Fn)); - print "\"".__x('Image$Furn."/".$Fn)."\">\n"; - #print "\"".__x('Image$Furn."/".$Fn)."\">\n"; - } + for (@listePhotos) { + $Fn = basename($_); + $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); + ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); + + #FB-was: ( $Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; + ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $olmsg = htmlspecialchars(__x("Click to enlarge
    Image={image}
    Date=$Fts
    Size=$Fwh",image=>$Fn)); + print "\"".__x('Image$Furn."/".$Fn)."\">\n"; + +#print "\"".__x('Image$Furn."/".$Fn)."\">\n"; + } } if ($editOK || $#listePhotos >= 0) { - print "\n"; + print "\n"; } # Row "SCHEMES" --------------------------------------------------------------- # $Fpath = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_SCHEMES}"; + #FB-was: ($Furn = $Fpath) =~ s/$WEBOBS{ROOT_SITE}/../g; ( $Furn = $Fpath) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; $Tpath = "$Fpath/$NODES{SPATH_THUMBNAILS}"; qx(mkdir -p $Tpath) if (!-d $Tpath); my @listeSchemas = <$Fpath/*.*> ; + #DL-was:my $uploadSCHEMAS = "$WEBOBS{CGI_UPLOAD}?node=$GRIDType.$GRIDName.$NODEName&doc=$NODES{SPATH_SCHEMES}"; my $uploadSCHEMAS = "$WEBOBS{CGI_UPLOAD}?object=$GRIDType.$GRIDName.$NODEName&doc=SPATH_SCHEMES"; if ($editOK) { - print "$__{Diagrams}"; + print "$__{Diagrams}"; } elsif ($#listeSchemas >= 0) { - print "$__{Diagrams}"; + print "$__{Diagrams}"; } chomp(@listeSchemas); if ($#listeSchemas >= 0) { - for (@listeSchemas) { - $Fn = basename($_); - print ""; - if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { - $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); - if ($TFn ne "") { - #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; - ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); - ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $olmsg = htmlspecialchars(__x("Click to enlarge
    Image={image}
    Size=$Fwh",image=>$Fn)); - print "\"".__x('Image$Furn."/".$Fn)."\">"; - } else { print "$Fn
    " } - } else { print "$Fn
    " } - print "    \n"; - } + for (@listeSchemas) { + $Fn = basename($_); + print ""; + if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { + $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); + if ($TFn ne "") { + + #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; + ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); + ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $olmsg = htmlspecialchars(__x("Click to enlarge
    Image={image}
    Size=$Fwh",image=>$Fn)); + print "\"".__x('Image$Furn."/".$Fn)."\">"; + } else { print "$Fn
    " } + } else { print "$Fn
    " } + print "    \n"; + } } if ($editOK || $#listeSchemas >= 0) { - print "\n"; + print "\n"; } # Row "DOCUMENTS" ------------------------------------------------------------- # $Fpath = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_DOCUMENTS}"; + #FB-was: ($Furn = $Fpath) =~ s/$WEBOBS{ROOT_SITE}/../g; ( $Furn = $Fpath) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; $Tpath = "$Fpath/$NODES{SPATH_THUMBNAILS}"; qx(mkdir -p $Tpath) if (!-d $Tpath); my @listeDocuments = <$Fpath/*.*> ; + #DL-was:my $uploadDOCUMENTS = "$WEBOBS{CGI_UPLOAD}?node=$GRIDType.$GRIDName.$NODEName&doc=$NODES{SPATH_DOCUMENTS}"; my $uploadDOCUMENTS = "$WEBOBS{CGI_UPLOAD}?object=$GRIDType.$GRIDName.$NODEName&doc=SPATH_DOCUMENTS"; if ($editOK) { - print "$__{Documents}"; + print "$__{Documents}"; } elsif ($#listeDocuments >= 0) { - print "$__{Documents}"; + print "$__{Documents}"; } chomp(@listeDocuments); if ($#listeDocuments >= 0) { - for (@listeDocuments) { - $Fn = basename($_); - print ""; - if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { - $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); - if ($TFn ne "") { - #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; - ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $olmsg = htmlspecialchars(__x("Click to download
    File={file}",file=>$Fn)); - print "\"".__x('Image$Furn."/".$Fn)."\">"; - } else { print "$Fn
    "; } - } else { print "$Fn
    "; } - print "    \n"; - } + for (@listeDocuments) { + $Fn = basename($_); + print ""; + if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { + $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); + if ($TFn ne "") { + + #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; + ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $olmsg = htmlspecialchars(__x("Click to download
    File={file}",file=>$Fn)); + print "\"".__x('Image$Furn."/".$Fn)."\">"; + } else { print "$Fn
    "; } + } else { print "$Fn
    "; } + print "    \n"; + } } if ($editOK || $#listeDocuments >= 0) { - print "\n"; + print "\n"; } # # ---- end of node table ------------------------------------------------------ print ""; - # ---- Project ---------------------------------------------------------------- # print "
    \n"; @@ -890,7 +896,7 @@ =head1 Query string parameters if ($editOK) { print "  " } print " $go2top

    "; print " $__{'Sort by'} [ ".($sortBy ne "event" ? "$__{'Event'}":"$__{'Event'}")." | " - .($sortBy ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
    \n"; + .($sortBy ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
    \n"; my $htmlEvents = ($sortBy =~ /event/i) ? eventsShow("events","$GRIDType.$GRIDName.$NODEName", $editOK) : eventsShow("date","$GRIDType.$GRIDName.$NODEName", $editOK); print $htmlEvents; print "
    "; @@ -898,7 +904,6 @@ =head1 Query string parameters # --- we're done !!!! print "

    \n\n\n"; - __END__ =pod diff --git a/CODE/cgi-bin/showNODES.pl b/CODE/cgi-bin/showNODES.pl index 4efc585b..ef065243 100755 --- a/CODE/cgi-bin/showNODES.pl +++ b/CODE/cgi-bin/showNODES.pl @@ -29,16 +29,16 @@ =head1 DESCRIPTION # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } # get all GRIDs with a minimum read auth my @T; for (sort(WebObs::Grids::listViewNames())) { - push(@T, "VIEW.$_") if (clientHasRead(type=>"authviews",name=>"$_")); + push(@T, "VIEW.$_") if (clientHasRead(type=>"authviews",name=>"$_")); } for (sort(WebObs::Grids::listProcNames())) { - push(@T, "PROC.$_") if (clientHasRead(type=>"authprocs",name=>"$_")); + push(@T, "PROC.$_") if (clientHasRead(type=>"authprocs",name=>"$_")); }; # get all NODE IDs with grid association @@ -83,39 +83,39 @@ =head1 DESCRIPTION # ---- build matrix as a print "
    "; print "
    \n"; - print ""; - my $oddeven = "even"; my $what = 'view'; - $row = ""; - for (@T) { - $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; - $row .= ""; - $oddeven = $oddeven eq "even" ? "odd" : "even"; - } - print "$row\n"; - print "\n"; - - print ""; - for my $node (sort keys(%N)) { - my $oddeven = "even"; - $row = ""; - if (@{$N{$node}}) { - for (@T) { - $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; - if ($_ ~~ @{$N{$node}}) { - my $link = "\"$NODES{CGI_SHOW}?node=$_.$node\""; - $row .= "" - } - else { - $row .= "" - } - $oddeven = $oddeven eq "even" ? "odd" : "even"; - } - } else { - $row .= "\n"; - } - print $row; - } - print ""; +print ""; +my $oddeven = "even"; my $what = 'view'; +$row = ""; +for (@T) { + $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; + $row .= ""; + $oddeven = $oddeven eq "even" ? "odd" : "even"; +} +print "$row\n"; +print "\n"; + +print ""; +for my $node (sort keys(%N)) { + my $oddeven = "even"; + $row = ""; + if (@{$N{$node}}) { + for (@T) { + $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; + if ($_ ~~ @{$N{$node}}) { + my $link = "\"$NODES{CGI_SHOW}?node=$_.$node\""; + $row .= "" + } + else { + $row .= "" + } + $oddeven = $oddeven eq "even" ? "odd" : "even"; + } + } else { + $row .= "\n"; + } + print $row; +} +print ""; print "
    $_
    $node○∅
    $_
    $node○∅
    "; print "\n"; diff --git a/CODE/cgi-bin/showNOVAC.pl b/CODE/cgi-bin/showNOVAC.pl index 2096f543..d0b76f8f 100755 --- a/CODE/cgi-bin/showNOVAC.pl +++ b/CODE/cgi-bin/showNOVAC.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showNOVAC.pl @@ -99,20 +100,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -138,31 +139,31 @@ =head1 Query string parameters my @cleParamAnnee = ("Old|Old"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my $titrePage = $FORM->conf('TITLE'); my @option = (); -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "All"; -$QryParm->{'site'} ||= "All"; -$QryParm->{'affiche'} ||= ""; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "All"; +$QryParm->{'site'} ||= "All"; +$QryParm->{'affiche'} ||= ""; # ---- a site requested as {name} means "all nodes for grid (proc) 'name'" # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -172,8 +173,8 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n + print $cgi->header(-charset=>'utf-8'); + print "\n \n \n $titrePage\n @@ -192,57 +193,57 @@ =head1 Query string parameters # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print "\n + print "\n
    conf('CGI_SHOW')."\" method=\"get\">\n

    \n Select: \n \n \n \n "; - if ($editOK) { - print "\n + if ($editOK) { + print "\n conf('CGI_FORM')."'\" value=\"new record\"/>"; - } - print "\n + } + print "\n

    \n
    \n

    $titrePage

    \n @@ -269,8 +270,9 @@ =head1 Query string parameters $tableHeader = ""; if ($editOK) { - $tableHeader = $tableHeader.""; + $tableHeader = $tableHeader.""; } + # ------------------------------------------------------------ # ---- start of specific NOVAC form code --------------------- # ------------------------------------------------------------ @@ -286,47 +288,48 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,u2l("$date;Code Site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans")); - } - elsif (($_ ne "") - && (($QryParm->{'site'} eq "All") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "All") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Old") && ($date lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "All") || ($QryParm->{'mois'} eq substr($date,5,2)))) { - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($editOK) { - $texte = $texte."$modif"; - } - $texte = $texte."$date$lien$flux1" - ."$flux2$windSpeed" - ."$windSpeedSource$windDirection" - ."$windDirectionSource$compassDirection" - ."$coneAngle$tilt" - ."$plumeHeight$plumeHeightSource" - ."$offset$plumeCentre" - ."$plumeEdge1$plumeEdge2" - ."$plumeCompleteness$geomError" - ."$spectrometerError$scatteringError" - ."$windError$nbValidScans"; - $texte = $texte.""; - $txt = "$date;$site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,u2l("$date;Code Site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans")); + } + elsif (($_ ne "") + && (($QryParm->{'site'} eq "All") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "All") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Old") && ($date lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "All") || ($QryParm->{'mois'} eq substr($date,5,2)))) { + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($editOK) { + $texte = $texte."$modif"; + } + $texte = $texte."$date$lien$flux1" + ."$flux2$windSpeed" + ."$windSpeedSource$windDirection" + ."$windDirectionSource$compassDirection" + ."$coneAngle$tilt" + ."$plumeHeight$plumeHeightSource" + ."$offset$plumeCentre" + ."$plumeEdge1$plumeEdge2" + ."$plumeCompleteness$geomError" + ."$spectrometerError$scatteringError" + ."$windError$nbValidScans"; + $texte = $texte.""; + $txt = "$date;$site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } + # ------------------------------------------------------------ # ---- end of specific NOVAC HTML code ----------------------- # ------------------------------------------------------------ @@ -339,7 +342,7 @@ =head1 Query string parameters

    \n"); if ($texte ne "") { - push(@html,"\n + push(@html,"\n \n $tableHeader\n $texte\n @@ -348,10 +351,10 @@ =head1 Query string parameters } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n + print @html; + print "\n \n diff --git a/CODE/cgi-bin/showOUTG.pl b/CODE/cgi-bin/showOUTG.pl index 51860986..8d8569e9 100755 --- a/CODE/cgi-bin/showOUTG.pl +++ b/CODE/cgi-bin/showOUTG.pl @@ -55,6 +55,7 @@ =head1 DESCRIPTION use Locale::TextDomain('webobs'); use POSIX qw/setlocale LC_ALL strftime/; + #use Encode; #my ($strftime_encoding)= setlocale(LC_ALL); #sub strftime2 { # try to return an utf8 value from strftime @@ -73,21 +74,20 @@ =head1 DESCRIPTION my $QryParm = $cgi->Vars; my @GID = split(/[\.\/]/, trim($QryParm->{'grid'})); - # ---- what grid do we have to process ? any showstoppers ? if (scalar(@GID) == 2) { - ($GRIDType, $GRIDName) = @GID; - if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } - elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } - if (%G) { - %GRID = %{$G{$GRIDName}} ; - if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"$GRIDName") || WebObs::Users::clientHasRead(type=>"authviews",name=>"$GRIDName") ) { - $RESOURCE = "authmisc/$GRIDName"; - if (-d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName" ) { - $OUTG = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName"; - } else { die "$__{'No outputs for'} $GRIDType.$GRIDName" } - } else { die "$__{'Not authorized'} $GRIDName (read)"} - } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } + ($GRIDType, $GRIDName) = @GID; + if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } + elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } + if (%G) { + %GRID = %{$G{$GRIDName}} ; + if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"$GRIDName") || WebObs::Users::clientHasRead(type=>"authviews",name=>"$GRIDName") ) { + $RESOURCE = "authmisc/$GRIDName"; + if (-d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName" ) { + $OUTG = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName"; + } else { die "$__{'No outputs for'} $GRIDType.$GRIDName" } + } else { die "$__{'Not authorized'} $GRIDName (read)"} + } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } } else { die "$__{'Not a valid GRID requested (NOT gridtype.gridname)'}" } # ---- good, passed all validity/authorization checkings above @@ -99,29 +99,32 @@ =head1 DESCRIPTION if ($GRIDType eq 'VIEW' && $QryParm->{'ts'} eq '') { $QryParm->{'ts'} = 'map' } if ($QryParm->{'g'} =~ s!^lastevent(\b|$)!!) { - # "^lastevent" was removed from 'g': - # replace it with the directory the 'lastevent' symlink links to. - my $lastevent_dir = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/lastevent"); - # Remove ^$OUTG/events/ from the path to only keep "yyyy/mm/dd/eventid" - my $OUTGabs = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}"); - $lastevent_dir =~ s!$OUTGabs/!!; - # Replace 'g' with this link and append the remaining of the original 'g', if any - # (so that both g=lastevent and g=lastevent/b3 work). - $QryParm->{'g'} = $lastevent_dir.$QryParm->{'g'}; + + # "^lastevent" was removed from 'g': + # replace it with the directory the 'lastevent' symlink links to. + my $lastevent_dir = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/lastevent"); + + # Remove ^$OUTG/events/ from the path to only keep "yyyy/mm/dd/eventid" + my $OUTGabs = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}"); + $lastevent_dir =~ s!$OUTGabs/!!; + +# Replace 'g' with this link and append the remaining of the original 'g', if any +# (so that both g=lastevent and g=lastevent/b3 work). + $QryParm->{'g'} = $lastevent_dir.$QryParm->{'g'}; } # ---- initialize 'timescales' definitions my %TIMESCALES = ( - xxx => 'Manual', - r => 'Reference', - all => 'All Data', - s => 'second', - h => 'hour', - d => 'day', - w => 'week', - m => 'month', - y => 'year', -); + xxx => 'Manual', + r => 'Reference', + all => 'All Data', + s => 'second', + h => 'hour', + d => 'day', + w => 'week', + m => 'month', + y => 'year', + ); # ---- get the list of nodes currently belonging to grid # ---- and the list of possible summary grid's summary filenames @@ -137,7 +140,7 @@ =head1 DESCRIPTION print ""; if ($QryParm->{'refresh'} gt 0) { - print "{'refresh'}\">"; + print "{'refresh'}\">"; } print ""; print ""; @@ -159,333 +162,337 @@ =head1 DESCRIPTION my $baseurl = "/cgi-bin/showOUTG.pl?grid=$GRIDType.$GRIDName&refresh=$QryParm->{'refresh'}&header=$QryParm->{'header'}"; print "
    "; - # build $tslist = the list of defined timescales for proc from proc's configuration file - # and $tsSelected = index of the one currently selected (defaults to first item of $tslist) - my @tslist = split(/,/, $GRID{TIMESCALELIST}); - my $tsSelected = 0 ; - my $tsHtml = ""; - for my $i (0..$#tslist) { - my $ts = $tslist[$i]; - my $tsName = $ts; - # for backward compatibility (replaces some of old "timescales.conf" definitions) - $ts =~ s/a$|an$|yr$/y/; - $ts =~ s/j$/d/; - my $n = 1*substr($ts,0,-1); - if ($n > 0) { - $tsName = "$n $TIMESCALES{substr($ts,-1)}".($n > 1 ? "s":""); - } elsif (substr($ts,0,1) eq "r") { - my $r = 1*substr($ts,1); - $tsName = "$TIMESCALES{r}".($r > 0 ? " $r":""); - } elsif (defined($TIMESCALES{$ts})) { - $tsName = $TIMESCALES{$ts}; - } - if ($QryParm->{'ts'} eq $tslist[$i] ) { - $tsSelected = $i; - $tsHtml .= " $tsName |"; - } else { - $tsHtml .= " {'g'}\">$tsName |"; - } - } - chop($tsHtml); - print "»» [ ".ucfirst(lc($GRIDType))." "; - if ($QryParm->{'ts'} eq 'map' ) { - print "| Map "; - } elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_MAPS}") { - print "| Map "; - } - if ($QryParm->{'ts'} eq 'events' ) { - print "| Events "; - } elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { - print "| Events "; - } - if (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { - (my $EVTurn = $OUTG) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - print "| All files "; - - # build @nlist = the list of available nodes in events/*/*/*/ subdirectories - my (@ilist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????/*/*/*"; - my @nlist; - foreach (sort(keys(%DefinedNodes))) { - if (grep(/$_/i,@ilist)) { - push(@nlist,$_); - if ($QryParm->{'g'} =~ /$_/) { - print "| $DefinedNodes{$_}{ALIAS} "; - } else { - print "| $DefinedNodes{$_}{ALIAS} "; - } - } - } - } - if ($#tslist >= 0 && -d "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}") { - print "| Time scales: $tsHtml "; - } - print " | ]\n"; - - # build @elist = the list of available .eps graphs for timescale $tslist[$tsSelected] - my (@elist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.eps"; - - # build @slist = the list of available .svg graphs for timescale $tslist[$tsSelected] - my (@slist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.svg"; - - # build @plist = the list of available .pdf graphs for timescale $tslist[$tsSelected] - my (@plist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.pdf"; - - # build @dlist = the list of available data/**.* for timescale $tslist[$tsSelected] - my (@dlist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_$tslist[$tsSelected]*.*"; - - # build @ylist = the list of available events/* years - my (@ylist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????"; - - - # build @glist = the list of available .png graphs for timescale $tslist[$tsSelected] - # $glistHtml is the corresponding string of html hrefs to these graphs - # with each nodenames replaced with their alias if it is defined - my (@glist) = sort glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.png"; - my $glistHtml = ""; - if ($QryParm->{'ts'} eq 'events' ) { - if ($QryParm->{'g'} eq "") { - $QryParm->{'g'} = $ylist[$#ylist]; - $QryParm->{'g'} =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; - } - foreach (@ylist) { - my $year = $_; - $year =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; - if ($QryParm->{'g'} eq $year) { - $glistHtml .= " $year |"; - } else { - $glistHtml .= " $year |"; - } - } - } else { - my $lnk = "$baseurl&ts=$tslist[$tsSelected]&g="; - $glistHtml .= " Overview | "; - $glistHtml .= ($QryParm->{'g'} ne "col" ? "Column":"Column")." |"; - for my $fpath (@glist) { - my $gname = $fpath; - $gname =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_$tslist[$tsSelected].*$/$1/; - $gname =~ s/^$/SUMMARY/; - my $gbase = $gname; - $gbase =~ s/(.*)_.*$/$1/; - my $gmenu = $gname; - if ($gname ne 'SUMMARY' && !(grep( /^$gbase$/i, @SummaryList)) ) { - if ( grep( /^$gname$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc - my $alias = getNodeString(node=>uc($gname), style=>'alias'); - $gmenu = $alias if ( $alias ne '' && $alias ne '-' ); - } else { # it's a node file, but node NOT currently in proc == stale node that survived the housekeeping above - $gmenu = 'STALE'; - } - } - if ( $gmenu ne 'STALE' ) { - if ($QryParm->{'g'} eq $gname) { - $glistHtml .= " $gmenu |"; - } else { - $glistHtml .= " $gmenu |"; - } - } - } - } - chop($glistHtml); - if ($QryParm->{'ts'} ne 'map' ) { - print "
    [ ".$glistHtml." ]\n"; - } + .($QryParm->{'header'} eq 'no' ? " display:none":"")."'>"; + +# build $tslist = the list of defined timescales for proc from proc's configuration file +# and $tsSelected = index of the one currently selected (defaults to first item of $tslist) +my @tslist = split(/,/, $GRID{TIMESCALELIST}); +my $tsSelected = 0 ; +my $tsHtml = ""; +for my $i (0..$#tslist) { + my $ts = $tslist[$i]; + my $tsName = $ts; + +# for backward compatibility (replaces some of old "timescales.conf" definitions) + $ts =~ s/a$|an$|yr$/y/; + $ts =~ s/j$/d/; + my $n = 1*substr($ts,0,-1); + if ($n > 0) { + $tsName = "$n $TIMESCALES{substr($ts,-1)}".($n > 1 ? "s":""); + } elsif (substr($ts,0,1) eq "r") { + my $r = 1*substr($ts,1); + $tsName = "$TIMESCALES{r}".($r > 0 ? " $r":""); + } elsif (defined($TIMESCALES{$ts})) { + $tsName = $TIMESCALES{$ts}; + } + if ($QryParm->{'ts'} eq $tslist[$i] ) { + $tsSelected = $i; + $tsHtml .= " $tsName |"; + } else { + $tsHtml .= " {'g'}\">$tsName |"; + } +} +chop($tsHtml); +print "»» [ ".ucfirst(lc($GRIDType))." "; +if ($QryParm->{'ts'} eq 'map' ) { + print "| Map "; +} elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_MAPS}") { + print "| Map "; +} +if ($QryParm->{'ts'} eq 'events' ) { + print "| Events "; +} elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { + print "| Events "; +} +if (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { + (my $EVTurn = $OUTG) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + print "| All files "; + + # build @nlist = the list of available nodes in events/*/*/*/ subdirectories + my (@ilist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????/*/*/*"; + my @nlist; + foreach (sort(keys(%DefinedNodes))) { + if (grep(/$_/i,@ilist)) { + push(@nlist,$_); + if ($QryParm->{'g'} =~ /$_/) { + print "| $DefinedNodes{$_}{ALIAS} "; + } else { + print "| $DefinedNodes{$_}{ALIAS} "; + } + } + } +} +if ($#tslist >= 0 && -d "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}") { + print "| Time scales: $tsHtml "; +} +print " | ]\n"; + +# build @elist = the list of available .eps graphs for timescale $tslist[$tsSelected] +my (@elist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.eps"; + +# build @slist = the list of available .svg graphs for timescale $tslist[$tsSelected] +my (@slist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.svg"; + +# build @plist = the list of available .pdf graphs for timescale $tslist[$tsSelected] +my (@plist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.pdf"; + +# build @dlist = the list of available data/**.* for timescale $tslist[$tsSelected] +my (@dlist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_$tslist[$tsSelected]*.*"; + +# build @ylist = the list of available events/* years +my (@ylist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????"; + +# build @glist = the list of available .png graphs for timescale $tslist[$tsSelected] +# $glistHtml is the corresponding string of html hrefs to these graphs +# with each nodenames replaced with their alias if it is defined +my (@glist) = sort glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.png"; +my $glistHtml = ""; +if ($QryParm->{'ts'} eq 'events' ) { + if ($QryParm->{'g'} eq "") { + $QryParm->{'g'} = $ylist[$#ylist]; + $QryParm->{'g'} =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; + } + foreach (@ylist) { + my $year = $_; + $year =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; + if ($QryParm->{'g'} eq $year) { + $glistHtml .= " $year |"; + } else { + $glistHtml .= " $year |"; + } + } +} else { + my $lnk = "$baseurl&ts=$tslist[$tsSelected]&g="; + $glistHtml .= " Overview | "; + $glistHtml .= ($QryParm->{'g'} ne "col" ? "Column":"Column")." |"; + for my $fpath (@glist) { + my $gname = $fpath; + $gname =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_$tslist[$tsSelected].*$/$1/; + $gname =~ s/^$/SUMMARY/; + my $gbase = $gname; + $gbase =~ s/(.*)_.*$/$1/; + my $gmenu = $gname; + if ($gname ne 'SUMMARY' && !(grep( /^$gbase$/i, @SummaryList)) ) { + if ( grep( /^$gname$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc + my $alias = getNodeString(node=>uc($gname), style=>'alias'); + $gmenu = $alias if ( $alias ne '' && $alias ne '-' ); + } else { # it's a node file, but node NOT currently in proc == stale node that survived the housekeeping above + $gmenu = 'STALE'; + } + } + if ( $gmenu ne 'STALE' ) { + if ($QryParm->{'g'} eq $gname) { + $glistHtml .= " $gmenu |"; + } else { + $glistHtml .= " $gmenu |"; + } + } + } +} +chop($glistHtml); +if ($QryParm->{'ts'} ne 'map' ) { + print "
    [ ".$glistHtml." ]\n"; +} print "
    "; print "
    ".qrcode(2)."
    \n"; - # ---- now show the selected item # -- case 'Map' if ($QryParm->{'ts'} eq 'map') { - # only 1 map : *.png and its corresponding *.map - my $MAPpath = my $MAPurn = ""; - my @htmlarea; - $MAPpath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_MAPS}"; - ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - - my $mapname = "$GRIDType.$GRIDName"."_map"; - if ( -e "$MAPpath/$mapname.eps" ) { - print "\"$mapname.eps\"
    \n"; - } - if ( -e "$MAPpath/$mapname.png" ) { - print "
    \n"; - if (-e "$MAPpath/$mapname.map") { - @htmlarea = readFile("$MAPpath/$mapname.map"); - print "\n@htmlarea\n"; - } - } - -# -- case 'Events' + # only 1 map : *.png and its corresponding *.map + my $MAPpath = my $MAPurn = ""; + my @htmlarea; + $MAPpath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_MAPS}"; + ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + + my $mapname = "$GRIDType.$GRIDName"."_map"; + if ( -e "$MAPpath/$mapname.eps" ) { + print "\"$mapname.eps\"
    \n"; + } + if ( -e "$MAPpath/$mapname.png" ) { + print "
    \n"; + if (-e "$MAPpath/$mapname.map") { + @htmlarea = readFile("$MAPpath/$mapname.map"); + print "\n@htmlarea\n"; + } + } + + # -- case 'Events' } elsif ($QryParm->{'ts'} eq 'events') { - # this lists files using complementary wildcards from g= YYYY[/MM[/DD[/EVENTID[/EVENTNAME]]]] - (my $depth = $QryParm->{'g'}) =~ s/[^\/]//g; - $depth = length($depth); # $depth is number of "/" in the g= argument - - # lists all files - @plist = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/$QryParm->{'g'}".("/*" x (4 - $depth)).".jpg"; - - # target directory contains multiple files: displays existing thumbnails - if ($#plist > 1) { - my $month0 = ""; - for (@plist) { - if ( ($depth < 3 && -l $_) || ($depth == 3 && ! -l $_)) { - (my $JPGurn = $_) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - (my $EVENTid = $_) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; - if (-l $_) { - my $lnk = basename($_); - my $tgt = readlink($_); - $EVENTid =~ s/$lnk/$tgt/g; - } - $EVENTid =~ s/\.jpg//g; - (my @evt) = split(/\//,$EVENTid); - my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); - my $month = l2u(strftime("%B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); - my $msg = "ID: $evt[3]
    $evt[4]"; - if ($depth == 3 && $QryParm->{'g'} !~ m/\*/ && $month ne $month0) { - print "

    $dte: $evt[3]

    \n"; - $month0 = $month; - } elsif ($month ne $month0) { - print "

    $month

    \n"; - $month0 = $month; - } - my $thumb = ""; - if ($WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT} > 0) { - $thumb = "; height:$WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT}px"; - } - my $target = $EVENTid; - if ($depth < 3) { - $target = join("/",@evt[0..3]); - } - print "", - "\n"; - } - } - # single file: displays .png (or .jpg) and links to other files (.eps,.pdf,.gse,.txt) - } else { - my $addlinks = ""; - (my $short = $plist[0]) =~ s/\.jpg//g; - (my $urn = $short) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - (my $EVENTid = $short) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; - (my @evt) = split(/\//,$EVENTid); - my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); - foreach ("eps","svg","pdf","gse","txt","kml") { - if ( -e "$short.$_" ) { - $addlinks .= " \"$urn.$_\" "; - } - } - # special case of .msg file (tremblemaps) - if ( -e "$short.msg" ) { - $addlinks .= " {'grid'}&ts=events&g=$EVENTid\">" - ."\"$urn.msg\" "; - } - print "

    $dte: $evt[3] / $evt[4]

    \n"; - print "$addlinks
    " if ($QryParm->{'header'} ne 'no'); - my $img = "$urn.png"; - if ( ! -f "$short.png" ) { - $img = "$urn.jpg"; - } - print "
    "; - } - -# -- case 'Timescales' +# this lists files using complementary wildcards from g= YYYY[/MM[/DD[/EVENTID[/EVENTNAME]]]] + (my $depth = $QryParm->{'g'}) =~ s/[^\/]//g; + $depth = length($depth); # $depth is number of "/" in the g= argument + + # lists all files + @plist = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/$QryParm->{'g'}".("/*" x (4 - $depth)).".jpg"; + + # target directory contains multiple files: displays existing thumbnails + if ($#plist > 1) { + my $month0 = ""; + for (@plist) { + if ( ($depth < 3 && -l $_) || ($depth == 3 && ! -l $_)) { + (my $JPGurn = $_) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + (my $EVENTid = $_) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; + if (-l $_) { + my $lnk = basename($_); + my $tgt = readlink($_); + $EVENTid =~ s/$lnk/$tgt/g; + } + $EVENTid =~ s/\.jpg//g; + (my @evt) = split(/\//,$EVENTid); + my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); + my $month = l2u(strftime("%B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); + my $msg = "ID: $evt[3]
    $evt[4]"; + if ($depth == 3 && $QryParm->{'g'} !~ m/\*/ && $month ne $month0) { + print "

    $dte: $evt[3]

    \n"; + $month0 = $month; + } elsif ($month ne $month0) { + print "

    $month

    \n"; + $month0 = $month; + } + my $thumb = ""; + if ($WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT} > 0) { + $thumb = "; height:$WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT}px"; + } + my $target = $EVENTid; + if ($depth < 3) { + $target = join("/",@evt[0..3]); + } + print "", + "\n"; + } + } + +# single file: displays .png (or .jpg) and links to other files (.eps,.pdf,.gse,.txt) + } else { + my $addlinks = ""; + (my $short = $plist[0]) =~ s/\.jpg//g; + (my $urn = $short) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + (my $EVENTid = $short) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; + (my @evt) = split(/\//,$EVENTid); + my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); + foreach ("eps","svg","pdf","gse","txt","kml") { + if ( -e "$short.$_" ) { + $addlinks .= " \"$urn.$_\" "; + } + } + + # special case of .msg file (tremblemaps) + if ( -e "$short.msg" ) { + $addlinks .= " {'grid'}&ts=events&g=$EVENTid\">" + ."\"$urn.msg\" "; + } + print "

    $dte: $evt[3] / $evt[4]

    \n"; + print "$addlinks
    " if ($QryParm->{'header'} ne 'no'); + my $img = "$urn.png"; + if ( ! -f "$short.png" ) { + $img = "$urn.jpg"; + } + print "
    "; + } + + # -- case 'Timescales' } else { - # i.e "only display requested g= in query-string" - # if none requested in query-string, show thumbnails of all available graphs - if ($QryParm->{'g'} eq "") { - - for my $g (@glist) { - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $urn =~ s/\.png$/\.jpg/; - (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $short =~ s/^$/SUMMARY/; - print " "; - } - - # if g=col in query-string, show all available graphs in one column - } elsif ($QryParm->{'g'} eq "col") { - - for my $g (@glist) { - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $short =~ s/^$/SUMMARY/; - print "
    "; - } - - - } else { - # prepare additional links to eps, svg, pdf and data - my $addlinks = ""; - for my $i (0..$#elist) { - if (-f $elist[$i]) { - (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $elist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $elist[$i] =~ s/^$/$GRIDName/; - if ($elist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; - } - } - } - for my $i (0..$#slist) { - if (-f $slist[$i]) { - (my $surn = $slist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $slist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $slist[$i] =~ s/^$/$GRIDName/; - if ($slist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.svg\" src=\"/icons/fsvg.png\"> "; - } - } - } - for my $i (0..$#plist) { - if (-f $plist[$i]) { - (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $plist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $plist[$i] =~ s/^$/$GRIDName/; - if ($plist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; - } - } - } - for my $i (0..$#dlist) { - if (-f $dlist[$i]) { - (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $dlist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; - $dlist[$i] =~ s/^$/$GRIDName/; - ##if ($dlist[$i] eq $QryParm->{'g'}) { - if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { - $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; - } - } - } - # if a FORM is associated to the PROC, adds a link to the database interface - if ($GRID{FORM} ne '') { - my $FORM = new WebObs::Form($GRID{FORM}); - my $opt = ($QryParm->{'g'} eq $GRIDName ? "{$GRIDName}":uc($QryParm->{'g'})); - $addlinks .= "conf('CGI_SHOW')."?node=$opt\">\"\" "; - } - - if ( $QryParm->{'g'} ne $GRIDName && !(grep( /^$QryParm->{'g'}$/i, @SummaryList)) && $QryParm->{'g'} eq lc($QryParm->{'g'}) ) { - my $ucg = uc($QryParm->{'g'}); - $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; - } - # finally plots the image ! - for my $g (@glist) { - (my $map = $g) =~ s/\.png/\.map/; - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $g =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $g =~ s/^$/SUMMARY/; - if ($g eq $QryParm->{'g'}) { - print "$addlinks
    " if ($QryParm->{'header'} ne 'no'); - print "
    "; - if (-e "$map") { - my @htmlarea = readFile("$map"); - print "\n@htmlarea\n"; - } - } - } - } + # i.e "only display requested g= in query-string" + # if none requested in query-string, show thumbnails of all available graphs + if ($QryParm->{'g'} eq "") { + + for my $g (@glist) { + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $urn =~ s/\.png$/\.jpg/; + (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $short =~ s/^$/SUMMARY/; + print " "; + } + + # if g=col in query-string, show all available graphs in one column + } elsif ($QryParm->{'g'} eq "col") { + + for my $g (@glist) { + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $short =~ s/^$/SUMMARY/; + print "
    "; + } + + } else { + + # prepare additional links to eps, svg, pdf and data + my $addlinks = ""; + for my $i (0..$#elist) { + if (-f $elist[$i]) { + (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $elist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $elist[$i] =~ s/^$/$GRIDName/; + if ($elist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; + } + } + } + for my $i (0..$#slist) { + if (-f $slist[$i]) { + (my $surn = $slist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $slist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $slist[$i] =~ s/^$/$GRIDName/; + if ($slist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.svg\" src=\"/icons/fsvg.png\"> "; + } + } + } + for my $i (0..$#plist) { + if (-f $plist[$i]) { + (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $plist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $plist[$i] =~ s/^$/$GRIDName/; + if ($plist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; + } + } + } + for my $i (0..$#dlist) { + if (-f $dlist[$i]) { + (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $dlist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; + $dlist[$i] =~ s/^$/$GRIDName/; + ##if ($dlist[$i] eq $QryParm->{'g'}) { + if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { + $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; + } + } + } + + # if a FORM is associated to the PROC, adds a link to the database interface + if ($GRID{FORM} ne '') { + my $FORM = new WebObs::Form($GRID{FORM}); + my $opt = ($QryParm->{'g'} eq $GRIDName ? "{$GRIDName}":uc($QryParm->{'g'})); + $addlinks .= "conf('CGI_SHOW')."?node=$opt\">\"\" "; + } + + if ( $QryParm->{'g'} ne $GRIDName && !(grep( /^$QryParm->{'g'}$/i, @SummaryList)) && $QryParm->{'g'} eq lc($QryParm->{'g'}) ) { + my $ucg = uc($QryParm->{'g'}); + $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; + } + + # finally plots the image ! + for my $g (@glist) { + (my $map = $g) =~ s/\.png/\.map/; + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $g =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $g =~ s/^$/SUMMARY/; + if ($g eq $QryParm->{'g'}) { + print "$addlinks
    " if ($QryParm->{'header'} ne 'no'); + print "
    "; + if (-e "$map") { + my @htmlarea = readFile("$map"); + print "\n@htmlarea\n"; + } + } + } + } } print "
    $go2top
    "; @@ -493,18 +500,19 @@ =head1 DESCRIPTION print "\n\n"; sub outgHouseKeeping { - # %DefinedNodes and @SummaryList must have been built - if ( defined($WEBOBS{OUTG_STALENODES_DISPO}) ) { - my @objects = ( glob("$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_*.eps"), glob("$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_*.*") ); - for my $object (@objects) { - my $prefix = basename($object); $prefix =~ /(.*)_.*/; $prefix = $1; - if ( $WEBOBS{OUTG_STALENODES_DISPO} eq 'DELETE' && ($prefix ne "" || !defined($GRID{SUMMARYLIST})) && $prefix ne $GRIDName ) { - if ( !(grep( /^$prefix$/i, keys(%DefinedNodes))) && !(grep( /^$prefix$/i, @SummaryList)) ) { - qx(rm $object); - } - } - } - } + + # %DefinedNodes and @SummaryList must have been built + if ( defined($WEBOBS{OUTG_STALENODES_DISPO}) ) { + my @objects = ( glob("$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_*.eps"), glob("$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_*.*") ); + for my $object (@objects) { + my $prefix = basename($object); $prefix =~ /(.*)_.*/; $prefix = $1; + if ( $WEBOBS{OUTG_STALENODES_DISPO} eq 'DELETE' && ($prefix ne "" || !defined($GRID{SUMMARYLIST})) && $prefix ne $GRIDName ) { + if ( !(grep( /^$prefix$/i, keys(%DefinedNodes))) && !(grep( /^$prefix$/i, @SummaryList)) ) { + qx(rm $object); + } + } + } + } } __END__ diff --git a/CODE/cgi-bin/showOUTR.pl b/CODE/cgi-bin/showOUTR.pl index b933b118..cbee4313 100755 --- a/CODE/cgi-bin/showOUTR.pl +++ b/CODE/cgi-bin/showOUTR.pl @@ -49,23 +49,23 @@ =head1 DESCRIPTION # ---- check authorization: request owner or administrator if ($user ne $CLIENT && !clientHasAdm(type=>"authprocs",name=>"*")) { - die "Sorry, you're not the owner of this proc request."; + die "Sorry, you're not the owner of this proc request."; } # ---- what grids do we have to process ? my @GL = qx(find $WEBOBS{ROOT_OUTR}/$OUTDIR -type d \\( -name "PROC.*" -o -name "VIEW.*" -o -name "GRIDMAPS" \\) -maxdepth 1); chomp(@GL); foreach (@GL) { - my $g = $_; - $g =~ s/$WEBOBS{ROOT_OUTR}\/$OUTDIR\///; - push(@GRIDList,$g); + my $g = $_; + $g =~ s/$WEBOBS{ROOT_OUTR}\/$OUTDIR\///; + push(@GRIDList,$g); } $QryParm->{'g'} ||= ''; $QryParm->{'grid'} ||= $GRIDList[0]; ($GRIDType, $GRIDName) = split(/[\.\/]/, trim($QryParm->{'grid'})); if (-d "$WEBOBS{ROOT_OUTR}/$OUTDIR/$GRIDType.$GRIDName" ) { - $OUTR = "$WEBOBS{ROOT_OUTR}/$OUTDIR/$GRIDType.$GRIDName"; + $OUTR = "$WEBOBS{ROOT_OUTR}/$OUTDIR/$GRIDType.$GRIDName"; } else { die "$__{'No outputs for'} $GRIDType.$GRIDName" } if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } @@ -95,54 +95,53 @@ =head1 DESCRIPTION print "

    $GRID{NAME}

    \n"; my $go2top = ""; - # ---- build the top-of-page outputs selection banner: # 1st line for GRID selection # 2nd line for output selection print "
    "; - print "»» [ ".ucfirst(lc($GRIDType)).""; - foreach (@GRIDList) { - if ($QryParm->{'grid'} eq $_ ) { - print " | $_"; - } else { - print " | {'dir'}&grid=$_\">$_"; - } - } - print " ]\n"; - - # build $elist = the list of available .eps graphs - my (@elist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.eps"; - - # build $plist = the list of available .pdf graphs - my (@plist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.pdf"; - - # build $dlist = the list of available data/**.* for timescale $tslist[$tsSelected] - my (@dlist) = glob "$OUTR/$WEBOBS{PATH_OUTG_EXPORT}/*_.*"; - - # build $glist = the list of available .png graphs for timescale $tslist[$tsSelected] - # $glistHtml is the corresponding string of html hrefs to these graphs - # with each nodenames replaced with their alias if it is defined - my (@glist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.png"; - my $glistHtml = ""; - for my $fpath (@glist) { - my $short = $fpath; - $short =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $short =~ s/^$/$GRIDName/; - my $shorter = ($short eq $GRIDName ? "Summary":$short); - if ($short ne $GRIDName && !(grep( /^$short$/i, @SummaryList)) ) { - if ( grep( /^$short$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc - my $alias = getNodeString(node=>uc($short), style=>'alias'); - $shorter = $alias if ( $alias ne '' && $alias ne '-' ); - } - } - if ($QryParm->{'g'} eq $short) { - $glistHtml .= " $shorter |"; - } else { - $glistHtml .= " {'dir'}&grid=$GRIDType.$GRIDName&g=$short\"> $shorter |"; - } - } - chop($glistHtml); - print "
    [ ".$glistHtml." ]\n"; +print "»» [ ".ucfirst(lc($GRIDType)).""; +foreach (@GRIDList) { + if ($QryParm->{'grid'} eq $_ ) { + print " | $_"; + } else { + print " | {'dir'}&grid=$_\">$_"; + } +} +print " ]\n"; + +# build $elist = the list of available .eps graphs +my (@elist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.eps"; + +# build $plist = the list of available .pdf graphs +my (@plist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.pdf"; + +# build $dlist = the list of available data/**.* for timescale $tslist[$tsSelected] +my (@dlist) = glob "$OUTR/$WEBOBS{PATH_OUTG_EXPORT}/*_.*"; + +# build $glist = the list of available .png graphs for timescale $tslist[$tsSelected] +# $glistHtml is the corresponding string of html hrefs to these graphs +# with each nodenames replaced with their alias if it is defined +my (@glist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.png"; +my $glistHtml = ""; +for my $fpath (@glist) { + my $short = $fpath; + $short =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $short =~ s/^$/$GRIDName/; + my $shorter = ($short eq $GRIDName ? "Summary":$short); + if ($short ne $GRIDName && !(grep( /^$short$/i, @SummaryList)) ) { + if ( grep( /^$short$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc + my $alias = getNodeString(node=>uc($short), style=>'alias'); + $shorter = $alias if ( $alias ne '' && $alias ne '-' ); + } + } + if ($QryParm->{'g'} eq $short) { + $glistHtml .= " $shorter |"; + } else { + $glistHtml .= " {'dir'}&grid=$GRIDType.$GRIDName&g=$short\"> $shorter |"; + } +} +chop($glistHtml); +print "
    [ ".$glistHtml." ]\n"; print "
    "; # ---- now show the selected item @@ -150,60 +149,61 @@ =head1 DESCRIPTION # i.e "only display requested g= in query-string" # if none requested in query-string, use the first item of $glist if ($QryParm->{'g'} eq "") { - $QryParm->{'g'} = $glist[0]; - $QryParm->{'g'} =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $QryParm->{'g'} =~ s/^$/$GRIDName/; + $QryParm->{'g'} = $glist[0]; + $QryParm->{'g'} =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $QryParm->{'g'} =~ s/^$/$GRIDName/; } + # prepare additional links to eps, pdf and data my $addlinks = ""; for my $i (0..$#elist) { - if (-f $elist[$i]) { - (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $elist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $elist[$i] =~ s/^$/$GRIDName/; - if ($elist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; - } - } + if (-f $elist[$i]) { + (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $elist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $elist[$i] =~ s/^$/$GRIDName/; + if ($elist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; + } + } } for my $i (0..$#plist) { - if (-f $plist[$i]) { - (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $plist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $plist[$i] =~ s/^$/$GRIDName/; - if ($plist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; - } - } + if (-f $plist[$i]) { + (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $plist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $plist[$i] =~ s/^$/$GRIDName/; + if ($plist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; + } + } } for my $i (0..$#dlist) { - if (-f $dlist[$i]) { - (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $dlist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; - $dlist[$i] =~ s/^$/$GRIDName/; - ##if ($dlist[$i] eq $QryParm->{'g'}) { - if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { - $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; - } - } + if (-f $dlist[$i]) { + (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $dlist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; + $dlist[$i] =~ s/^$/$GRIDName/; + ##if ($dlist[$i] eq $QryParm->{'g'}) { + if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { + $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; + } + } } if ($QryParm->{'g'} ne $GRIDName && !(grep( /^$QryParm->{'g'}$/i, @SummaryList)) ) { - my $ucg = uc($QryParm->{'g'}); - $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; + my $ucg = uc($QryParm->{'g'}); + $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; } for my $g (@glist) { - (my $map = $g) =~ s/\.png/\.map/; - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $g =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $g =~ s/^$/$GRIDName/; - if ($g eq $QryParm->{'g'}) { - print "$addlinks
    "; - print "
    "; - if (-e "$map") { - my @htmlarea = readFile("$map"); - print "@htmlarea\n"; - } - } + (my $map = $g) =~ s/\.png/\.map/; + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $g =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $g =~ s/^$/$GRIDName/; + if ($g eq $QryParm->{'g'}) { + print "$addlinks
    "; + print "
    "; + if (-e "$map") { + my @htmlarea = readFile("$map"); + print "@htmlarea\n"; + } + } } print "
    $go2top
    "; @@ -211,7 +211,6 @@ =head1 DESCRIPTION # ---- We're done ! print "\n\n"; - __END__ =pod diff --git a/CODE/cgi-bin/showPLUVIO.pl b/CODE/cgi-bin/showPLUVIO.pl index fb68c80e..18307b9e 100755 --- a/CODE/cgi-bin/showPLUVIO.pl +++ b/CODE/cgi-bin/showPLUVIO.pl @@ -86,20 +86,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -126,12 +126,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamSite; @@ -140,19 +140,19 @@ =head1 Query string parameters my @option = (); my $msgFinal; -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "Tout"; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "Tout"; $QryParm->{'site'} ||= "Tout"; -$QryParm->{'affiche'} ||= ""; +$QryParm->{'affiche'} ||= ""; # ---- a site requested as {name} means "all nodes for grid (proc) 'name'" # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -161,63 +161,63 @@ =head1 Query string parameters # ---- start html if not CSV output - if ($affiche ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "$titrePage\n", - "", - "\n"; - - print "\n", - "\n", - "
    Recherche des données, merci de patienter.
    ", - "
    \n", - "\n", - "\n"; +if ($affiche ne "csv") { + print $cgi->header(-charset=>'utf-8'); + print "\n", + "$titrePage\n", + "", + "\n"; + + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "
    \n", + "\n", + "\n"; } # Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'affiche'} ne "csv") { - print("
    conf('CGI_SHOW')."\" method=\"get\">", - "

    ", - "Sélectionner: \n", - "\n", - "", - " "); - if ($displayOnly ne 1) { - print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); - } - print "

    \n", - "

    $titrePage

    \n", - "

    Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
    ", - "Sites sélectionnés: $afficheSite
    "; + print("

    conf('CGI_SHOW')."\" method=\"get\">", + "

    ", + "Sélectionner: \n", + "\n", + "", + " "); + if ($displayOnly ne 1) { + print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + } + print "

    \n", + "

    $titrePage

    \n", + "

    Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
    ", + "Sites sélectionnés: $afficheSite
    "; } # ---- Lecture du fichier de données dans tableau @lignes @@ -237,16 +237,16 @@ =head1 Query string parameters $entete = ""; if ($displayOnly ne 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."Année" - ."Mois" - ."Site" - ."Pluviométrie journalière (en mm)" - ."Cumul
    (mm)" - ."\n"; + ."Mois" + ."Site" + ."Pluviométrie journalière (en mm)" + ."Cumul
    (mm)" + ."\n"; for ("01".."31") { - $entete = $entete."$_"; + $entete = $entete."$_"; } $entete = $entete."\n"; @@ -254,77 +254,77 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,$_); - my $sc = ""; - my $cm = 0; - if ($i eq 0) { - push(@csv,u2l("$aa;$mm;Code Site;$site;$d01;$d02;$d03;$d04;$d05;$d06;$d07;$d08;$d09;$d10;$d11;$d12;$d13;$d14;$d15;$d16;$d17;$d18;$d19;$d20;$d21;$d22;$d23;$d24;$d25;$d26;$d27;$d28;$d29;$d30;$d31;$val")); - } - elsif (($_ ne "") - && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} == $aa) || (($QryParm->{'annee'} eq "Ancien") && ($aa lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} == $mm))) { - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($displayOnly ne 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$aa" - ."$nomMois[$mm-1]" - ."$lien"; - $txt = "$aa;$mm;$site;$aliasSite"; - for ("01".."31") { - my $dd = eval("\$d$_"); - my $vv = eval("\$v$_"); - my $ss = ""; - $cm += $dd; - if ($dd ne "") { $dd = sprintf("%0.1f",$dd); } - if ($vv == 2) { - $ss = "style=\"background-color:#FFAAAA\" onMouseOut=\"nd()\" onMouseOver=\"overlib('Donnée douteuse')\""; - } - if (($vv == 3) || ($sc ne "")) { - if ($sc eq "") { $sc = "Cumul depuis le $_ $nomMois[$mm-1] $aa"; }; - $ss = "style=\"background-color:#AAAAFF\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$sc')\""; - } - if ($vv == 4) { - $ss = ""; - $sc = ""; - } - $texte = $texte."$dd"; - $txt = $txt.";".eval("\$d$_"); - } - $texte = $texte."$cm\n"; - $txt = $txt."\n"; - push(@csv,$txt); - - $nbLignesRetenues++; - } - $i++; + my ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,$_); + my $sc = ""; + my $cm = 0; + if ($i eq 0) { + push(@csv,u2l("$aa;$mm;Code Site;$site;$d01;$d02;$d03;$d04;$d05;$d06;$d07;$d08;$d09;$d10;$d11;$d12;$d13;$d14;$d15;$d16;$d17;$d18;$d19;$d20;$d21;$d22;$d23;$d24;$d25;$d26;$d27;$d28;$d29;$d30;$d31;$val")); + } + elsif (($_ ne "") + && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} == $aa) || (($QryParm->{'annee'} eq "Ancien") && ($aa lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} == $mm))) { + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($displayOnly ne 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$aa" + ."$nomMois[$mm-1]" + ."$lien"; + $txt = "$aa;$mm;$site;$aliasSite"; + for ("01".."31") { + my $dd = eval("\$d$_"); + my $vv = eval("\$v$_"); + my $ss = ""; + $cm += $dd; + if ($dd ne "") { $dd = sprintf("%0.1f",$dd); } + if ($vv == 2) { + $ss = "style=\"background-color:#FFAAAA\" onMouseOut=\"nd()\" onMouseOver=\"overlib('Donnée douteuse')\""; + } + if (($vv == 3) || ($sc ne "")) { + if ($sc eq "") { $sc = "Cumul depuis le $_ $nomMois[$mm-1] $aa"; }; + $ss = "style=\"background-color:#AAAAFF\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$sc')\""; + } + if ($vv == 4) { + $ss = ""; + $sc = ""; + } + $texte = $texte."$dd"; + $txt = $txt.";".eval("\$d$_"); + } + $texte = $texte."$cm\n"; + $txt = $txt."\n"; + push(@csv,$txt); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

    \n", - "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

    \n"); + "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
    \n"); + push(@html,"$entete\n$texte\n$entete\n
    \n"); } # Time to display (or download csv) # if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/showQRcode.pl b/CODE/cgi-bin/showQRcode.pl index 9d4e6959..c1f634c5 100755 --- a/CODE/cgi-bin/showQRcode.pl +++ b/CODE/cgi-bin/showQRcode.pl @@ -37,7 +37,7 @@ =head1 Parameters # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $title = "$ENV{HTTP_REFERER}"; @@ -67,7 +67,7 @@ =head1 Parameters END for (@logos) { - print "

    "; + print "

    "; } print "\n\n\n"; diff --git a/CODE/cgi-bin/showRAINWATER.pl b/CODE/cgi-bin/showRAINWATER.pl index 201bc7c8..1e7f1a12 100755 --- a/CODE/cgi-bin/showRAINWATER.pl +++ b/CODE/cgi-bin/showRAINWATER.pl @@ -115,13 +115,13 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (sort keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -179,22 +179,22 @@ =head1 Query string parameters $i = 0; for (@ratios) { - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } - $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } + $i++; } # ---- a site requested as {name} means "all nodes for proc 'name'" # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -204,13 +204,13 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'dump'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print qq( + print $cgi->header(-charset=>'utf-8'); + print qq( ).$FORM->conf('TITLE').qq( ); - print qq( + print qq(
    $__{'Searching for the data... please wait'}.
    @@ -221,65 +221,65 @@ =head1 Query string parameters # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'dump'} ne "csv") { - print "
    conf('CGI_SHOW')."\" method=\"get\">", - ""; + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('return_url' => $return_url); + print qq(); + } + print qq(
    ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "   + print "conf('CGI_SHOW')."\" method=\"get\">", + ""; - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('return_url' => $return_url); - print qq(); - } - print qq(
    ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "       + for (@cleParamUnite) { + my ($val,$cle) = split (/\|/,$_); + if ("$val" eq "$QryParm->{'unit'}") { print qq(\n); } + else { print qq(\n); } + } + print qq(   
      \n$__{'Ratios'}:); - $i = 0; - for (@ratios) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print qq($nhtm/$dhtm  ); - $i++; - } - print "
    + $i = 0; + for (@ratios) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print qq($nhtm/$dhtm  ); + $i++; + } + print "

    ).$FORM->conf('TITLE').qq(

    \n); } @@ -300,39 +300,39 @@ =head1 Query string parameters $header = ""; if ($clientAuth > 1) { - $header = $header.""; + $header = $header.""; } $header = $header."Sampling Time Collection" - ."Site" - ."Rainfall" - ."Laboratory Meas." - ."Cations ($unit)" - ."Anions ($unit)" - ."Isotopes (‰)" - ."NICB
    (%)" - .($nbRap > 0 ? " Ratios":"") - ."\n" - ."Start
    Date & TimeEnd
    Date & TimeDays" - ."Cum.
    (mm)Avr.
    (mm/day)" - ."pH" - ."Cond.
    (µS)" - ."Na+" - ."K+" - ."Mg++" - ."Ca++" - ."HCO3-" - ."Cl-" - ."SO4--" - ."δDδ18O"; + ."Site" + ."Rainfall" + ."Laboratory Meas." + ."Cations ($unit)" + ."Anions ($unit)" + ."Isotopes (‰)" + ."NICB
    (%)" + .($nbRap > 0 ? " Ratios":"") + ."\n" + ."Start
    Date & TimeEnd
    Date & TimeDays" + ."Cum.
    (mm)Avr.
    (mm/day)" + ."pH" + ."Cond.
    (µS)" + ."Na+" + ."K+" + ."Mg++" + ."Ca++" + ."HCO3-" + ."Cl-" + ."SO4--" + ."δDδ18O"; $i = 0; for (@ratios) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - if ($rap[$i] == 1) { - $header = $header."" - ."" - ."
    $nhtm
    $dthm
    "; - } - $i++; + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + if ($rap[$i] == 1) { + $header = $header."" + ."" + ."
    $nhtm
    $dthm
    "; + } + $i++; } $header = $header."\n"; @@ -340,138 +340,138 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for (@lines) { - my ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$volume;$diameter;Total Rain (mm);Daily Rain (mm/day);$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;$dD;$d18O;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) - && ($id > 0 || $clientAuth == 4) - && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span - - my ($y,$m,$d) = split(/-/,$date1); - my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); - my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my ($y,$m,$d) = split(/-/,$date2); - my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); - my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my $dur = $d1->delta_days($d2)->delta_days; - my $total_rain = ""; - my $daily_rain = ""; - my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cSO4_mmol,$cHCO3_mmol); - $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cSO4_mmol=$cHCO3_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; - my $nicb = ""; - my @rapv; - my $rapport = ""; - - if ($volume gt 0 && $diameter gt 0) { - $total_rain = 10*$volume/(pi()*($diameter/2)**2); - $daily_rain = $total_rain/$dur if ($dur > 0); - } - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; - if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - my $iv = 0; - for (@ratios) { - if ($rap[$iv] == 1) { - my ($num,$den,$nrp) = split(/\|/,$_); - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - $rapport = $rapport."$rapv[$iv]"; - } - $iv++; - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { - $lien = "$aliasSite"; - } - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('id' => $id, 'return_url' => $return_url); - $modif = qq(); - $efface = qq(); - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$date1 $time1$date2 $time2$dur$lien" - ."".sprintf("%0.1f",$total_rain)."".sprintf("%0.1f",$daily_rain)."" - ."$pH$cond"; - $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$volume;$diameter;" - .sprintf("%0.1f",$total_rain).";".sprintf("%0.1f",$daily_rain).";$pH;$cond;"; - if ($QryParm->{'unit'} eq "mmol") { - for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { - $texte .= ""; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= ""; - } - $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol;"; - } else { - $texte .= "$cNa$cK$cMg$cCa" - ."$cHCO3$cCl$cSO4"; - $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;"; - } - if ($QryParm->{'isotopes'} ne "") { - $texte .= "$dD$d18O"; - } - if ($nicb and ($nicb < -20) || ($nicb > 20)) { - $texte .= ""; - } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= "$rapport"; - $txt = $txt."$dD;$d18O;".sprintf("%0.1f",$nicb).";\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$volume;$diameter;Total Rain (mm);Daily Rain (mm/day);$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;$dD;$d18O;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) + && ($id > 0 || $clientAuth == 4) + && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span + + my ($y,$m,$d) = split(/-/,$date1); + my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); + my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my ($y,$m,$d) = split(/-/,$date2); + my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); + my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my $dur = $d1->delta_days($d2)->delta_days; + my $total_rain = ""; + my $daily_rain = ""; + my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cSO4_mmol,$cHCO3_mmol); + $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cSO4_mmol=$cHCO3_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + my $nicb = ""; + my @rapv; + my $rapport = ""; + + if ($volume gt 0 && $diameter gt 0) { + $total_rain = 10*$volume/(pi()*($diameter/2)**2); + $daily_rain = $total_rain/$dur if ($dur > 0); + } + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + my $iv = 0; + for (@ratios) { + if ($rap[$iv] == 1) { + my ($num,$den,$nrp) = split(/\|/,$_); + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + $rapport = $rapport."$rapv[$iv]"; + } + $iv++; + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { + $lien = "$aliasSite"; + } + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('id' => $id, 'return_url' => $return_url); + $modif = qq(); + $efface = qq(); + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$date1 $time1$date2 $time2$dur$lien" + ."".sprintf("%0.1f",$total_rain)."".sprintf("%0.1f",$daily_rain)."" + ."$pH$cond"; + $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$volume;$diameter;" + .sprintf("%0.1f",$total_rain).";".sprintf("%0.1f",$daily_rain).";$pH;$cond;"; + if ($QryParm->{'unit'} eq "mmol") { + for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { + $texte .= ""; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= ""; + } + $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol;"; + } else { + $texte .= "$cNa$cK$cMg$cCa" + ."$cHCO3$cCl$cSO4"; + $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;"; + } + if ($QryParm->{'isotopes'} ne "") { + $texte .= "$dD$d18O"; + } + if ($nicb and ($nicb < -20) || ($nicb > 20)) { + $texte .= ""; + } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= "$rapport"; + $txt = $txt."$dD;$d18O;".sprintf("%0.1f",$nicb).";\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"$__{'Number of records'} = $nbLignesRetenues / $nbData.

    \n", - "

    $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

    \n"); + "

    $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"$header\n$texte\n$header\n
    "); - push(@html,"

    "); + push(@html,"$header\n$texte\n$header\n
    "); + push(@html,"

    "); } push(@html,@notes); if ($QryParm->{'dump'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/showREQ.pl b/CODE/cgi-bin/showREQ.pl index 2cba9b28..b5647281 100755 --- a/CODE/cgi-bin/showREQ.pl +++ b/CODE/cgi-bin/showREQ.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showREQ.pl @@ -81,69 +82,69 @@ =head1 DESCRIPTION print "

    $pagetitle

    "; print "

    »» [ Forms: " -."Procs | " -."Gridmaps | " -."Users: " -.($QryParm->{'usr'} eq "all" ? "$CLIENT | all":"$CLIENT | all")." | " -."" -." ]

    "; + ."Procs | " + ."Gridmaps | " + ."Users: " + .($QryParm->{'usr'} eq "all" ? "$CLIENT | all":"$CLIENT | all")." | " + ."" + ." ]

    "; $table = " .\n"; for (reverse sort @reqlist) { - my $dir = my $reqdir = $_; - $reqdir =~ s|$WEBOBS{ROOT_OUTR}/||; - my ($date,$time,$host,$user) = split(/_/,$reqdir); - my $date1 = qx(grep -a "^DATE1|" $dir/REQUEST.rc | sed -e "s/DATE1|//"); - my $date2 = qx(grep -a "^DATE2|" $dir/REQUEST.rc | sed -e "s/DATE2|//"); - my (@procs) = grep {-d} glob("$dir/{PROC.*,GRIDMAPS}"); # first list of procs from output directories - $_ =~ s|$dir/|| for @procs; # keeps only the PROC.NAME part - my @procreq = qx(grep -a "^PROC\." $dir/REQUEST.rc | sed -e "s/\.[^.]*|.*//"); # second list of procs from the request parameters - chomp(@procreq); - push(@procs,@procreq); # merging output directories and request parameters - @procs = do { my %seen; grep { !$seen{$_}++ } @procs }; # uniq - my $rowspan = scalar(@procs); - if ($user eq $CLIENT || (WebObs::Users::clientHasAdm(type=>"authprocs",name=>"$_") && $QryParm->{'usr'} eq "all")) { - if (length($date)==8 && length($time)==6) { - $date = substr($date,0,4)."-".substr($date,4,2)."-".substr($date,6,2); - $time = substr($time,0,2).":".substr($time,2,2).":".substr($time,4,2); - } - $table .= "" - ."" - ."" - ."" - ."" - .""; - for (@procs) { - (my $proc = $_) =~ s/PROC\.//; - if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$proc") || $_ eq "GRIDMAPS") { - my $rreq = qx(sqlite3 $SCHED{SQL_DB_JOBS} "SELECT cmd,stdpath,rc FROM runs WHERE jid<0 AND cmd LIKE '%$reqdir%' AND cmd LIKE '%$proc%';"); - chomp($rreq); - if ($rreq eq "") { - $table .= ("" x 2); - } else { - my ($rcmd,$rlog,$rc) = split(/\|/,$rreq); - my $log_filename = $rlog =~ s/^[><] +//r; - my $log_name = $log_filename =~ s|/$reqdir/||r; - $table .= ""; - if ($rc eq "0") { - $table .= ""; - } elsif ($rc > 0) { - $table .= ""; - } else { - $table .= ""; - } - } - $table .= ""; - $table .= ""; - } else { - $table .= ""; - } - $table .= "\n"; - } - $table .= "\n"; - } + my $dir = my $reqdir = $_; + $reqdir =~ s|$WEBOBS{ROOT_OUTR}/||; + my ($date,$time,$host,$user) = split(/_/,$reqdir); + my $date1 = qx(grep -a "^DATE1|" $dir/REQUEST.rc | sed -e "s/DATE1|//"); + my $date2 = qx(grep -a "^DATE2|" $dir/REQUEST.rc | sed -e "s/DATE2|//"); + my (@procs) = grep {-d} glob("$dir/{PROC.*,GRIDMAPS}"); # first list of procs from output directories + $_ =~ s|$dir/|| for @procs; # keeps only the PROC.NAME part + my @procreq = qx(grep -a "^PROC\." $dir/REQUEST.rc | sed -e "s/\.[^.]*|.*//"); # second list of procs from the request parameters + chomp(@procreq); + push(@procs,@procreq); # merging output directories and request parameters + @procs = do { my %seen; grep { !$seen{$_}++ } @procs }; # uniq + my $rowspan = scalar(@procs); + if ($user eq $CLIENT || (WebObs::Users::clientHasAdm(type=>"authprocs",name=>"$_") && $QryParm->{'usr'} eq "all")) { + if (length($date)==8 && length($time)==6) { + $date = substr($date,0,4)."-".substr($date,4,2)."-".substr($date,6,2); + $time = substr($time,0,2).":".substr($time,2,2).":".substr($time,4,2); + } + $table .= "" + ."" + ."" + ."" + ."" + .""; + for (@procs) { + (my $proc = $_) =~ s/PROC\.//; + if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$proc") || $_ eq "GRIDMAPS") { + my $rreq = qx(sqlite3 $SCHED{SQL_DB_JOBS} "SELECT cmd,stdpath,rc FROM runs WHERE jid<0 AND cmd LIKE '%$reqdir%' AND cmd LIKE '%$proc%';"); + chomp($rreq); + if ($rreq eq "") { + $table .= ("" x 2); + } else { + my ($rcmd,$rlog,$rc) = split(/\|/,$rreq); + my $log_filename = $rlog =~ s/^[><] +//r; + my $log_name = $log_filename =~ s|/$reqdir/||r; + $table .= ""; + if ($rc eq "0") { + $table .= ""; + } elsif ($rc > 0) { + $table .= ""; + } else { + $table .= ""; + } + } + $table .= ""; + $table .= ""; + } else { + $table .= ""; + } + $table .= "\n"; + } + $table .= "\n"; + } } $table .= "
    $__{'Date & Time'}$__{'Host'}$__{'User'}$__{'Time Span'}$__{'Params'}$__{'Job logs'}$__{'Status'}$__{'Graphs'}$__{'Archive'}
    $date $time$host$user$date1 - $date2$log_nameOKerrorwait...".(-d "$dir/$_" ? "":"")."".(-e "$dir/$_.tgz" ? "":"")."
    $date $time$host$user$date1 - $date2$log_nameOKerrorwait...".(-d "$dir/$_" ? "":"")."".(-e "$dir/$_.tgz" ? "":"")."


    \n"; @@ -154,7 +155,6 @@ =head1 DESCRIPTION print "\n\n\n"; - __END__ =pod diff --git a/CODE/cgi-bin/showRIVERS.pl b/CODE/cgi-bin/showRIVERS.pl index bb1f41c3..789e6d03 100755 --- a/CODE/cgi-bin/showRIVERS.pl +++ b/CODE/cgi-bin/showRIVERS.pl @@ -118,21 +118,21 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # ---- DateTime inits ---------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $day = strftime('%d',@tod); -my $month = strftime('%m',@tod); +my $day = strftime('%d',@tod); +my $month = strftime('%m',@tod); my $year = strftime('%Y',@tod); my $endDate = strftime('%F',@tod); my $delay = $FORM->conf('DEFAULT_DAYS') // 30; @@ -161,12 +161,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$year) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamUnite = ("ppm|en ppm","mmol|en mmol/l"); my @cleParamSite; @@ -176,17 +176,17 @@ =head1 Query string parameters my $nbRap = 0; my @rapCalc; -$QryParm->{'y1'} //= $y1; -$QryParm->{'m1'} //= $m1; -$QryParm->{'d1'} //= $d1; -$QryParm->{'y2'} //= $year; -$QryParm->{'m2'} //= $month; -$QryParm->{'d2'} //= $day; -$QryParm->{'node'} //= "All"; -$QryParm->{'sio2'} //= ""; -$QryParm->{'organiques'} //= ""; -$QryParm->{'affiche'} //= ""; -$QryParm->{'unite'} //= "ppm"; +$QryParm->{'y1'} //= $y1; +$QryParm->{'m1'} //= $m1; +$QryParm->{'d1'} //= $d1; +$QryParm->{'y2'} //= $year; +$QryParm->{'m2'} //= $month; +$QryParm->{'d2'} //= $day; +$QryParm->{'node'} //= "All"; +$QryParm->{'sio2'} //= ""; +$QryParm->{'organiques'} //= ""; +$QryParm->{'affiche'} //= ""; +$QryParm->{'unite'} //= "ppm"; if ($QryParm->{'unite'} eq "ppm") {$unite = "ppm = mg/l"} else {$unite = "mmol/l"} $startDate = "$QryParm->{'y1'}-$QryParm->{'m1'}-$QryParm->{'d1'}"; @@ -196,20 +196,20 @@ =head1 Query string parameters # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } $i = 0; for (@rapports) { - $i++; - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } + $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } } # ---- @@ -219,83 +219,83 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
    Recherche des données, merci de patienter.
    ", - "
    \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "
    \n", + "\n", + "\n"; } # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'affiche'} ne "csv") { - print "
    conf('CGI_SHOW')."\" method=\"get\">", - "

    ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  \n", - "", - " ", - " "); - if ($clientAuth > 1) { - print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; - } - print("
    \n"); - print("{'sio2'} ne ""? " checked":"").">SiO2  "); - print("{'organiques'} ne ""? " checked":"").">$__{'Organiques'}  "); - print("  \n$__{'Ratios'}: "); - - $i = 0; - for (@rapports) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - $i++; - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print("$nhtm/$dhtm  "); - } - print "

    \n", - "

    ".$FORM->conf('TITLE')."

    \n", - "

    "; + print "

    conf('CGI_SHOW')."\" method=\"get\">", + "

    ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  \n", + "", + " ", + " "); + if ($clientAuth > 1) { + print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; + } + print("
    \n"); + print("{'sio2'} ne ""? " checked":"").">SiO2  "); + print("{'organiques'} ne ""? " checked":"").">$__{'Organiques'}  "); + print("  \n$__{'Ratios'}: "); + + $i = 0; + for (@rapports) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + $i++; + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print("$nhtm/$dhtm  "); + } + print "

    \n", + "

    ".$FORM->conf('TITLE')."

    \n", + "

    "; } # ---- Read the data file @@ -315,186 +315,189 @@ =head1 Query string parameters $entete = ""; if ($clientAuth > 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."Date" - ."Site
    (Type prél.
    et flacon)" - ."Mesures sur site" - ."Charge
    solide
    (mg/L)" - ."Cations ($unite)" - ."Anions ($unite)" - .($QryParm->{'sio2'} ne "" ? "Autres":"") - .($QryParm->{'organiques'} ne "" ? "Organiques":"") - ." Calculs" - ."\n" - ."Niveau
    (cm)" - ."T eau
    (°C)" - ."pH" - ."Cond
    (µS/cm)" - ."Na+" - ."K+" - ."Mg++" - ."Ca++" - ."HCO3-" - ."Cl-" - ."SO4--" - .($QryParm->{'sio2'} ne "" ? "SiO2".($QryParm->{'unite'} ne "mmol" ? "
    (ppm)":"")."":"") - .($QryParm->{'organiques'} ne "" ? "DOCPOC":"") - ."Cond25
    (μS)" - ."NICB
    (%)"; + ."Site
    (Type prél.
    et flacon)" + ."Mesures sur site" + ."Charge
    solide
    (mg/L)" + ."Cations ($unite)" + ."Anions ($unite)" + .($QryParm->{'sio2'} ne "" ? "Autres":"") + .($QryParm->{'organiques'} ne "" ? "Organiques":"") + ." Calculs" + ."\n" + ."Niveau
    (cm)" + ."T eau
    (°C)" + ."pH" + ."Cond
    (µS/cm)" + ."Na+" + ."K+" + ."Mg++" + ."Ca++" + ."HCO3-" + ."Cl-" + ."SO4--" + .($QryParm->{'sio2'} ne "" ? "SiO2".($QryParm->{'unite'} ne "mmol" ? "
    (ppm)":"")."":"") + .($QryParm->{'organiques'} ne "" ? "DOCPOC":"") + ."Cond25
    (μS)" + ."NICB
    (%)"; $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - $i++; - if ($rap[$i] == 1) { - $entete = $entete."
    $nhtm
    $dthm
    "; - } + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + $i++; + if ($rap[$i] == 1) { + $entete = $entete."
    $nhtm
    $dthm
    "; + } } - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date;$heure;Code Site;$site;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;".($QryParm->{'sio2'} ne "" ? "$cSiO2;":"").($QryParm->{'organiques'} ne "" ? "$cDOC;$cPOC;":"")."$cond25;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) - && ($id > 0 || $clientAuth == 4) - && ($date le $endDate) && ($date ge $startDate)) { - - my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cHCO3_mmol,$cCl_mmol,$cSO4_mmol,$cSiO2_mmol); - $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cHCO3_mmol=$cCl_mmol=$cSO4_mmol=$cSiO2_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; -# my $cond25 = ""; - my $nicb = ""; - my @rapv; - my $iv = 0; - my $rapport = ""; - - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cSiO2 ne "") { $cSiO2_mmol = $cSiO2/$GMOL{SiO2}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - if (($cond ne "") && ($tRiver ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tRiver - 25))); }; - $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; -# if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cHCO3_mmol + $cCl_mmol + 2*$cSO4_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - for (@rapports) { - my ($num,$den,$nrp) = split(/\|/,$_); - $iv++; - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - if ($rap[$iv] == 1) { - $rapport = $rapport."$rapv[$iv]"; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte .= "$date $heure$lien 
    $type $flacon" - .($level ne ""?"".sprintf('%.2f',$level):"")."" - .($tRiver ne ""?"".sprintf('%.2f',$tRiver):"")."" - .($pH ne ""?"".sprintf('%.2f',$pH):"")."" - .($cond ne ""?"".sprintf('%.2f',$cond):"")."" - .($suspendedLoad ne ""?"".sprintf('%.2f',$suspendedLoad):"").""; - $txt = "$date;$heure;$site;$aliasSite;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;"; - if ($QryParm->{'unite'} eq "mmol") { - for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { - $texte .= ""; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= ""; - } - $texte .= ($QryParm->{'sio2'} ne "" ? "".sprintf($fmt,$cSiO2_mmol)."":""); - $txt .= "$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol" - .($QryParm->{'sio2'} ne "" ? ";$cSiO2_mmol;":";"); - } else { - $texte .= "" - .($cNa ne ""?"".sprintf('%.2f',$cNa):"")."" - .($cK ne ""?"".sprintf('%.2f',$cK):"")."" - .($cMg ne ""?"".sprintf('%.2f',$cMg):"")."" - .($cCa ne ""?"".sprintf('%.2f',$cCa):"")."" - .($cHCO3 ne ""?"".sprintf('%.2f',$cHCO3):"")."" - .($cCl ne ""?"".sprintf('%.2f',$cCl):"")."" - .($cSO4 ne ""?"".sprintf('%.2f',$cSO4):"")."" - .($QryParm->{'sio2'} ne ""?"".($cSiO2 ne ""?"".sprintf('%.2f',$cSiO2):"")."":""); - $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4" - .($QryParm->{'sio2'} ne "" ? ";$cSiO2;":";"); - } - if ($QryParm->{'organiques'} ne "") { - $texte .= "" - .($cDOC ne ""?"".sprintf('%.2f',$cDOC):"")."" - .($cPOC ne ""?"".sprintf('%.2f',$cPOC):"").""; - $txt .= "$cDOC;$cPOC;"; - } - $texte .= "$cond25"; - if (($nicb < -20) || ($nicb > 20)) { - $texte .= ""; - } elsif (($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= "$rapport"; - #$texte = $texte."$so4_cl$hco3_cl$ca_cl"; - $txt = $txt."$cond25;$nicb;\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date;$heure;Code Site;$site;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;".($QryParm->{'sio2'} ne "" ? "$cSiO2;":"").($QryParm->{'organiques'} ne "" ? "$cDOC;$cPOC;":"")."$cond25;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) + && ($id > 0 || $clientAuth == 4) + && ($date le $endDate) && ($date ge $startDate)) { + + my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cHCO3_mmol,$cCl_mmol,$cSO4_mmol,$cSiO2_mmol); + $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cHCO3_mmol=$cCl_mmol=$cSO4_mmol=$cSiO2_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + + # my $cond25 = ""; + my $nicb = ""; + my @rapv; + my $iv = 0; + my $rapport = ""; + + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cSiO2 ne "") { $cSiO2_mmol = $cSiO2/$GMOL{SiO2}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + if (($cond ne "") && ($tRiver ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tRiver - 25))); }; + $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + + # if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cHCO3_mmol + $cCl_mmol + 2*$cSO4_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + for (@rapports) { + my ($num,$den,$nrp) = split(/\|/,$_); + $iv++; + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + if ($rap[$iv] == 1) { + $rapport = $rapport."$rapv[$iv]"; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte .= "$date $heure$lien 
    $type $flacon" + .($level ne ""?"".sprintf('%.2f',$level):"")."" + .($tRiver ne ""?"".sprintf('%.2f',$tRiver):"")."" + .($pH ne ""?"".sprintf('%.2f',$pH):"")."" + .($cond ne ""?"".sprintf('%.2f',$cond):"")."" + .($suspendedLoad ne ""?"".sprintf('%.2f',$suspendedLoad):"").""; + $txt = "$date;$heure;$site;$aliasSite;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;"; + if ($QryParm->{'unite'} eq "mmol") { + for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { + $texte .= ""; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= ""; + } + $texte .= ($QryParm->{'sio2'} ne "" ? "".sprintf($fmt,$cSiO2_mmol)."":""); + $txt .= "$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol" + .($QryParm->{'sio2'} ne "" ? ";$cSiO2_mmol;":";"); + } else { + $texte .= "" + .($cNa ne ""?"".sprintf('%.2f',$cNa):"")."" + .($cK ne ""?"".sprintf('%.2f',$cK):"")."" + .($cMg ne ""?"".sprintf('%.2f',$cMg):"")."" + .($cCa ne ""?"".sprintf('%.2f',$cCa):"")."" + .($cHCO3 ne ""?"".sprintf('%.2f',$cHCO3):"")."" + .($cCl ne ""?"".sprintf('%.2f',$cCl):"")."" + .($cSO4 ne ""?"".sprintf('%.2f',$cSO4):"")."" + .($QryParm->{'sio2'} ne ""?"".($cSiO2 ne ""?"".sprintf('%.2f',$cSiO2):"")."":""); + $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4" + .($QryParm->{'sio2'} ne "" ? ";$cSiO2;":";"); + } + if ($QryParm->{'organiques'} ne "") { + $texte .= "" + .($cDOC ne ""?"".sprintf('%.2f',$cDOC):"")."" + .($cPOC ne ""?"".sprintf('%.2f',$cPOC):"").""; + $txt .= "$cDOC;$cPOC;"; + } + $texte .= "$cond25"; + if (($nicb < -20) || ($nicb > 20)) { + $texte .= ""; + } elsif (($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= "$rapport"; + +#$texte = $texte."$so4_cl$hco3_cl$ca_cl"; + $txt = $txt."$cond25;$nicb;\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Number of records = $nbLignesRetenues / $nbData.

    \n", - "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}".($QryParm->{'sio2'} ne "" ? "&sio2=$QryParm->{'sio2'}":"").($QryParm->{'organiques'} ne "" ? "&organiques=$QryParm->{'organiques'}":"")."\">$fileCSV

    \n"); + "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}".($QryParm->{'sio2'} ne "" ? "&sio2=$QryParm->{'sio2'}":"").($QryParm->{'organiques'} ne "" ? "&organiques=$QryParm->{'organiques'}":"")."\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
    ", - "

    Types of sites: "); - for (sort(keys(%types))) { - push(@html,"$_ = $types{$_}{name}, "); - } - push(@html,"

    "); + push(@html,"$entete\n$texte\n$entete\n
    ", + "

    Types of sites: "); + for (sort(keys(%types))) { + push(@html,"$_ = $types{$_}{name}, "); + } + push(@html,"

    "); } push(@html,@notes); if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/showSISMOBUL.pl b/CODE/cgi-bin/showSISMOBUL.pl index 87603d3e..62061b96 100755 --- a/CODE/cgi-bin/showSISMOBUL.pl +++ b/CODE/cgi-bin/showSISMOBUL.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showSISMOBUL.pl @@ -44,8 +45,6 @@ =head1 Query string parameters my $FORMPATH = "$WEBOBS{PATH_FORMS}/SISMOBUL"; my %FORM = readCfg("$FORMPATH/SISMOBUL.conf"); - - ########djl: here I am . my @grids = readCfgFile("$FORMPATH/$FORM{FILE_PROCS}"); @@ -57,8 +56,8 @@ =head1 Query string parameters # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -76,11 +75,11 @@ =head1 Query string parameters # sélection des stations utilisées et récupération des alias (réseaux sources + érosion) my @reseaux = readCfgFile("$WEBOBS{RACINE_FICHIERS_CONFIGURATION}/$WEBOBS{SISMOBUL_FILE_RESEAUX}"); + #my @types = readCfgFile("$WEBOBS{RACINE_FICHIERS_CONFIGURATION}/$WEBOBS{PLUVIO_FILE_TYPE}"); my %stationsRes; my @cleRes; - $ENV{TZ} = "America/Guadeloupe"; my $tz_old = $ENV{TZ}; $ENV{LANG} = $WEBOBS{LOCALE}; @@ -99,12 +98,12 @@ =head1 Query string parameters my $unite; my @cleParamAnnee; for ($WEBOBS{SISMOBUL_BANG}..$anneeP) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$anneeP-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$anneeP-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamSite; @@ -112,7 +111,6 @@ =head1 Query string parameters my $titrePage = $WEBOBS{SISMOBUL_TITLE}; my $pathDATA = $WEBOBS{RACINE_FTP}."/".$WEBOBS{SISMOBUL_PATH_NAME}; - # --------------------------------------------------------------- # Récuperation des paramètres transmis (GET) # --------------------------------------------------------------- @@ -121,24 +119,24 @@ =head1 Query string parameters my @parametres=$cgi->url_param(); my $valParams = join(" ",@parametres); -if ($valParams =~ /annee/) { - $parametreAnnee=$cgi->url_param('annee'); - $msgFinal = $msgFinal." & annee=$parametreAnnee"; +if ($valParams =~ /annee/) { + $parametreAnnee=$cgi->url_param('annee'); + $msgFinal = $msgFinal." & annee=$parametreAnnee"; } else { - $msgFinal = "Pas (ou Mauvais) paramètre d'année - Option forcée à année en cours"; - $parametreAnnee = $anneeP; + $msgFinal = "Pas (ou Mauvais) paramètre d'année - Option forcée à année en cours"; + $parametreAnnee = $anneeP; } -if ($valParams =~ /mois/) { - $parametreMois=$cgi->url_param('mois'); - $msgFinal = $msgFinal." & mois=$parametreMois"; +if ($valParams =~ /mois/) { + $parametreMois=$cgi->url_param('mois'); + $msgFinal = $msgFinal." & mois=$parametreMois"; } else { - $msgFinal = $msgFinal." & Mois non transmis - Option forcée à mois en cours"; - $parametreMois = $moisP; + $msgFinal = $msgFinal." & Mois non transmis - Option forcée à mois en cours"; + $parametreMois = $moisP; } -if ($valParams =~ /affiche/) { - $affiche=$cgi->url_param('affiche'); +if ($valParams =~ /affiche/) { + $affiche=$cgi->url_param('affiche'); } my $fileDATA = "$pathDATA/$parametreAnnee/$parametreAnnee-$parametreMois.TXT"; @@ -147,13 +145,13 @@ =head1 Query string parameters push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/dat\n\n"); if ($affiche ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "$titrePage\n", - "", - "\n"; - - print "\n"; - print "\n", - "\n", - "
    Recherche des données, merci de patienter.
    ", - "\n", - "
    \n", - "\n", - "\n", - "\n"; + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "\n", + "
    \n", + "\n", + "\n", + "\n"; } - for (@reseaux) { - my $codeRes = $_; - chomp($codeRes); - my @sta = qx(/bin/ls -d $WEBOBS{RACINE_DATA_STATIONS}/$codeRes*); - my $res = $graphStr{"nom_".$graphStr{"routine_$codeRes"}}; - push(@cleRes,"$codeRes|- réseau $res -"); - for (@sta) { - $s = substr($_,length($_)-8,7); - my %config = readConfStation($s); - $stationsRes{$s} = $config{ALIAS}; - if ($stationsRes{$s} ne "-") { - push(@cleRes,"$s|$stationsRes{$s}"); - } - } + my $codeRes = $_; + chomp($codeRes); + my @sta = qx(/bin/ls -d $WEBOBS{RACINE_DATA_STATIONS}/$codeRes*); + my $res = $graphStr{"nom_".$graphStr{"routine_$codeRes"}}; + push(@cleRes,"$codeRes|- réseau $res -"); + for (@sta) { + $s = substr($_,length($_)-8,7); + my %config = readConfStation($s); + $stationsRes{$s} = $config{ALIAS}; + if ($stationsRes{$s} ne "-") { + push(@cleRes,"$s|$stationsRes{$s}"); + } + } } # Debut du formulaire pour la selection de l'affichage # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ($affiche ne "csv") { - print("
    ", - "

    ", - "Sélectionner: \n", - "\n", - " "); - print "

    \n", - "

    $titrePage

    \n", - "

    Intervalle sélectionné: $afficheMois $parametreAnnee
    ", - "Fichier: $fileDATA

    "; + print("
    ", + "

    ", + "Sélectionner: \n", + "\n", + " "); + print "

    \n", + "

    $titrePage

    \n", + "

    Intervalle sélectionné: $afficheMois $parametreAnnee
    ", + "Fichier: $fileDATA

    "; } # ---- Lecture du fichier de données (dans tableau @lignes) @@ -239,20 +236,19 @@ =head1 Query string parameters $i = 0; open(FILE, "<$fileDATA") || die "fichier $fileDATA non trouvé\n"; $debuts_lignes[0] = tell(FILE); -while() { - $i++; - $debuts_lignes[$i] = tell(FILE); - my $old_fin=$/; - $/="\n";chomp; - $/="\r";chomp; - $/="\r\n";chomp; - $/=$old_fin; - push(@lignes,l2u($_)); +while() { + $i++; + $debuts_lignes[$i] = tell(FILE); + my $old_fin=$/; + $/="\n";chomp; + $/="\r";chomp; + $/="\r\n";chomp; + $/=$old_fin; + push(@lignes,l2u($_)); } close(FILE); my $nbData = @lignes - 1; - my $entete; my $texte = ""; my $modif; @@ -266,73 +262,74 @@ =head1 Query string parameters # Ligne d'en-tête du tableau de données $entete = "Station" - ."Phase P" - ."Temps d'arrivée" - ."Phase S" - ."Distance" - ."Durée
    (s)" - ."Commentaire" - ."TXT" - ."\n"; + ."Phase P" + ."Temps d'arrivée" + ."Phase S" + ."Distance" + ."Durée
    (s)" + ."Commentaire" + ."TXT" + ."\n"; # Tableau de données $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - if (substr($_,0,length($car10)) ne $car10) { - - $sta = substr($_,0,4); - $php = substr($_,4,4); - $tps = substr($_,9,15); - $phs = substr($_,30,10); - $dis = substr($_,99,4); - $dur = substr($_,70,5); - $com = substr($_,75,23); - - if ($stationsRes{$sta}) { - $aliasSite = "$stationsRes{$sta}"; - } else { - $aliasSite = $sta; - } + if (substr($_,0,length($car10)) ne $car10) { - $lien = "$aliasSite"; + $sta = substr($_,0,4); + $php = substr($_,4,4); + $tps = substr($_,9,15); + $phs = substr($_,30,10); + $dis = substr($_,99,4); + $dur = substr($_,70,5); + $com = substr($_,75,23); + + if ($stationsRes{$sta}) { + $aliasSite = "$stationsRes{$sta}"; + } else { + $aliasSite = $sta; + } + + $lien = "$aliasSite"; # my $ligne_txt = substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis; - my $ligne_txt = sprintf("%3s%4s%15s%6s%1s %23s%4s%4s", substr($sta,0,3), $php, $tps, substr($phs,0,6), substr($phs,9,1), $com, substr($dur,1,4), $dis); - $texte = $texte."$lien".substr($sta,0,3)."" - ."$php" - ."$tps" - ."$phs".substr($phs,0,6)."".substr($phs,9,1)."" - ."$dis" - ."$dur".substr($dur,1,4)."" - ."$com" - ."$ligne_txt" - ."\n"; - $txt.=$ligne_txt; + my $ligne_txt = sprintf("%3s%4s%15s%6s%1s %23s%4s%4s", substr($sta,0,3), $php, $tps, substr($phs,0,6), substr($phs,9,1), $com, substr($dur,1,4), $dis); + $texte = $texte."$lien".substr($sta,0,3)."" + ."$php" + ."$tps" + ."$phs".substr($phs,0,6)."".substr($phs,9,1)."" + ."$dis" + ."$dur".substr($dur,1,4)."" + ."$com" + ."$ligne_txt" + ."\n"; + $txt.=$ligne_txt; + # $txt = $txt.substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis."\n"; # $texte .= "
    ".$ligne_txt."
    "; - - $nbLignesRetenues++; - } else { - $texte = $texte." \n"; - } - $i++; + + $nbLignesRetenues++; + } else { + $texte = $texte." \n"; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

    \n", - "

    Télécharger le bulletin au format GUA (Martinique): $fileCSV

    \n", -"
    sprintf(\"%3s%4s%15s%6s%1s    %23s%4s%4s\", substr(\$sta,0,3), \$php, \$tps, substr(\$phs,0,6), substr(\$phs,9,1), \$com, substr(\$dur,1,4), \$dis)
    "); + "

    Télécharger le bulletin au format GUA (Martinique): $fileCSV

    \n", + "
    sprintf(\"%3s%4s%15s%6s%1s    %23s%4s%4s\", substr(\$sta,0,3), \$php, \$tps, substr(\$phs,0,6), substr(\$phs,9,1), \$com, substr(\$dur,1,4), \$dis)
    "); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
    \n"); + push(@html,"$entete\n$texte\n$entete\n
    \n"); } if ($affiche eq "csv") { - push(@csv,$txt); - print @csv; + push(@csv,$txt); + print @csv; } else { - print @html; - print "\n
    \n@signature\n\n\n"; diff --git a/CODE/cgi-bin/showSOILSOLUTION.pl b/CODE/cgi-bin/showSOILSOLUTION.pl index eac8e6d9..24d8b828 100755 --- a/CODE/cgi-bin/showSOILSOLUTION.pl +++ b/CODE/cgi-bin/showSOILSOLUTION.pl @@ -111,13 +111,13 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (sort keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -174,22 +174,22 @@ =head1 Query string parameters $i = 0; for (@ratios) { - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } - $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } + $i++; } # ---- a site requested as {name} means "all nodes for proc 'name'" # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -199,13 +199,13 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'dump'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print qq( + print $cgi->header(-charset=>'utf-8'); + print qq( ).$FORM->conf('TITLE').qq( ); - print qq( + print qq(
    $__{'Searching for the data... please wait'}.
    @@ -216,65 +216,65 @@ =head1 Query string parameters # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'dump'} ne "csv") { - print "
    conf('CGI_SHOW')."\" method=\"get\">", - ""; + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('return_url' => $return_url); + print qq(); + } + print qq(
    ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "   + print "conf('CGI_SHOW')."\" method=\"get\">", + ""; - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('return_url' => $return_url); - print qq(); - } - print qq(
    ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "       + for (@cleParamUnite) { + my ($val,$cle) = split (/\|/,$_); + if ("$val" eq "$QryParm->{'unit'}") { print qq(\n); } + else { print qq(\n); } + } + print qq(   
      \n$__{'Ratios'}:); - $i = 0; - for (@ratios) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print qq($nhtm/$dhtm  ); - $i++; - } - print "
    + $i = 0; + for (@ratios) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print qq($nhtm/$dhtm  ); + $i++; + } + print "

    ).$FORM->conf('TITLE').qq(

    \n); } @@ -295,40 +295,40 @@ =head1 Query string parameters $header = ""; if ($clientAuth > 1) { - $header = $header.""; + $header = $header.""; } $header = $header."Sampling Time Collection" - ."Site" - ."Lysimeter" - ."Laboratory Meas." - ."Cations ($unit)" - ."Anions ($unit)" - ."NICB
    (%)" - .($nbRap > 0 ? " Ratios":"") - ."\n" - ."Start
    Date & TimeEnd
    Date & TimeDays" - ."Depth
    (cm)Level" - ."pH" - ."Cond.
    (µS)" - ."SiO2
    (ppm)" - ."DOC
    (ppm)" - ."Na+" - ."K+" - ."Mg++" - ."Ca++" - ."HCO3-" - ."Cl-" - ."NO3-" - ."SO4--"; + ."Site" + ."Lysimeter" + ."Laboratory Meas." + ."Cations ($unit)" + ."Anions ($unit)" + ."NICB
    (%)" + .($nbRap > 0 ? " Ratios":"") + ."\n" + ."Start
    Date & TimeEnd
    Date & TimeDays" + ."Depth
    (cm)Level" + ."pH" + ."Cond.
    (µS)" + ."SiO2
    (ppm)" + ."DOC
    (ppm)" + ."Na+" + ."K+" + ."Mg++" + ."Ca++" + ."HCO3-" + ."Cl-" + ."NO3-" + ."SO4--"; $i = 0; for (@ratios) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - if ($rap[$i] == 1) { - $header = $header."" - ."" - ."
    $nhtm
    $dthm
    "; - } - $i++; + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + if ($rap[$i] == 1) { + $header = $header."" + ."" + ."
    $nhtm
    $dthm
    "; + } + $i++; } $header = $header."\n"; @@ -336,130 +336,130 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for (@lines) { - my ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$depth;$level;$pH;$cond;$cSiO2;$cDOC;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) - && ($id > 0 || $clientAuth == 4) - && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span - - my ($y,$m,$d) = split(/-/,$date1); - my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); - my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my ($y,$m,$d) = split(/-/,$date2); - my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); - my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my $dur = $d1->delta_days($d2)->delta_days; - my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol); - $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; - my $nicb = ""; - my @rapv; - my $rapport = ""; - - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; - if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - my $iv = 0; - for (@ratios) { - if ($rap[$iv] == 1) { - my ($num,$den,$nrp) = split(/\|/,$_); - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - $rapport = $rapport."$rapv[$iv]"; - } - $iv++; - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { - $lien = "$aliasSite"; - } - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('id' => $id, 'return_url' => $return_url); - $modif = qq(); - $efface = qq(); - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$date1 $time1$date2 $time2$dur$lien" - ."$depth$level" - ."$pH$cond" - ."$cSiO2$cDOC"; - $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$depth;$level;$pH;$cond;$cSiO2;$cDOC;"; - if ($QryParm->{'unit'} eq "mmol") { - for ("Na","K","Mg","Ca","HCO3","Cl","NO3","SO4") { - $texte .= ""; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= ""; - } - $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cNO3_mmol;$cSO4_mmol;"; - } else { - $texte .= "$cNa$cK$cMg$cCa" - ."$cHCO3$cCl$cNO3$cSO4"; - $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;"; - } - if ($nicb and ($nicb < -20) || ($nicb > 20)) { - $texte .= ""; - } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= "$rapport"; - $txt = $txt.sprintf("%0.1f",$nicb).";\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$depth;$level;$pH;$cond;$cSiO2;$cDOC;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) + && ($id > 0 || $clientAuth == 4) + && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span + + my ($y,$m,$d) = split(/-/,$date1); + my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); + my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my ($y,$m,$d) = split(/-/,$date2); + my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); + my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my $dur = $d1->delta_days($d2)->delta_days; + my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol); + $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + my $nicb = ""; + my @rapv; + my $rapport = ""; + + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + my $iv = 0; + for (@ratios) { + if ($rap[$iv] == 1) { + my ($num,$den,$nrp) = split(/\|/,$_); + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + $rapport = $rapport."$rapv[$iv]"; + } + $iv++; + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { + $lien = "$aliasSite"; + } + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('id' => $id, 'return_url' => $return_url); + $modif = qq(); + $efface = qq(); + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$date1 $time1$date2 $time2$dur$lien" + ."$depth$level" + ."$pH$cond" + ."$cSiO2$cDOC"; + $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$depth;$level;$pH;$cond;$cSiO2;$cDOC;"; + if ($QryParm->{'unit'} eq "mmol") { + for ("Na","K","Mg","Ca","HCO3","Cl","NO3","SO4") { + $texte .= ""; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= ""; + } + $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cNO3_mmol;$cSO4_mmol;"; + } else { + $texte .= "$cNa$cK$cMg$cCa" + ."$cHCO3$cCl$cNO3$cSO4"; + $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;"; + } + if ($nicb and ($nicb < -20) || ($nicb > 20)) { + $texte .= ""; + } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= "$rapport"; + $txt = $txt.sprintf("%0.1f",$nicb).";\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"$__{'Number of records'} = $nbLignesRetenues / $nbData.

    \n", - "

    $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

    \n"); + "

    $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"$header\n$texte\n$header\n
    "); - push(@html,"

    "); + push(@html,"$header\n$texte\n$header\n
    "); + push(@html,"

    "); } push(@html,@notes); if ($QryParm->{'dump'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/showTHEIA.pl b/CODE/cgi-bin/showTHEIA.pl index 0d3e9026..9366f742 100755 --- a/CODE/cgi-bin/showTHEIA.pl +++ b/CODE/cgi-bin/showTHEIA.pl @@ -44,7 +44,7 @@ =head1 DESCRIPTION # ---- checking if user has authorisation to create a JSON metadata file. # ---------------------------------------- if ( ! WebObs::Users::clientHasAdm(type=>"authmisc",name=>"grids")) { - die "You are not authorized" ; + die "You are not authorized" ; } # ---- init general-use variables on the way and quit if something's wrong @@ -61,7 +61,7 @@ =head1 DESCRIPTION my $userid = ""; my $password = ""; my $dbh = DBI->connect($dsn, $userid, $password, { RaiseError => 1 }) - or die $DBI::errstr; + or die $DBI::errstr; # ---- display HTML content print $cgi->header(-type=>'text/html',-charset=>'utf-8'); @@ -87,7 +87,7 @@ =head1 DESCRIPTION my $rv = $sth->execute() or die $DBI::errstr; if($rv < 0) { - print $DBI::errstr; + print $DBI::errstr; } # ---- creating the panel @@ -95,66 +95,66 @@ =head1 DESCRIPTION print "Producer"; print ""; print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + my $contacts; my $funders; my @onlineRes; - -while(my @row = $sth->fetchrow_array()) { - $funders = join(', ',split(/_,/,$row[8])); - @onlineRes = split(/_,/,$row[9]); - foreach (@onlineRes) { - $_ = (split '@', $_)[1]; - } - my $onlineRes = join(', ', @onlineRes); - - # ---- extracting datasets contacts data - my $stmt2 = qq(SELECT * FROM contacts WHERE related_id = '$row[0]';); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - if($rv2 < 0) { - print $DBI::errstr; - } - my @contacts; - while(my @row2 = $sth2->fetchrow_array()){ - push(@contacts, "($row2[3]) ".$row2[1]." ".$row2[2].": ".$row2[0]); - } - print "" - ."" - ."" - ."

    " - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; +while(my @row = $sth->fetchrow_array()) { + $funders = join(', ',split(/_,/,$row[8])); + @onlineRes = split(/_,/,$row[9]); + foreach (@onlineRes) { + $_ = (split '@', $_)[1]; + } + my $onlineRes = join(', ', @onlineRes); + + # ---- extracting datasets contacts data + my $stmt2 = qq(SELECT * FROM contacts WHERE related_id = '$row[0]';); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + if($rv2 < 0) { + print $DBI::errstr; + } + + my @contacts; + while(my @row2 = $sth2->fetchrow_array()){ + push(@contacts, "($row2[3]) ".$row2[1]." ".$row2[2].": ".$row2[0]); + } + print "" + ."" + ."" + ."

    " + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; }; print "
    IdentifierNameTitleDescriptionObjectiveMeasured variablesEmailContactsFundersOnline resource
    IdentifierNameTitleDescriptionObjectiveMeasured variablesEmailContactsFundersOnline resource
    $row[0]  $row[1]" - ."

    		$row[2]" - ."

    		$row[3]" - ."

    		$row[4]" - ."

    		$row[5]" - ."

    		$row[6]" - ."

    		".(join "\n", @contacts) - ."

    		$funders" - ."

    		$onlineRes" - ."

    $row[0]  $row[1]" + ."

    		$row[2]" + ."

    		$row[3]" + ."

    		$row[4]" + ."

    		$row[5]" + ."

    		$row[6]" + ."

    		".(join "\n", @contacts) + ."

    		$funders" + ."

    		$onlineRes" + ."

    \n"; @@ -174,69 +174,70 @@ =head1 DESCRIPTION $rv = $sth->execute() or die $DBI::errstr; if($rv < 0) { - print $DBI::errstr; + print $DBI::errstr; } + # ---- creating the panel print ""; print ""; print "\n"; @@ -250,52 +251,53 @@ =head1 DESCRIPTION $rv = $sth->execute() or die $DBI::errstr; if($rv < 0) { - print $DBI::errstr; + print $DBI::errstr; } + # ---- creating the panel print "
    Datasets"; print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; while(my @row = $sth->fetchrow_array()){ - my $datasetId = (split /_DAT_/, $row[0]) [1]; - ($GRIDName, $NODEName) = (split /\./, $datasetId); - my %S = readNode($NODEName, "novsub"); - my %NODE = %{$S{$NODEName}}; - my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; - - if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ){ - my $subject = join(',', split(/_/,$row[2])); - - # ---- extracting datasets contacts data - my $stmt2 = qq(SELECT * FROM contacts WHERE related_id LIKE '$row[0]%';); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - if($rv2 < 0) { - print $DBI::errstr; - } - - my @contacts; - while(my @row2 = $sth2->fetchrow_array()){ - push(@contacts, $row2[1]." ".$row2[2].": ".$row2[0]); - } - - print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - } else { - print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - } + my $datasetId = (split /_DAT_/, $row[0]) [1]; + ($GRIDName, $NODEName) = (split /\./, $datasetId); + my %S = readNode($NODEName, "novsub"); + my %NODE = %{$S{$NODEName}}; + my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; + + if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ){ + my $subject = join(',', split(/_/,$row[2])); + + # ---- extracting datasets contacts data + my $stmt2 = qq(SELECT * FROM contacts WHERE related_id LIKE '$row[0]%';); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + if($rv2 < 0) { + print $DBI::errstr; + } + + my @contacts; + while(my @row2 = $sth2->fetchrow_array()){ + push(@contacts, $row2[1]." ".$row2[2].": ".$row2[0]); + } + + print "" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + } else { + print "" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + } }; print "
    IdentifierTitleDescriptionSubjectCreator(s)Spatial coverageProvenance
    IdentifierTitleDescriptionSubjectCreator(s)Spatial coverageProvenance
    $row[0]$row[1]$desc$subject".join(', ', @contacts)."$row[3]$row[4]
    No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !
    $row[0]$row[1]$desc$subject".join(', ', @contacts)."$row[3]$row[4]
    No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !
    "; print ""; print "\n"; diff --git a/CODE/cgi-bin/showVEHICLES.pl b/CODE/cgi-bin/showVEHICLES.pl index 91b1a76b..a5641638 100755 --- a/CODE/cgi-bin/showVEHICLES.pl +++ b/CODE/cgi-bin/showVEHICLES.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showVEHICLES.pl @@ -90,20 +91,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -129,12 +130,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamVehicle; @@ -142,19 +143,19 @@ =head1 Query string parameters my @option = (); -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "Tout"; -$QryParm->{'vehicle'} ||= "Tout"; -$QryParm->{'affiche'} ||= ""; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "Tout"; +$QryParm->{'vehicle'} ||= "Tout"; +$QryParm->{'affiche'} ||= ""; # ---- a vehicle requested as {name} means "all nodes for grid (proc) 'name'" # my @gridvehicles; if ($QryParm->{'vehicle'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridvehicles,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridvehicles,"$_"); + } } # ---- @@ -164,64 +165,64 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "$titrePage\n", - "", - "\n"; - - print "\n", - "\n", - "
    Recherche des données, merci de patienter.
    ", - "\n", - "
    \n", - "\n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "$titrePage\n", + "", + "\n"; + + print "\n", + "\n", + "
    Recherche des données, merci de patienter.
    ", + "\n", + "
    \n", + "\n", + "\n", + "\n"; } # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print("conf('CGI_SHOW')."\" method=\"get\">", - "

    ", - "Sélectionner: \n", - "\n", - "", - " "); - if ($editOK) { - print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); - } - print "

    \n", - "

    $titrePage

    \n", - "

    Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
    ", - "Vehicule sélectionnés: $afficheVehicle
    "; + print("
    conf('CGI_SHOW')."\" method=\"get\">", + "

    ", + "Sélectionner: \n", + "\n", + "", + " "); + if ($editOK) { + print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + } + print "

    \n", + "

    $titrePage

    \n", + "

    Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
    ", + "Vehicule sélectionnés: $afficheVehicle
    "; } # ---- Lecture du fichier de données (dans tableau @lignes) @@ -242,66 +243,66 @@ =head1 Query string parameters $entete = "

    "; if ($editOK) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete.""; - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,u2l("$date;$heure;Code Vehicle;$vehicle;$mileage;$type;$site;$driver;$oil")); - } - elsif (($_ ne "") - && (($QryParm->{'vehicle'} eq "Tout") || ($vehicle =~ $QryParm->{'vehicle'}) || ($vehicle ~~ @gridvehicles)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { - - $aliasVehicle = $Ns{$vehicle}{ALIAS} ? $Ns{$vehicle}{ALIAS} : $vehicle; - - my $normVehicle = normNode(node=>"PROC.$vehicle"); - if ($normVehicle ne "") { - $lien = "$aliasVehicle"; - } else { $lien = "$aliasVehicle" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($editOK) { - $texte = $texte.""; - } - $texte = $texte."" - ."" - .""; - $txt = "$date;$heure;$vehicle;$aliasVehicle;$mileage;$type;$site;$driver;$oil\n"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,u2l("$date;$heure;Code Vehicle;$vehicle;$mileage;$type;$site;$driver;$oil")); + } + elsif (($_ ne "") + && (($QryParm->{'vehicle'} eq "Tout") || ($vehicle =~ $QryParm->{'vehicle'}) || ($vehicle ~~ @gridvehicles)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { + + $aliasVehicle = $Ns{$vehicle}{ALIAS} ? $Ns{$vehicle}{ALIAS} : $vehicle; + + my $normVehicle = normNode(node=>"PROC.$vehicle"); + if ($normVehicle ne "") { + $lien = "$aliasVehicle"; + } else { $lien = "$aliasVehicle" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($editOK) { + $texte = $texte.""; + } + $texte = $texte."" + ."" + .""; + $txt = "$date;$heure;$vehicle;$aliasVehicle;$mileage;$type;$site;$driver;$oil\n"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

    \n", "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&vehicle=$QryParm->{'vehicle'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"
    Observations"; print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; while(my @row = $sth->fetchrow_array()){ - my $datasetId = $row[7]; - my $channelId = $row[5]; - ($GRIDName, $NODEName) = (split /\./, $datasetId); - $GRIDName = (split /_DAT_/, $GRIDName)[1]; - if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ) { - my $subject = join(',', split(/_/,$row[3])); - print ""; - print $row[0] ~~ @channels ? "" : ""; - print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - } else { - print "" - ."" - .""; - } + my $datasetId = $row[7]; + my $channelId = $row[5]; + ($GRIDName, $NODEName) = (split /\./, $datasetId); + $GRIDName = (split /_DAT_/, $GRIDName)[1]; + if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ) { + my $subject = join(',', split(/_/,$row[3])); + print ""; + print $row[0] ~~ @channels ? "" : ""; + print "" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + } else { + print "" + ."" + .""; + } }; print "
    IdentifierProcessing levelData typeTemporal extentTime seriesObserved propertyStation nameDatasetData file nameTHEIA category
    IdentifierProcessing levelData typeTemporal extentTime seriesObserved propertyStation nameDatasetData file nameTHEIA category
    $row[0]$row[2]$row[3]$row[4]$row[5]$row[6]$row[7]$row[8]
    No access to $GRIDName.$NODEName\_$channelId !
    $row[0]$row[2]$row[3]$row[4]$row[5]$row[6]$row[7]$row[8]
    No access to $GRIDName.$NODEName\_$channelId !
    DateVehiculeKilomètrageType de déplacementLieuxConducteurPlein?
    $modif$date $heure$lien$mileage$type$site$driver$oil
    $modif$date $heure$lien$mileage$type$site$driver$oil
    $entete\n$texte\n$entete\n
    ", - "

    Types de deplacements: "); - for (@types) { - my ($tpi,$tpn) = split(/\|/,$_); - push(@html,"$tpi = $tpn, "); - } - push(@html,"

    \n"); + push(@html,"$entete\n$texte\n$entete\n
    ", + "

    Types de deplacements: "); + for (@types) { + my ($tpi,$tpn) = split(/\|/,$_); + push(@html,"$tpi = $tpn, "); + } + push(@html,"

    \n"); } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
    \n\n\n"; diff --git a/CODE/cgi-bin/training.pl b/CODE/cgi-bin/training.pl index 90edba19..16885eb6 100755 --- a/CODE/cgi-bin/training.pl +++ b/CODE/cgi-bin/training.pl @@ -35,7 +35,6 @@ =head1 Query string parameters my $cgi = CGI->new; $cgi->charset('UTF-8'); - # ---- loads arguments my ($date1, $date2, $s3, $conf) = @ARGV; @@ -49,7 +48,7 @@ =head1 Query string parameters # ---- must have admin auth to run if (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) { - die "Sorry, you must have administrator right on $mc3 to run this script."; + die "Sorry, you must have administrator right on $mc3 to run this script."; } # ---- Download csv database from the WebObs main-courante @@ -57,7 +56,6 @@ =head1 Query string parameters my $netrc = $WEBOBS{NETRC_FILE}; my $opt = (-e $netrc ? "--netrc-file '$netrc'":""); - # split dates my $y1 = substr($date1, 0,4); my $m1 = substr($date1, 4,2); @@ -91,6 +89,7 @@ =head1 Query string parameters my $verbatim = 3; my $stdout = qx($WEBOBS{ROOT_CODE}/python/AAA/USECASE3_REAL_TIME_SPARSE_CLASSIFICATION_TRAINING.py $MC3{PSE_ROOT_CONF} $MC3{PSE_ROOT_DATA} $MC3{PSE_TMP_FILEPATH} $conf $SEFRAN3{DATASOURCE} $WEBOBS{SLINKTOOL_PRGM} $verbatim); print $stdout if ($debug); + #print "$MC3{PSE_CONF_FILENAME} \n"; __END__ diff --git a/CODE/cgi-bin/usersMgr.pl b/CODE/cgi-bin/usersMgr.pl index cb3188af..0a771afd 100755 --- a/CODE/cgi-bin/usersMgr.pl +++ b/CODE/cgi-bin/usersMgr.pl @@ -77,11 +77,10 @@ =head1 QUERY-STRING PARAMETERS # ---- special functions only for the WebObs Owner my $isWO = WebObs::Users::clientIsWO; - # ---- any reasons why we couldn't go on ? # ---------------------------------------- if ( ! WebObs::Users::clientHasAdm(type=>"authmisc",name=>"users")) { - die "You are not authorized." ; + die "You are not authorized." ; } # ---- parse/defaults query string @@ -118,169 +117,177 @@ =head1 QUERY-STRING PARAMETERS # ---- process (execute) sql insert new row into table 'tbl' # ----------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'insert') { - # query-string must contain all required DB columns values for an sql insert - my $q=''; - if ($QryParm->{'tbl'} eq "user") { - $q = "insert into $WEBOBS{SQL_TABLE_USERS} values(\'$QryParm->{'uid'}\',\'$QryParm->{'fullname'}\',"; - $q .= "\'$QryParm->{'login'}\',\'$QryParm->{'email'}\',\'$QryParm->{'valid'}\',\'$QryParm->{'enddate'}\',\'$QryParm->{'comment'}\')"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "group") { - $q = "insert into $WEBOBS{SQL_TABLE_GROUPS} values(\'$QryParm->{'gid'}\',\'$QryParm->{'uid'}\')"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "notification") { - $q = "insert into $WEBOBS{SQL_TABLE_NOTIFICATIONS} values(\'$QryParm->{'event'}\',\'$QryParm->{'valid'}\',"; - $q .= "\'$QryParm->{'uid'}\',\'$QryParm->{'mailsub'}\',\'$QryParm->{'mailatt'}\',\'$QryParm->{'act'}\')"; - $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; - } - elsif ($authtable ne "") { - $q = "insert into $authtable values(\'$QryParm->{'uid'}\',\'$QryParm->{'res'}\',\'$QryParm->{'auth'}\')"; - $q = "" if ( $QryParm->{'uid'} eq '!' && !$isWO ); - $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; - } else { die "$QryParm->{'action'} for unknown table"; } - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $$refMsg .= " failed to insert new $QryParm->{'tbl'} ($err) "; - $$refMsgColor = "red"; - } else { - $$refMsg .= " successfully inserted new $QryParm->{'tbl'} "; - $$refMsgColor = "green" if ($$refMsgColor ne "red"); - } + + # query-string must contain all required DB columns values for an sql insert + my $q=''; + if ($QryParm->{'tbl'} eq "user") { + $q = "insert into $WEBOBS{SQL_TABLE_USERS} values(\'$QryParm->{'uid'}\',\'$QryParm->{'fullname'}\',"; + $q .= "\'$QryParm->{'login'}\',\'$QryParm->{'email'}\',\'$QryParm->{'valid'}\',\'$QryParm->{'enddate'}\',\'$QryParm->{'comment'}\')"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "group") { + $q = "insert into $WEBOBS{SQL_TABLE_GROUPS} values(\'$QryParm->{'gid'}\',\'$QryParm->{'uid'}\')"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "notification") { + $q = "insert into $WEBOBS{SQL_TABLE_NOTIFICATIONS} values(\'$QryParm->{'event'}\',\'$QryParm->{'valid'}\',"; + $q .= "\'$QryParm->{'uid'}\',\'$QryParm->{'mailsub'}\',\'$QryParm->{'mailatt'}\',\'$QryParm->{'act'}\')"; + $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; + } + elsif ($authtable ne "") { + $q = "insert into $authtable values(\'$QryParm->{'uid'}\',\'$QryParm->{'res'}\',\'$QryParm->{'auth'}\')"; + $q = "" if ( $QryParm->{'uid'} eq '!' && !$isWO ); + $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; + } else { die "$QryParm->{'action'} for unknown table"; } + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $$refMsg .= " failed to insert new $QryParm->{'tbl'} ($err) "; + $$refMsgColor = "red"; + } else { + $$refMsg .= " successfully inserted new $QryParm->{'tbl'} "; + $$refMsgColor = "green" if ($$refMsgColor ne "red"); + } } + # ---- process (execute) sql update a row of table 'tbl' # ---------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'update') { - # query-string must contain all required DB columns values for an sql insert - my $q=''; - if ($QryParm->{'tbl'} eq "user") { - $q = "update $WEBOBS{SQL_TABLE_USERS} set UID=\'$QryParm->{'uid'}\',"; - $q .= " FULLNAME=\'$QryParm->{'fullname'}\', LOGIN=\'$QryParm->{'login'}\',"; - $q .= " EMAIL=\'$QryParm->{'email'}\', VALIDITY=\'$QryParm->{'valid'}\',"; - $q .= " ENDDATE=\'$QryParm->{'enddate'}\', COMMENT=\'$QryParm->{'comment'}\'"; - $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "group") { - $q = "update $WEBOBS{SQL_TABLE_GROUPS} set GID=\'$QryParm->{'gid'}\', UID=\'$QryParm->{'uid'}\'"; - $q .= " WHERE GID=\'$QryParm->{'OLDgid'}\' AND UID=\'$QryParm->{'OLDuid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "notification") { - $q = "update $WEBOBS{SQL_TABLE_NOTIFICATIONS} set EVENT=\'$QryParm->{'event'}\', VALIDITY=\'$QryParm->{'valid'}\', UID=\'$QryParm->{'uid'}\', MAILSUBJECT=\'$QryParm->{'mailsub'}\', MAILATTACH=\'$QryParm->{'mailatt'}\',ACTION=\'$QryParm->{'act'}\'"; - $q .= " WHERE EVENT=\'$QryParm->{'OLDevent'}\' AND UID=\'$QryParm->{'OLDuid'}\' AND ACTION=\'$QryParm->{'OLDact'}\'"; - $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; - } - elsif ($authtable ne "") { - $q = "update $authtable set UID=\'$QryParm->{'uid'}\', RESOURCE=\'$QryParm->{'res'}\', AUTH=\'$QryParm->{'auth'}\'"; - $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\' AND RESOURCE=\'$QryParm->{'OLDres'}\'"; - $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; - } else { die "$QryParm->{'action'} for unknown table"; } - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $$refMsg .= " failed to update $QryParm->{'tbl'} ($err) "; - $$refMsgColor = "red"; - } else { - $$refMsg .= " successfully updated $QryParm->{'tbl'} "; - $$refMsgColor = "green" if ($$refMsgColor ne "red" ); - } + + # query-string must contain all required DB columns values for an sql insert + my $q=''; + if ($QryParm->{'tbl'} eq "user") { + $q = "update $WEBOBS{SQL_TABLE_USERS} set UID=\'$QryParm->{'uid'}\',"; + $q .= " FULLNAME=\'$QryParm->{'fullname'}\', LOGIN=\'$QryParm->{'login'}\',"; + $q .= " EMAIL=\'$QryParm->{'email'}\', VALIDITY=\'$QryParm->{'valid'}\',"; + $q .= " ENDDATE=\'$QryParm->{'enddate'}\', COMMENT=\'$QryParm->{'comment'}\'"; + $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "group") { + $q = "update $WEBOBS{SQL_TABLE_GROUPS} set GID=\'$QryParm->{'gid'}\', UID=\'$QryParm->{'uid'}\'"; + $q .= " WHERE GID=\'$QryParm->{'OLDgid'}\' AND UID=\'$QryParm->{'OLDuid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "notification") { + $q = "update $WEBOBS{SQL_TABLE_NOTIFICATIONS} set EVENT=\'$QryParm->{'event'}\', VALIDITY=\'$QryParm->{'valid'}\', UID=\'$QryParm->{'uid'}\', MAILSUBJECT=\'$QryParm->{'mailsub'}\', MAILATTACH=\'$QryParm->{'mailatt'}\',ACTION=\'$QryParm->{'act'}\'"; + $q .= " WHERE EVENT=\'$QryParm->{'OLDevent'}\' AND UID=\'$QryParm->{'OLDuid'}\' AND ACTION=\'$QryParm->{'OLDact'}\'"; + $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; + } + elsif ($authtable ne "") { + $q = "update $authtable set UID=\'$QryParm->{'uid'}\', RESOURCE=\'$QryParm->{'res'}\', AUTH=\'$QryParm->{'auth'}\'"; + $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\' AND RESOURCE=\'$QryParm->{'OLDres'}\'"; + $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; + } else { die "$QryParm->{'action'} for unknown table"; } + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $$refMsg .= " failed to update $QryParm->{'tbl'} ($err) "; + $$refMsgColor = "red"; + } else { + $$refMsg .= " successfully updated $QryParm->{'tbl'} "; + $$refMsgColor = "green" if ($$refMsgColor ne "red" ); + } } + # ---- process (execute) sql update table 'groups' after user insert or update # ---------------------------------------------------------------------------- if (($QryParm->{'action'} eq 'insert' || $QryParm->{'action'} eq 'update') && $QryParm->{'tbl'} eq "user") { - my $err = set_wo_user_groups($QryParm->{'uid'}, - $cgi->multi_param('gid')); - if ($err) { - $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; - $userMsgColor = "red"; - } else { - $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; - $userMsgColor = "green" if ($userMsgColor ne "red"); - } + my $err = set_wo_user_groups($QryParm->{'uid'}, + $cgi->multi_param('gid')); + if ($err) { + $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; + $userMsgColor = "red"; + } else { + $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; + $userMsgColor = "green" if ($userMsgColor ne "red"); + } } + # ---- process (execute) sql update table 'groups' # ---------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'updgrp') { - my $err = set_wo_group_members($QryParm->{'gid'}, - $cgi->multi_param('uid')); - if ($err) { - $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; - $userMsgColor = "red"; - } else { - $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; - $userMsgColor = "green" if ($userMsgColor ne "red"); - } + my $err = set_wo_group_members($QryParm->{'gid'}, + $cgi->multi_param('uid')); + if ($err) { + $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; + $userMsgColor = "red"; + } else { + $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; + $userMsgColor = "green" if ($userMsgColor ne "red"); + } } + # ---- process (execute) sql delete a row of table 'tbl' # ------------------------------------------------------ if ($QryParm->{'action'} eq 'delete') { - my $q=''; - # query-string must contain all required DB columns values for an sql insert - if ($QryParm->{'tbl'} eq "user") { - $q = "delete from $WEBOBS{SQL_TABLE_USERS}"; - $q .= " WHERE UID=\'$QryParm->{'uid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "group") { - $q = "delete from $WEBOBS{SQL_TABLE_GROUPS}"; - $q .= " WHERE GID=\'$QryParm->{'gid'}\' AND UID=\'$QryParm->{'uid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "notification") { - $q = "delete from $WEBOBS{SQL_TABLE_NOTIFICATIONS}"; - $q .= " WHERE EVENT=\'$QryParm->{'event'}\' AND UID=\'$QryParm->{'uid'}\' AND ACTION=\'$QryParm->{'act'}\'"; - $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; - } - elsif ($authtable ne "") { - $q = "delete from $authtable"; - $q .= " WHERE UID=\'$QryParm->{'uid'}\' AND RESOURCE=\'$QryParm->{'res'}\'"; - $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; - } else { die "$QryParm->{'action'} for unknown table"; } - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $$refMsg .= " failed to delete in $QryParm->{'tbl'} ($err) "; - $$refMsgColor = "red"; - } else { - $$refMsg .= " successfully deleted in $QryParm->{'tbl'} "; - $$refMsgColor = "green" if ($$refMsgColor ne "red"); - } + my $q=''; + + # query-string must contain all required DB columns values for an sql insert + if ($QryParm->{'tbl'} eq "user") { + $q = "delete from $WEBOBS{SQL_TABLE_USERS}"; + $q .= " WHERE UID=\'$QryParm->{'uid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "group") { + $q = "delete from $WEBOBS{SQL_TABLE_GROUPS}"; + $q .= " WHERE GID=\'$QryParm->{'gid'}\' AND UID=\'$QryParm->{'uid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "notification") { + $q = "delete from $WEBOBS{SQL_TABLE_NOTIFICATIONS}"; + $q .= " WHERE EVENT=\'$QryParm->{'event'}\' AND UID=\'$QryParm->{'uid'}\' AND ACTION=\'$QryParm->{'act'}\'"; + $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; + } + elsif ($authtable ne "") { + $q = "delete from $authtable"; + $q .= " WHERE UID=\'$QryParm->{'uid'}\' AND RESOURCE=\'$QryParm->{'res'}\'"; + $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; + } else { die "$QryParm->{'action'} for unknown table"; } + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $$refMsg .= " failed to delete in $QryParm->{'tbl'} ($err) "; + $$refMsgColor = "red"; + } else { + $$refMsg .= " successfully deleted in $QryParm->{'tbl'} "; + $$refMsgColor = "green" if ($$refMsgColor ne "red"); + } } + # ---- process (execute) sql delete # --------------------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'deleteU') { - if ($QryParm->{'tbl'} eq "group") { - my $q = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." WHERE GID='$QryParm->{'gid'}'"; - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $userMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; - $userMsgColor = "red"; - } else { - $userMsg .= " successfully deleted $QryParm->{'tbl'} "; - $userMsgColor = "green" if ($userMsgColor ne "red"); - } - - } - if ($QryParm->{'tbl'} eq "notification") { - my $q = "DELETE FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." WHERE EVENT='$QryParm->{'event'}'"; - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $notfMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; - $notfMsgColor = "red"; - } else { - $notfMsg .= " successfully deleted $QryParm->{'tbl'} "; - $notfMsgColor = "green" if ($notfMsgColor ne "red"); - } - } + if ($QryParm->{'tbl'} eq "group") { + my $q = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." WHERE GID='$QryParm->{'gid'}'"; + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $userMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; + $userMsgColor = "red"; + } else { + $userMsg .= " successfully deleted $QryParm->{'tbl'} "; + $userMsgColor = "green" if ($userMsgColor ne "red"); + } + + } + if ($QryParm->{'tbl'} eq "notification") { + my $q = "DELETE FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." WHERE EVENT='$QryParm->{'event'}'"; + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $notfMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; + $notfMsgColor = "red"; + } else { + $notfMsg .= " successfully deleted $QryParm->{'tbl'} "; + $notfMsgColor = "green" if ($notfMsgColor ne "red"); + } + } } # ---- start html page @@ -310,64 +317,64 @@ =head1 QUERY-STRING PARAMETERS # ---- build users and groups 'select dropdowns contents' # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(UID), FULLNAME" - ." FROM $WEBOBS{SQL_TABLE_USERS} ORDER BY UID"); + "SELECT DISTINCT(UID), FULLNAME" + ." FROM $WEBOBS{SQL_TABLE_USERS} ORDER BY UID"); my $selusers = ""; for my $uid_name (@$db_rows) { - my ($uid, $name) = @$uid_name; - $selusers .= qq(); + my ($uid, $name) = @$uid_name; + $selusers .= qq(); } $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." ORDER BY GID"); + "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." ORDER BY GID"); my $selgrps = ""; for my $row (@$db_rows) { - my ($gid) = @$row; - $selgrps .= ""; + my ($gid) = @$row; + $selgrps .= ""; } # ---- build 'users' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT u.UID,FULLNAME,LOGIN,EMAIL,VALIDITY,ENDDATE,COMMENT," - ."group_concat(GID) AS groups" - ." FROM $WEBOBS{SQL_TABLE_USERS} u" - ." LEFT JOIN $WEBOBS{SQL_TABLE_GROUPS} g" - ." ON (u.uid = g.uid)" - ." GROUP BY u.UID ORDER BY u.UID"); + "SELECT u.UID,FULLNAME,LOGIN,EMAIL,VALIDITY,ENDDATE,COMMENT," + ."group_concat(GID) AS groups" + ." FROM $WEBOBS{SQL_TABLE_USERS} u" + ." LEFT JOIN $WEBOBS{SQL_TABLE_GROUPS} g" + ." ON (u.uid = g.uid)" + ." GROUP BY u.UID ORDER BY u.UID"); my $dusers = ''; my $dusersCount = 0; my $dusersCountValid = 0; my $dusersId = ''; for my $row (@$db_rows) { - my ($dusers_uid, $dusers_fullname, $dusers_login, $dusers_email, - $dusers_validity, $dusers_enddate, $dusers_comment, $dusers_groups) = @$row; - $dusers_groups //= ''; - $dusers_groups =~ s/,/ /g; - $dusersCount++; - $dusersCountValid++ if ($dusers_validity eq 'Y' && ($dusers_enddate eq '' || $dusers_enddate gt $today)); - $dusersId = "udef".$dusersCount; - - # Webobs owner and visitor user row should be grayed and have no edition/deletion link - my $tr_classes = ''; - my $edit_link = ''; - my $del_link = ''; - if ($dusers_uid eq "!" || $dusers_uid eq "?" ) { - $tr_classes = "trlock"; - } else { - if ($dusers_validity ne "Y" || ($dusers_enddate ne "" && $dusers_enddate lt $today)) { - $tr_classes = "troff"; - } - $edit_link = "" - .""; - $del_link = "" - ."" if ($isWO); - } - - # Build user table row (also used as input for the user edition form) - $dusers .= <<_EOD_; + my ($dusers_uid, $dusers_fullname, $dusers_login, $dusers_email, + $dusers_validity, $dusers_enddate, $dusers_comment, $dusers_groups) = @$row; + $dusers_groups //= ''; + $dusers_groups =~ s/,/ /g; + $dusersCount++; + $dusersCountValid++ if ($dusers_validity eq 'Y' && ($dusers_enddate eq '' || $dusers_enddate gt $today)); + $dusersId = "udef".$dusersCount; + +# Webobs owner and visitor user row should be grayed and have no edition/deletion link + my $tr_classes = ''; + my $edit_link = ''; + my $del_link = ''; + if ($dusers_uid eq "!" || $dusers_uid eq "?" ) { + $tr_classes = "trlock"; + } else { + if ($dusers_validity ne "Y" || ($dusers_enddate ne "" && $dusers_enddate lt $today)) { + $tr_classes = "troff"; + } + $edit_link = "" + .""; + $del_link = "" + ."" if ($isWO); + } + + # Build user table row (also used as input for the user edition form) + $dusers .= <<_EOD_; $edit_link $del_link @@ -386,17 +393,17 @@ =head1 QUERY-STRING PARAMETERS # ---- build 'unique groups' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." ORDER BY GID"); + "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." ORDER BY GID"); my $dugrps = ''; my $dugrpsCount = 0; my $dugrpsId = ''; for my $row (@$db_rows) { - my ($gid) = @$row; - $dugrpsCount++; - $dugrpsId="nudef".$dugrpsCount; - $dugrps .= <<_EOD_ + my ($gid) = @$row; + $dugrpsCount++; + $dugrpsId="nudef".$dugrpsCount; + $dugrps .= <<_EOD_ @@ -411,20 +418,20 @@ =head1 QUERY-STRING PARAMETERS # ---- build S'groups' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT GID,GROUP_CONCAT(UID) AS UIDS" - ." FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." GROUP BY GID ORDER BY GID"); + "SELECT GID,GROUP_CONCAT(UID) AS UIDS" + ." FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." GROUP BY GID ORDER BY GID"); my $Sdgrps = ''; my $SdgrpsCount = 0; my $SdgrpsId = ''; for my $row (@$db_rows) { - my ($Sdgrps_gid, $Sdgrps_uids) = @$row; - $Sdgrps_uids =~ s/,/ /g; - $SdgrpsCount++; - $SdgrpsId="gdef".$SdgrpsCount; + my ($Sdgrps_gid, $Sdgrps_uids) = @$row; + $Sdgrps_uids =~ s/,/ /g; + $SdgrpsCount++; + $SdgrpsId="gdef".$SdgrpsCount; - $Sdgrps .= <<_EOD_; + $Sdgrps .= <<_EOD_; @@ -445,19 +452,19 @@ =head1 QUERY-STRING PARAMETERS # ---- build 'unique evnt notifications' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(EVENT)" - ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." ORDER BY EVENT"); + "SELECT DISTINCT(EVENT)" + ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." ORDER BY EVENT"); my $dunotf = ''; my $dunotfCount = 0; my $dunotfId = ''; for my $row (@$db_rows) { - my ($event) = @$row; - $dunotfCount++; - $dunotfId="nudef".$dunotfCount; - $dunotf .= <<_EOD_; + my ($event) = @$row; + $dunotfCount++; + $dunotfId="nudef".$dunotfCount; + $dunotf .= <<_EOD_; @@ -472,20 +479,20 @@ =head1 QUERY-STRING PARAMETERS # ---- build 'notifications' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT EVENT,VALIDITY,UID,MAILSUBJECT,MAILATTACH,ACTION" - ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." ORDER BY 1"); + "SELECT EVENT,VALIDITY,UID,MAILSUBJECT,MAILATTACH,ACTION" + ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." ORDER BY 1"); my $dnotf = ''; my $dnotfCount = 0; my $dnotfId = ''; for my $row (@$db_rows) { - my ($dnotf_event, $dnotf_valid, $dnotf_mail, $dnotf_mailsubj, - $dnotf_mailatt, $dnotf_act) = @$row; + my ($dnotf_event, $dnotf_valid, $dnotf_mail, $dnotf_mailsubj, + $dnotf_mailatt, $dnotf_act) = @$row; - $dnotfCount++; - $dnotfId="ndef".$dnotfCount; - $dnotf .= <<_EOD_; + $dnotfCount++; + $dnotfId="ndef".$dnotfCount; + $dnotf .= <<_EOD_; @@ -512,44 +519,43 @@ =head1 QUERY-STRING PARAMETERS my $postboardstatus=""; my @PBREPLY = qx($WEBOBS{ROOT_CODE}/shells/postboard status); if ( scalar(@PBREPLY) > 0 ) { - my @td1 = map {$_ =~ s/\n/
    /; $_} (grep { /STATTIME=|STARTED=|PID=|USER=/ } @PBREPLY); - s/POSTBOARD NOT RUNNING/POSTBOARD NOT RUNNING<\/span>/ for @td1; - my @td2 = map {$_ =~ s/\n/
    /; $_} (grep { /FIFO=|LOG=/ } @PBREPLY); - $postboardstatus = "
    @td1@td2
    " + my @td1 = map {$_ =~ s/\n/
    /; $_} (grep { /STATTIME=|STARTED=|PID=|USER=/ } @PBREPLY); + s/POSTBOARD NOT RUNNING/POSTBOARD NOT RUNNING<\/span>/ for @td1; + my @td2 = map {$_ =~ s/\n/
    /; $_} (grep { /FIFO=|LOG=/ } @PBREPLY); + $postboardstatus = "
    @td1@td2
    " } else { $postboardstatus = "POSTBOARD IS NOT RUNNING !"} - # ---- build 'auth' table result rows # ----------------------------------------------------------------------------- my %TA; for my $an (qw(proc view form wiki misc)) { - my %auth_tablenames = ( - "proc" => $WEBOBS{SQL_TABLE_AUTHPROCS}, - "view" => $WEBOBS{SQL_TABLE_AUTHVIEWS}, - "form" => $WEBOBS{SQL_TABLE_AUTHFORMS}, - "wiki" => $WEBOBS{SQL_TABLE_AUTHWIKIS}, - "misc" => $WEBOBS{SQL_TABLE_AUTHMISC}, - ); - $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT UID,RESOURCE,AUTH FROM $auth_tablenames{$an}" - ." ORDER BY UID,RESOURCE"); - $TA{$an}{dauth} = ''; - $TA{$an}{dauthCount} = 0; - - for my $row (@$db_rows) { - my ($dauth_uid, $dauth_res, $dauth_auth) = @$row; - - my $td_modif_auth = ''; - my $td_delete_auth = ''; - $TA{$an}{dauthCount}++; - my $dauthId="adef$an".$TA{$an}{dauthCount}; - if ($dauth_uid ne '!' || $isWO) { - $td_modif_auth = "    " - .""; - $td_delete_auth = "" - .""; - } - $TA{$an}{dauth} .= <<_EOD_; + my %auth_tablenames = ( + "proc" => $WEBOBS{SQL_TABLE_AUTHPROCS}, + "view" => $WEBOBS{SQL_TABLE_AUTHVIEWS}, + "form" => $WEBOBS{SQL_TABLE_AUTHFORMS}, + "wiki" => $WEBOBS{SQL_TABLE_AUTHWIKIS}, + "misc" => $WEBOBS{SQL_TABLE_AUTHMISC}, + ); + $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, + "SELECT UID,RESOURCE,AUTH FROM $auth_tablenames{$an}" + ." ORDER BY UID,RESOURCE"); + $TA{$an}{dauth} = ''; + $TA{$an}{dauthCount} = 0; + + for my $row (@$db_rows) { + my ($dauth_uid, $dauth_res, $dauth_auth) = @$row; + + my $td_modif_auth = ''; + my $td_delete_auth = ''; + $TA{$an}{dauthCount}++; + my $dauthId="adef$an".$TA{$an}{dauthCount}; + if ($dauth_uid ne '!' || $isWO) { + $td_modif_auth = "" + .""; + $td_delete_auth = "" + .""; + } + $TA{$an}{dauth} .= <<_EOD_; $td_modif_auth $td_delete_auth @@ -558,7 +564,7 @@ =head1 QUERY-STRING PARAMETERS $dauth_auth _EOD_ - } + } } # ---- assemble the page @@ -789,10 +795,10 @@ =head1 QUERY-STRING PARAMETERS

    EOPART2 - print ""; - print "
    "; - for my $i (qw(view proc form)) { - print <<"EOAUTH1" +print ""; +print "
    "; +for my $i (qw(view proc form)) { + print <<"EOAUTH1"
    $i
    @@ -809,13 +815,13 @@ =head1 QUERY-STRING PARAMETERS
    EOAUTH1 - } - print "
    "; +} +print "
    "; - print ""; - print ""); + +# il faut balayer 6 semaines pour être sûr d'avoir le mois complet dans toutes les situations... + for (0..41) { + $j = qx(date -I -d "$lundiCalendrier $_ days"); chomp($j); + if (($_ % 7) == 0) { + if (($_ != 0) && (substr($j,5,2) ne substr($moisCalendrier,5,2))) { + last; + } else { + +#$s = qx(date -d "$j" +"\%W"); chomp($s); +# permet de choisir le n° semaine suivant l'année du calendrier (dernière semaine Y ou première semaine Y+1) + if (substr($j,0,4) != $anneeCalendrier) { $s = qx(date -d "$j 6 days" +%V); } + else { $s = qx(date -d "$j" +%V); } + chomp($s); + +#push(@contenu,"\n"); + push(@contenu,"\n"); + } + } + if (substr($j,5,2) ne substr($moisCalendrier,5,2)) { + $s = "class=\"CalendarOutMonth\""; + } else { + $s = "class=\"CalendarInMonth\""; + if (($_%7) >= 5) { $s = "class=\"CalendarWeekend\""; } + my @jf = grep(/$j/,@feries); + if (@jf and length($jf[0]) > 0) { + my ($dd,$ss) = split(/\|/,$jf[0]); + chomp($ss); + $ss =~ s/\'/’/g; + $ss =~ s/\"/"/g; + $s = "class=\"CalendarFerie\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\""; + } + } + if ($j eq $todayDate) { $s = "class=\"CalendarToday\""; } + push(@contenu,""); + } + push(@contenu,"
    "; - for my $i (qw(wiki misc)) { - print <<"EOAUTH2" +print ""; +print "\n"; +print "
    "; +for my $i (qw(wiki misc)) { + print <<"EOAUTH2"
    $i
    @@ -844,87 +850,90 @@ =head1 QUERY-STRING PARAMETERS # Connect to the database and return the handler # ------------------------------------------------------------------------------ sub db_connect { - # Open a connection to a SQLite database using RaiseError. - # - # Usage example: - # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) - # || die "Error connecting to $dbname: $DBI::errstr"; - # - my $dbname = shift; - my $opts = shift || {}; - my %default_options = ( - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - ); - my %options = (%default_options, %$opts); - return DBI->connect("dbi:SQLite:$dbname", "", "", \%options); -} + # Open a connection to a SQLite database using RaiseError. + # + # Usage example: + # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) + # || die "Error connecting to $dbname: $DBI::errstr"; + # + my $dbname = shift; + my $opts = shift || {}; + my %default_options = ( + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + ); + my %options = (%default_options, %$opts); + return DBI->connect("dbi:SQLite:$dbname", "", "", \%options); +} # Fetch and return all results of a select statement # ----------------------------------------------------------------------------- sub fetch_all { - # - # Connect to a database, run the given SQL statement, and - # return a reference to an array of array references. - # - my $dbname = shift; - my $query = shift; - - my $dbh = db_connect($dbname); - if (not $dbh) { - logit("Error connecting to $dbname: $DBI::errstr"); - return; - } - # Will raise an error if anything goes wrong - my $ref = $dbh->selectall_arrayref($query); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $dbname: ".$dbh->errstr; - return $ref; + # + # Connect to a database, run the given SQL statement, and + # return a reference to an array of array references. + # + my $dbname = shift; + my $query = shift; + + my $dbh = db_connect($dbname); + if (not $dbh) { + logit("Error connecting to $dbname: $DBI::errstr"); + return; + } + + # Will raise an error if anything goes wrong + my $ref = $dbh->selectall_arrayref($query); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $dbname: ".$dbh->errstr; + return $ref; } # Atomatically execute a list of queries # ----------------------------------------------------------------------------- sub execute_queries { - # - # Connect to a database and atomically execute the given SQL - # statements, using DBI->do(). - # Log error or warning to stderr/logs if anything goes wrong. - # Return an empty string on success, the error message otherwise. - # - my $dbname = shift; - my @queries = @_; - my $err_msg = ""; - - my $dbh = db_connect($dbname, {'AutoCommit' => 0}); - if (not $dbh) { - logit("Error connecting to $dbname: $DBI::errstr"); - return $DBI::errstr; - } - try { - for my $q (@queries) { - $dbh->do($q); - } - } catch { - # Catch errors to show them to the user - # (Try::Tiny sets $_ to the exception message) - $err_msg = $_; - # Log the queries for information (the error is already logged by DBI, - # as we use the PrintError option). - warn "Error while executing queries '".join("; ", @queries) - ." (rolling back)"; - eval { $dbh->rollback() }; # rollback might fail - }; - if (not $err_msg) { - $dbh->commit(); - } - $dbh->disconnect() - or CORE::warn "Got warning while disconnecting from $dbname: " - .$dbh->errstr; - - return $err_msg; + # + # Connect to a database and atomically execute the given SQL + # statements, using DBI->do(). + # Log error or warning to stderr/logs if anything goes wrong. + # Return an empty string on success, the error message otherwise. + # + my $dbname = shift; + my @queries = @_; + my $err_msg = ""; + + my $dbh = db_connect($dbname, {'AutoCommit' => 0}); + if (not $dbh) { + logit("Error connecting to $dbname: $DBI::errstr"); + return $DBI::errstr; + } + try { + for my $q (@queries) { + $dbh->do($q); + } + } catch { + + # Catch errors to show them to the user + # (Try::Tiny sets $_ to the exception message) + $err_msg = $_; + + # Log the queries for information (the error is already logged by DBI, + # as we use the PrintError option). + warn "Error while executing queries '".join("; ", @queries) + ." (rolling back)"; + eval { $dbh->rollback() }; # rollback might fail + }; + if (not $err_msg) { + $dbh->commit(); + } + $dbh->disconnect() + or CORE::warn "Got warning while disconnecting from $dbname: " + .$dbh->errstr; + + return $err_msg; } # ------------------------------------------------------------------------------ @@ -933,23 +942,23 @@ sub execute_queries { # occured and the gropu members could not be updated. # sub set_wo_group_members { - my $gid = shift; # group GID - my @uids = @_; # UIDs of group members - - # Insert members of the group - my @values = map { "('$gid', '$_')" } @uids; - my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " - .join(',', @values); - - # Delete any removed members from the group. This is done _after_ we have - # inserted new members to prevent the group from having no member for a - # short while, as the SQL trigger on the 'groups' table would remove the - # group entries in 'auth*' and 'notifications' tables. - my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." WHERE GID='$gid' AND UID NOT IN (" - .join(",", map { "'$_'" } @uids).")"; - - return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); + my $gid = shift; # group GID + my @uids = @_; # UIDs of group members + + # Insert members of the group + my @values = map { "('$gid', '$_')" } @uids; + my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " + .join(',', @values); + + # Delete any removed members from the group. This is done _after_ we have + # inserted new members to prevent the group from having no member for a + # short while, as the SQL trigger on the 'groups' table would remove the + # group entries in 'auth*' and 'notifications' tables. + my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." WHERE GID='$gid' AND UID NOT IN (" + .join(",", map { "'$_'" } @uids).")"; + + return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); } # ------------------------------------------------------------------------------ @@ -958,26 +967,25 @@ sub set_wo_group_members { # occured and the memberships could not be updated. # sub set_wo_user_groups { - my $uid = shift; # user UID - my @gids = @_; # GIDs of groups the user is a member of - - # Insert the user in its groups - my @values = map { "('$_', '$uid')" } @gids; - my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " - .join(',', @values); - - # Delete any group membership for the user. This is done _after_ we have - # inserted new memberships to prevent any group from having no member for - # a short while, as the SQL trigger on the 'groups' table would remove the - # group entries in 'auth*' and 'notifications' tables. - my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS} " - ."WHERE UID='$uid' AND GID NOT IN (" - .join(",", map { "'$_'" } @gids).")"; - - return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); + my $uid = shift; # user UID + my @gids = @_; # GIDs of groups the user is a member of + + # Insert the user in its groups + my @values = map { "('$_', '$uid')" } @gids; + my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " + .join(',', @values); + + # Delete any group membership for the user. This is done _after_ we have + # inserted new memberships to prevent any group from having no member for + # a short while, as the SQL trigger on the 'groups' table would remove the + # group entries in 'auth*' and 'notifications' tables. + my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS} " + ."WHERE UID='$uid' AND GID NOT IN (" + .join(",", map { "'$_'" } @gids).")"; + + return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); } - __END__ =pod diff --git a/CODE/cgi-bin/vedit.pl b/CODE/cgi-bin/vedit.pl index 7dc3f277..bca2fdaa 100755 --- a/CODE/cgi-bin/vedit.pl +++ b/CODE/cgi-bin/vedit.pl @@ -146,38 +146,40 @@ =head1 Markitup customization my $tz = ""; if ($action =~ /upd|new|del|save/i) { - if (defined($GRIDType)) { - $isProject = ($evpath =~ /$NODEName\_Projet.txt/); - if (clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - if ( $isProject && basename($evpath) ne $evpath ) { die $__{'invalid project name'} } - if ( $action =~ /upd|del/i && $evpath !~ /.*\.txt$/i) { die "\"$evpath\" $__{'invalid for action'} $action" } - if ( $action =~ /upd|del/i && !-f "$evbase/$evpath") { die "\"$evpath\" $__{'not found'}" } - if ( $action =~ /new/i && -f "$evbase/$evpath" ) { $action = 'upd' } # new on existing: force upd ! - } else { - die "$__{'Not authorized'}"; - } - } else { - die "$__{'invalid event object'}"; - } + if (defined($GRIDType)) { + $isProject = ($evpath =~ /$NODEName\_Projet.txt/); + if (clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + if ( $isProject && basename($evpath) ne $evpath ) { die $__{'invalid project name'} } + if ( $action =~ /upd|del/i && $evpath !~ /.*\.txt$/i) { die "\"$evpath\" $__{'invalid for action'} $action" } + if ( $action =~ /upd|del/i && !-f "$evbase/$evpath") { die "\"$evpath\" $__{'not found'}" } + if ( $action =~ /new/i && -f "$evbase/$evpath" ) { $action = 'upd' } # new on existing: force upd ! + } else { + die "$__{'Not authorized'}"; + } + } else { + die "$__{'invalid event object'}"; + } } else { - die "$__{'No or invalid action'}"; + die "$__{'No or invalid action'}"; } my $objectfullname; my %NODE; my %GRID; + # object if a node (gridtype.gridname.nodename) if ($object =~ /^.*\..*\..*$/) { - my %S = readNode($NODEName); - %NODE = %{$S{$NODEName}}; - $objectfullname = "$NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})"; - $tz = $NODE{TZ}; -# ... or a grid (gridtype.gridname) + my %S = readNode($NODEName); + %NODE = %{$S{$NODEName}}; + $objectfullname = "$NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})"; + $tz = $NODE{TZ}; + + # ... or a grid (gridtype.gridname) } else { - my %S = readGrid($object); - %GRID = %{$S{$object}}; - $objectfullname = "$GRID{NAME}"; - $tz = $GRID{TZ}; + my %S = readGrid($object); + %GRID = %{$S{$object}}; + $objectfullname = "$GRID{NAME}"; + $tz = $GRID{TZ}; } # --------------------------------------------------------------------------------------- @@ -185,85 +187,90 @@ =head1 Markitup customization # write event's form elements to event file (object,event,formelements) # if ($action =~ /save/i ) { - my $logmsg = ""; - my @lines; - # determine $target which is the full path to the event file we want to 'save' - # from $evbase which is the events (=interventions) root directory path - # and $evpath (event= in querystring) which is the event file name relative to $evbase: - # $evpath is: "subpath/evname.txt" OR "subpath" OR "" - $target = "$evbase/$evpath"; - # extract the event's file name from $evpath and make sure the path exists - my $evname = ($evpath =~ /.*\.txt$/) ? basename($evpath) : ""; - - my $tline = join("+",@oper)."/".join("+",@roper)."|$titre"; - if (!$isProject) { - $tline .= "|$date2 $time2|$feature|$channel|$outcome|$notebook|$notebookfwd"; - # now build an event's file name from form's elements - $time =~ s/:/-/; - my $formname = "$NODEName\_$date\_$time.txt"; - if ($evname eq "") { # no *txt specified, use $formname (new event) - $target = "$evbase/$evpath/$formname"; - WebObs::Events::versionit(\$target); - my $fp = dirname($target); qx(mkdir -p "$fp" 2>/dev/null); - } else { - # moving an event - if ($mvnode ne "" && $mvnode ne $NODEName) { - (my $object2 = $object) =~ s/$NODEName/$mvnode/; - (my $evpath2 = $evpath) =~ s/$NODEName/$mvnode/; - my ($GRIDType2, $GRIDName2, $NODEName2, $evbase2, $evtrash2) = WebObs::Events::struct(trim($object2)); - my $formname2 = "$mvnode\_$date\_$time.txt"; - my $evname2 = ($evpath2 =~ /.*\.txt$/) ? basename($evpath2) : ""; - $target = "$evbase2/$formname2"; - WebObs::Events::versionit(\$target); - my $fp = dirname($target); - qx(mkdir -p "$fp" 2>/dev/null); - (my $evsrc = $evname2) =~ s/.txt//; - (my $evtgt = $formname2) =~ s/.txt//; - $logmsg .= "moving event $evpath to $evname2\n"; - qx(mv "$evbase/$evpath" $target); # rename event file - qx(mv "$evbase/$evsrc/" "$evbase2/$evtgt"); # rename event extensions dir - qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file - $logmsg .= "deleting gazette $evpath\n"; - my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); - } - # renaming of an event (*.txt != $formname) - elsif ($evname ne $formname) { - $target = dirname("$evbase/$evpath")."/$formname"; - WebObs::Events::versionit(\$target); - my $fp = dirname($target); - qx(mkdir -p "$fp" 2>/dev/null); - (my $evsrc = $evname) =~ s/.txt//; - (my $evtgt = $formname) =~ s/.txt//; - $logmsg .= "renaming event $evpath\n"; - qx(mv "$evbase/$evpath" $target); # rename event file - qx(mv "$evbase/$evsrc/" "$evbase/$evtgt"); # rename event extensions dir - qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file - $logmsg .= "deleting gazette $evpath\n"; - my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); - } - } - } - $logmsg .= "saving ".basename($target); - if ( sysopen(FILE, "$target", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $target..."; - flock(FILE, LOCK_EX); - } - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - if ($conv eq "1") { # add MMD - $contents = WebObs::Wiki::wiki2MMD($contents); - $contents = "WebObs: converted with wiki2MMD\n\n$contents"; - } - $contents =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lines,$tline."\n"); - push(@lines,$contents); - print FILE @lines; - close(FILE); - htmlMsgOK("$logmsg"); - } else { htmlMsgNotOK("$logmsg\nerror $! opening ".basename($target)) } - - exit; + my $logmsg = ""; + my @lines; + +# determine $target which is the full path to the event file we want to 'save' +# from $evbase which is the events (=interventions) root directory path +# and $evpath (event= in querystring) which is the event file name relative to $evbase: +# $evpath is: "subpath/evname.txt" OR "subpath" OR "" + $target = "$evbase/$evpath"; + + # extract the event's file name from $evpath and make sure the path exists + my $evname = ($evpath =~ /.*\.txt$/) ? basename($evpath) : ""; + + my $tline = join("+",@oper)."/".join("+",@roper)."|$titre"; + if (!$isProject) { + $tline .= "|$date2 $time2|$feature|$channel|$outcome|$notebook|$notebookfwd"; + + # now build an event's file name from form's elements + $time =~ s/:/-/; + my $formname = "$NODEName\_$date\_$time.txt"; + if ($evname eq "") { # no *txt specified, use $formname (new event) + $target = "$evbase/$evpath/$formname"; + WebObs::Events::versionit(\$target); + my $fp = dirname($target); qx(mkdir -p "$fp" 2>/dev/null); + } else { + + # moving an event + if ($mvnode ne "" && $mvnode ne $NODEName) { + (my $object2 = $object) =~ s/$NODEName/$mvnode/; + (my $evpath2 = $evpath) =~ s/$NODEName/$mvnode/; + my ($GRIDType2, $GRIDName2, $NODEName2, $evbase2, $evtrash2) = WebObs::Events::struct(trim($object2)); + my $formname2 = "$mvnode\_$date\_$time.txt"; + my $evname2 = ($evpath2 =~ /.*\.txt$/) ? basename($evpath2) : ""; + $target = "$evbase2/$formname2"; + WebObs::Events::versionit(\$target); + my $fp = dirname($target); + qx(mkdir -p "$fp" 2>/dev/null); + (my $evsrc = $evname2) =~ s/.txt//; + (my $evtgt = $formname2) =~ s/.txt//; + $logmsg .= "moving event $evpath to $evname2\n"; + qx(mv "$evbase/$evpath" $target); # rename event file + qx(mv "$evbase/$evsrc/" "$evbase2/$evtgt"); # rename event extensions dir + qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file + $logmsg .= "deleting gazette $evpath\n"; + my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); + } + + # renaming of an event (*.txt != $formname) + elsif ($evname ne $formname) { + $target = dirname("$evbase/$evpath")."/$formname"; + WebObs::Events::versionit(\$target); + my $fp = dirname($target); + qx(mkdir -p "$fp" 2>/dev/null); + (my $evsrc = $evname) =~ s/.txt//; + (my $evtgt = $formname) =~ s/.txt//; + $logmsg .= "renaming event $evpath\n"; + qx(mv "$evbase/$evpath" $target); # rename event file + qx(mv "$evbase/$evsrc/" "$evbase/$evtgt"); # rename event extensions dir + qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file + $logmsg .= "deleting gazette $evpath\n"; + my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); + } + } + } + $logmsg .= "saving ".basename($target); + if ( sysopen(FILE, "$target", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $target..."; + flock(FILE, LOCK_EX); + } + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + if ($conv eq "1") { # add MMD + $contents = WebObs::Wiki::wiki2MMD($contents); + $contents = "WebObs: converted with wiki2MMD\n\n$contents"; + } + $contents =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lines,$tline."\n"); + push(@lines,$contents); + print FILE @lines; + close(FILE); + htmlMsgOK("$logmsg"); + } else { htmlMsgNotOK("$logmsg\nerror $! opening ".basename($target)) } + + exit; } # --------------------------------------------------------------------------------------- @@ -271,27 +278,31 @@ =head1 Markitup customization # delete actually is a 'move' to a shared EVENT trash directory # if ($action =~ /del/i ) { - #dbg# $msg .= "deleting \no=$object\nb=$evbase\nt=$evtrash\ne=$evpath\nE=$evp"; - (my $evp = $evpath) =~ s/\.txt$//; - # list (@tree) all children of event to delete from its eventTree() - my @tree = ("$evbase/$evpath"); my $msg = ""; my $rc = ""; my $rcd = 0; - WebObs::Events::eventsTree(\@tree,"$evbase/$evp"); - grep {s/^\Q$evbase\E\///} @tree; - #dbg# $msg .= "\ntree=\n"; for (@tree) { $msg .= "* $_\n"}; - # delete event and all of its children - $msg .= "deleting $evpath and children\n"; - $rc = WebObs::Events::deleteit($evbase, $evtrash, $evpath); - # if events are gone, remove their reference in Gazette (from @tree) - if ($rc eq 'OK') { - if (isok($GazetteDel)) { - for (@tree) { $rcd += WebObs::Gazette::delEventArticle($object,$_); } - $msg .= " $rcd $__{'article removed from Gazette'}"; - } - htmlMsgOK($msg); - } else { - htmlMsgNotOK("$msg\nError $rc"); - } - exit; + + #dbg# $msg .= "deleting \no=$object\nb=$evbase\nt=$evtrash\ne=$evpath\nE=$evp"; + (my $evp = $evpath) =~ s/\.txt$//; + + # list (@tree) all children of event to delete from its eventTree() + my @tree = ("$evbase/$evpath"); my $msg = ""; my $rc = ""; my $rcd = 0; + WebObs::Events::eventsTree(\@tree,"$evbase/$evp"); + grep {s/^\Q$evbase\E\///} @tree; + + #dbg# $msg .= "\ntree=\n"; for (@tree) { $msg .= "* $_\n"}; + # delete event and all of its children + $msg .= "deleting $evpath and children\n"; + $rc = WebObs::Events::deleteit($evbase, $evtrash, $evpath); + + # if events are gone, remove their reference in Gazette (from @tree) + if ($rc eq 'OK') { + if (isok($GazetteDel)) { + for (@tree) { $rcd += WebObs::Gazette::delEventArticle($object,$_); } + $msg .= " $rcd $__{'article removed from Gazette'}"; + } + htmlMsgOK($msg); + } else { + htmlMsgNotOK("$msg\nError $rc"); + } + exit; } # --------------------------------------------------------------------------------------- @@ -310,19 +321,20 @@ =head1 Markitup customization # (object,event) # if ($action =~ /new/i ) { - if (!$isProject) { - $date = $today->strftime('%Y-%m-%d'); - $time = $today->strftime('%H:%M'); - $date2 = $date; - $time2 = $time; - $pagetitle = "$__{'Create Event'}"; - # fool parents() with a pseudo (xx) evntname if needed - $parents = WebObs::Events::parents($evbase, "$evpath/xx") if ($evpath ne "" && $parents eq ""); - $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; - } else { - $pagetitle = "$__{'Create Project'}"; - } - $meta = "WebObs: created by vedit \n\n" if ($mmd ne 'NO'); # add MMD + if (!$isProject) { + $date = $today->strftime('%Y-%m-%d'); + $time = $today->strftime('%H:%M'); + $date2 = $date; + $time2 = $time; + $pagetitle = "$__{'Create Event'}"; + + # fool parents() with a pseudo (xx) evntname if needed + $parents = WebObs::Events::parents($evbase, "$evpath/xx") if ($evpath ne "" && $parents eq ""); + $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; + } else { + $pagetitle = "$__{'Create Project'}"; + } + $meta = "WebObs: created by vedit \n\n" if ($mmd ne 'NO'); # add MMD } # --------------------------------------------------------------------------------------- @@ -330,29 +342,29 @@ =head1 Markitup customization # (object,event) # if ($action =~ /upd/i ) { - if (!$isProject) { - my ($fname,$ft) = split(/\./,basename($evpath)); - ($name,$date,$time,$version) = WebObs::Events::eventnameSplit(basename($fname)); - $time =~ s/-/:/; - $time =~ s/NA//; - $pagetitle = "$__{'Edit Event'} [$date $time".($tz ne "" ? " ($tz)":"")." $version]"; - $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; - } else { - $pagetitle = "$__{'Edit Project'}"; - } - - # event metadata are stored in the header line of file as pipe-separated fields: - # UID1[+UID2+...]/RUID1[+RUID2+...]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd - # event text content - # ... - @lines = readFile("$evbase/$evpath"); - chomp(@lines); - (my $authors,my $remotes,$titre,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); - @oper = @$authors; - @roper = @$remotes; - shift(@lines); - $contents = join("\n",@lines); - ($contents, $meta) = WebObs::Wiki::stripMDmetadata($contents); + if (!$isProject) { + my ($fname,$ft) = split(/\./,basename($evpath)); + ($name,$date,$time,$version) = WebObs::Events::eventnameSplit(basename($fname)); + $time =~ s/-/:/; + $time =~ s/NA//; + $pagetitle = "$__{'Edit Event'} [$date $time".($tz ne "" ? " ($tz)":"")." $version]"; + $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; + } else { + $pagetitle = "$__{'Edit Project'}"; + } + +# event metadata are stored in the header line of file as pipe-separated fields: +# UID1[+UID2+...]/RUID1[+RUID2+...]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd +# event text content +# ... + @lines = readFile("$evbase/$evpath"); + chomp(@lines); + (my $authors,my $remotes,$titre,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); + @oper = @$authors; + @roper = @$remotes; + shift(@lines); + $contents = join("\n",@lines); + ($contents, $meta) = WebObs::Wiki::stripMDmetadata($contents); } # ---- wodp stuff @@ -367,6 +379,7 @@ =head1 Markitup customization while() { push(@holidaysdef,l2u($_)) if ($_ !~/^(#|$)/); }; close(FILE); chomp(@holidaysdef); my $wodp_holidays = "[".join(',',map { my ($d,$t)=split(/\|/,$_); "{d: \"$d\", t:\"$t\"}" } @holidaysdef)."]"; + # ---- end wodp stuff # ---- html page @@ -386,10 +399,10 @@ =head1 Markitup customization "; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print " @@ -398,7 +411,7 @@ =head1 Markitup customization # javascript for Event form (not Project) # if (!$isProject) { - print ""; -# javascript for Project form -# + + # javascript for Project form + # } else { - print ""; } + # resume common for Project and Event # print " @@ -505,176 +520,180 @@ =head1 Markitup customization print "
    $parents" if ($parents ne ""); print ""; print "
    "; - print ""; - print "\n"; +print "\n\n\n\n"; - print "
    "; - if (!$isProject) { - print " "; - print "".($tz ne "" ? " GMT $tz":"")."

    \n"; - print " "; - print "".($tz ne "" ? " GMT $tz":"")."

    \n"; - } - print "

    \n"; - # only for node's event - if ($object =~ /^.*\..*\..*$/) { - print "

    \n"; - # only if node associated to a proc and calibration file defined - my $clbFile = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; - if (-s $clbFile != 0) { - print ""; - my @carCLB = readCfgFile($clbFile); - # make a list of available channels and label them with last Chan. + Loc. codes - my %chan; - for (@carCLB) { - my (@chpCLB) = split(/\|/,$_); - $chan{$chpCLB[2]} = "$chpCLB[2]: $chpCLB[3] ($chpCLB[6] $chpCLB[19])"; - } - print "

    \n"; - } else { - print "\n"; - } - print "$__{'Sensor/data outcome'}: "; - if (isok($NODES{EVENTNODE_NOTEBOOK})) { - print "$__{'Notebook Nb'}: "; - print "$__{'Forward to notebook'}: "; - } else { - print "\n"; - print "\n"; - } - } - print "    		"; - print "$__{'Author(s)'}:
    "; +if (!$isProject) { + print " "; + print "".($tz ne "" ? " GMT $tz":"")."

    \n"; + print " "; + print "".($tz ne "" ? " GMT $tz":"")."

    \n"; +} +print "

    \n"; + +# only for node's event +if ($object =~ /^.*\..*\..*$/) { + print "

    \n"; + + # only if node associated to a proc and calibration file defined + my $clbFile = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; + if (-s $clbFile != 0) { + print ""; + my @carCLB = readCfgFile($clbFile); + + # make a list of available channels and label them with last Chan. + Loc. codes + my %chan; + for (@carCLB) { + my (@chpCLB) = split(/\|/,$_); + $chan{$chpCLB[2]} = "$chpCLB[2]: $chpCLB[3] ($chpCLB[6] $chpCLB[19])"; + } + print "

    \n"; + } else { + print "\n"; + } + print "$__{'Sensor/data outcome'}: "; + if (isok($NODES{EVENTNODE_NOTEBOOK})) { + print "$__{'Notebook Nb'}: "; + print "$__{'Forward to notebook'}: "; + } else { + print "\n"; + print "\n"; + } +} +print "    		"; +print "$__{'Author(s)'}:
    \n"; - print "    		"; - print "$__{'Remote Operator(s)'}:
    \n"; +print "    		"; +print "$__{'Remote Operator(s)'}:
    "; - print "

    "; - print "

    $__{Notify} (email)"; - # moves event to another node - if (!($action =~ /new/i) && $object =~ /^.*\..*\..*$/ && !$isProject) { - my @allNodes = qx(/bin/ls $NODES{PATH_NODES}); - chomp(@allNodes); - print "\n$__{'Move this event to another node'}: \n"; - } - print "

    \n

    "; - print ""; - if (length($meta) == 0 && $mmd ne 'NO') { - print " MMD'}\" onClick=\"convert2MMD();\" style=\"font-weight:normal\">"; - } - print ""; - print ""; - print ""; - print ""; - print ""; - print ""; - print "\n"; - print "

    "; - print "
    "; +for my $ulogin (@logins) { + my $uid = $USERS{$ulogin}{UID}; + my $sel = ((grep {$_ eq $uid} @roper) ? 'selected':''); + print "\n"; +} +print "
    "; +print "

    "; +print "

    $__{Notify} (email)"; + +# moves event to another node +if (!($action =~ /new/i) && $object =~ /^.*\..*\..*$/ && !$isProject) { + my @allNodes = qx(/bin/ls $NODES{PATH_NODES}); + chomp(@allNodes); + print "\n$__{'Move this event to another node'}: \n"; +} +print "

    \n

    "; +print ""; +if (length($meta) == 0 && $mmd ne 'NO') { + print " MMD'}\" onClick=\"convert2MMD();\" style=\"font-weight:normal\">"; +} +print ""; +print ""; +print ""; +print ""; +print ""; +print ""; +print "\n"; +print "

    "; +print "
    "; print "\n"; print "\n\n\n"; - # ---- helpers fns to process Gazette and return 'save' information to client # sub htmlMsgOK { - my $msg = "$_[0]\n"; - my $rcd = 0; - if ($send2Gazette) { - if (isok($GazetteDel) && $target ne "") { - $rcd = WebObs::Gazette::delEventArticle($object,$target); - $msg .= "\n+ ".basename($target)." $__{'removed from Gazette'}" if ($rcd != 0); - } - $rcd = WebObs::Gazette::setEventArticle($object,$target,$titre,join('+',@oper),$date2."_".$time2); - $msg .= "+ ".basename($target)." $__{'written to Gazette'}\n" if ($rcd =~ /1 row.*/); - } - if ( $notify eq 'OK' ) { - my $t = notify(); - $msg .= "+ Notify ok" if ( $t == 0 ); - $msg .= "+ Notify error $t" if ( $t > 0); - } - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "$msg\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); + my $msg = "$_[0]\n"; + my $rcd = 0; + if ($send2Gazette) { + if (isok($GazetteDel) && $target ne "") { + $rcd = WebObs::Gazette::delEventArticle($object,$target); + $msg .= "\n+ ".basename($target)." $__{'removed from Gazette'}" if ($rcd != 0); + } + $rcd = WebObs::Gazette::setEventArticle($object,$target,$titre,join('+',@oper),$date2."_".$time2); + $msg .= "+ ".basename($target)." $__{'written to Gazette'}\n" if ($rcd =~ /1 row.*/); + } + if ( $notify eq 'OK' ) { + my $t = notify(); + $msg .= "+ Notify ok" if ( $t == 0 ); + $msg .= "+ Notify error $t" if ( $t > 0); + } + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "$msg\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); } sub htmlMsgNotOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "$_[0]\n$__{'FAILED'} !\n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "$_[0]\n$__{'FAILED'} !\n"; } # ---- notify # sub notify { - my $eventname = "eventnode"; - my $senderId = $USERS{$CLIENT}{UID}; - my $names = join(", ",WebObs::Users::userName(@oper))."/".join(", ",WebObs::Users::userName(@roper)); - my $msg = ''; - my $isnode = ($object =~ /^.*\..*\..*$/ ? 1:0); - - $msg .= "$__{'New event'} WebObs-$WEBOBS{WEBOBS_ID}.\n\n"; - if ($isnode) { - my %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); - $msg .= "$__{'Node'}: {$NODEName} $NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})\n"; - $msg .= "$__{'Grids'}: @{$allNodeGrids{$NODEName}}\n"; - } else { - $msg .= "$__{'Grid'}: {$GRIDType.$GRIDName} $GRID{NAME}\n"; - } - $msg .= "$__{'Date'}: $date $time\n"; - $msg .= "$__{'Author(s)'}: $names\n"; - $msg .= "$__{'Title'}: $titre\n\n"; - $msg .= "$contents\n\n" if (isok($WEBOBS{EVENTS_NOTIFY_FULL_MESSAGE})); - if ($isnode) { - $msg .= "$__{'WebObs show node'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$NODES{CGI_SHOW}?node=$GRIDType.$GRIDName.$NODEName"; - } else { - $msg .= "$__{'WebObs show grid'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$GRIDS{CGI_SHOW_GRID}?node=$GRIDType.$GRIDName"; - } - $msg .= "\n"; - - my $args = substr("$eventname|$senderId|$msg",0,4000); # 4000 fits FIFO atomicity (4096) - return ( WebObs::Config::notify($args) ) + my $eventname = "eventnode"; + my $senderId = $USERS{$CLIENT}{UID}; + my $names = join(", ",WebObs::Users::userName(@oper))."/".join(", ",WebObs::Users::userName(@roper)); + my $msg = ''; + my $isnode = ($object =~ /^.*\..*\..*$/ ? 1:0); + + $msg .= "$__{'New event'} WebObs-$WEBOBS{WEBOBS_ID}.\n\n"; + if ($isnode) { + my %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); + $msg .= "$__{'Node'}: {$NODEName} $NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})\n"; + $msg .= "$__{'Grids'}: @{$allNodeGrids{$NODEName}}\n"; + } else { + $msg .= "$__{'Grid'}: {$GRIDType.$GRIDName} $GRID{NAME}\n"; + } + $msg .= "$__{'Date'}: $date $time\n"; + $msg .= "$__{'Author(s)'}: $names\n"; + $msg .= "$__{'Title'}: $titre\n\n"; + $msg .= "$contents\n\n" if (isok($WEBOBS{EVENTS_NOTIFY_FULL_MESSAGE})); + if ($isnode) { + $msg .= "$__{'WebObs show node'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$NODES{CGI_SHOW}?node=$GRIDType.$GRIDName.$NODEName"; + } else { + $msg .= "$__{'WebObs show grid'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$GRIDS{CGI_SHOW_GRID}?node=$GRIDType.$GRIDName"; + } + $msg .= "\n"; + + my $args = substr("$eventname|$senderId|$msg",0,4000); # 4000 fits FIFO atomicity (4096) + return ( WebObs::Config::notify($args) ) } =pod diff --git a/CODE/cgi-bin/viewMAN.pl b/CODE/cgi-bin/viewMAN.pl index 9359b23a..b2fd6d2e 100755 --- a/CODE/cgi-bin/viewMAN.pl +++ b/CODE/cgi-bin/viewMAN.pl @@ -27,7 +27,7 @@ =head1 DESCRIPTION # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $man = $cgi->param('man') // ''; @@ -38,18 +38,19 @@ =head1 DESCRIPTION print "\n"; print "webobs manpages"; print ""; + #print ""; print ""; if ( -f $man ) { - mkdir("$WEBOBS{ROOT_DATA}/tmp"); chdir("$WEBOBS{ROOT_DATA}/tmp"); - ##my @h = qx(groff -T html $man); - my @h = qx(man2html $man); - my $groffbody=0; while (! $groffbody) { my $x=shift @h; $groffbody=1 if $x =~ "" } - my $groffbody=0; while (! $groffbody) { my $x=pop @h; $groffbody=1 if $x =~ "" } - for (@h) { print $_; } + mkdir("$WEBOBS{ROOT_DATA}/tmp"); chdir("$WEBOBS{ROOT_DATA}/tmp"); + ##my @h = qx(groff -T html $man); + my @h = qx(man2html $man); + my $groffbody=0; while (! $groffbody) { my $x=shift @h; $groffbody=1 if $x =~ "" } + my $groffbody=0; while (! $groffbody) { my $x=pop @h; $groffbody=1 if $x =~ "" } + for (@h) { print $_; } } else { - print "

    man page $man not found

    "; + print "

    man page $man not found

    "; } print ""; diff --git a/CODE/cgi-bin/viewMFILE.pl b/CODE/cgi-bin/viewMFILE.pl index fc35c2d9..a1fa91b9 100755 --- a/CODE/cgi-bin/viewMFILE.pl +++ b/CODE/cgi-bin/viewMFILE.pl @@ -13,17 +13,17 @@ # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $mfile = $cgi->param('mfile') // ''; print $cgi->header(-type=>'text/plain',-charset=>'utf-8'); if ($mfile) { - my $fname = "$WEBOBS{ROOT_CODE}/matlab/$mfile"; - print STDERR "** mfile = $fname **\n"; - if (-f $fname) { - my @m = qx(sed -n '/^function/,/^[\s\r]*\$/p' $fname); - print join('',@m); - } + my $fname = "$WEBOBS{ROOT_CODE}/matlab/$mfile"; + print STDERR "** mfile = $fname **\n"; + if (-f $fname) { + my @m = qx(sed -n '/^function/,/^[\s\r]*\$/p' $fname); + print join('',@m); + } } diff --git a/CODE/cgi-bin/viewPOD.pl b/CODE/cgi-bin/viewPOD.pl index a8513864..5a4287d2 100755 --- a/CODE/cgi-bin/viewPOD.pl +++ b/CODE/cgi-bin/viewPOD.pl @@ -15,24 +15,25 @@ # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $pod = $cgi->param('pod') // ''; if ($pod) { my $fname = scan4($pod); - if ($fname) { - #print "Content-type: text/html\n\n"; - print $cgi->header(-charset=>'utf-8'); - mkdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); # just in case - chdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); - pod2html("--quiet","--css=/css/viewpod.css","--infile=$fname"); - } + if ($fname) { + + #print "Content-type: text/html\n\n"; + print $cgi->header(-charset=>'utf-8'); + mkdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); # just in case + chdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); + pod2html("--quiet","--css=/css/viewpod.css","--infile=$fname"); + } } sub scan4 { - my $what = $_[0]; - my $wd = qx(pwd); chomp($wd); + my $what = $_[0]; + my $wd = qx(pwd); chomp($wd); if ( -e $what ) { return "$wd/$what" } for (@INC) { if( -e "$_/$what.pm" ) { return "$_/$what.pm" } diff --git a/CODE/cgi-bin/vsearch.pl b/CODE/cgi-bin/vsearch.pl index 80ea690a..c0ac1302 100755 --- a/CODE/cgi-bin/vsearch.pl +++ b/CODE/cgi-bin/vsearch.pl @@ -121,37 +121,38 @@ =head1 DESCRIPTION # predefined lists my @catlist = split(/,/,$NODES{EVENT_SEARCH_CATEGORY_LIST}); if ($#catlist < 0) { - @catlist = split(/,/,"grid,alias,name,feature,author,remote,startdate,title,comment,notebook,outcome"); + @catlist = split(/,/,"grid,alias,name,feature,author,remote,startdate,title,comment,notebook,outcome"); } my %category = ( - "grid" => $__{'Grid Name'}, - "alias" => $__{'Node Alias'}, - "name" => $__{'Node Name'}, - "feature" => $__{'Node Feature'}, - "author" => $__{'Author'}, - "remote" => $__{'Remote Operator'}, - "startdate" => $__{'Start Date'}, - "enddate" => $__{'End Date'}, - "title" => $__{'Event Title'}, - "comment" => $__{'Comment/Observation'}, - "notebook" => $__{'Notebook #'}, - "outcome" => $__{'Sensor Outcome'}, -); + "grid" => $__{'Grid Name'}, + "alias" => $__{'Node Alias'}, + "name" => $__{'Node Name'}, + "feature" => $__{'Node Feature'}, + "author" => $__{'Author'}, + "remote" => $__{'Remote Operator'}, + "startdate" => $__{'Start Date'}, + "enddate" => $__{'End Date'}, + "title" => $__{'Event Title'}, + "comment" => $__{'Comment/Observation'}, + "notebook" => $__{'Notebook #'}, + "outcome" => $__{'Sensor Outcome'}, + ); + # removes category notebook if option is not set delete $category{"notebook"} if (!isok($NODES{EVENTNODE_NOTEBOOK})); my %catdisplay; foreach my $n (0..$#catlist) { - if (defined $category{$catlist[$n]}) { - $catdisplay{sprintf("%02d|%s", $n, $catlist[$n])} = $category{$catlist[$n]}; - } + if (defined $category{$catlist[$n]}) { + $catdisplay{sprintf("%02d|%s", $n, $catlist[$n])} = $category{$catlist[$n]}; + } } my %sortlist = ( - "startdateinc" => $__{'Start Date - increasing'}, - "startdatedec" => $__{'Start Date - decreasing'}, -); + "startdateinc" => $__{'Start Date - increasing'}, + "startdatedec" => $__{'Start Date - decreasing'}, + ); my @maxlist = ("15","50","100"); @maxlist = split(/,/,$NODES{EVENT_SEARCH_MAXDISPLAY_LIST}) if ($NODES{EVENT_SEARCH_MAXDISPLAY_LIST} ne ""); @@ -171,31 +172,33 @@ =head1 DESCRIPTION my ($evfname,$node,$date1,$time1,$version); if ($str ne "") { - @events1 = searchEvents($target,$str,$in); + @events1 = searchEvents($target,$str,$in); } if ($str2 ne "") { - @events2 = searchEvents($target,$str2,$in2); - if ($lop eq "OR") { - # simply appends the two requests - push(@events1,@events2); - } + @events2 = searchEvents($target,$str2,$in2); + if ($lop eq "OR") { + + # simply appends the two requests + push(@events1,@events2); + } } # ---- must remove NODES that are not associated to readable GRIDS by user my %NG = listNodeGrids; foreach(@events1) { - $evfname = $_; - my $fname = basename($evfname); - ($node,$date1,$time1,$version) = split(/_/,basename(split(/\./,$fname))); - my $ok = 0; - foreach(@{$NG{$node}}) { - my ($GRIDType,$GRIDName) = split(/\./,$_); - $ok = 1 if (clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); - } - # avoid duplicates and keeps only events common to the 2 requests in case of AND logical operator - if (! grep(/$fname/,@events) && ($lop ne "AND" || $str2 eq "" || grep(/$fname/,@events2))) { - push(@events,$evfname); - } + $evfname = $_; + my $fname = basename($evfname); + ($node,$date1,$time1,$version) = split(/_/,basename(split(/\./,$fname))); + my $ok = 0; + foreach(@{$NG{$node}}) { + my ($GRIDType,$GRIDName) = split(/\./,$_); + $ok = 1 if (clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); + } + +# avoid duplicates and keeps only events common to the 2 requests in case of AND logical operator + if (! grep(/$fname/,@events) && ($lop ne "AND" || $str2 eq "" || grep(/$fname/,@events2))) { + push(@events,$evfname); + } } # ---- sort events @@ -236,59 +239,59 @@ =head1 DESCRIPTION # form part print "
    "; - print ""; - print "\n"; - print "\n"; - print "\n\n"; - print "
    "; - print "$__{'Search for:'}   "; - print "$__{'in:'}
    \n"; - print "  \n"; - print "  "; - print "$__{'in:'}     		"; - print "$__{'sorted by:'}
    \n"; - print "$__{'Show:'} $__{'grids'}"; - print "   $__{'node\'s name'}"; - print "    		"; - print "$__{'max diplayed:'} "; - if ($from > 1) { - my $prev = max(1,$from - $max); - my $qr = $query; - $qr =~ s/from=[0-9]*/from=$prev/; - print ""; - } - print "$from - ".($from + $maxdisp - 1)." / ".($#events + 1).""; - if ($from + $maxdisp - 2 < $#events) { - my $next = min($#events + 1,$from + $max); - my $qr = $query; - $qr =~ s/from=[0-9]*/from=$next/; - print ""; - } - print " "; - print "
    \n"; - print "\n"; +print ""; +print "\n"; +print "\n"; +print "\n\n"; +print "
    "; +print "$__{'Search for:'}   "; +print "$__{'in:'}
    \n"; +print "  \n"; +print "  "; +print "$__{'in:'}     		"; +print "$__{'sorted by:'}
    \n"; +print "$__{'Show:'} $__{'grids'}"; +print "   $__{'node\'s name'}"; +print "    		"; +print "$__{'max diplayed:'} "; +if ($from > 1) { + my $prev = max(1,$from - $max); + my $qr = $query; + $qr =~ s/from=[0-9]*/from=$prev/; + print ""; +} +print "$from - ".($from + $maxdisp - 1)." / ".($#events + 1).""; +if ($from + $maxdisp - 2 < $#events) { + my $next = min($#events + 1,$from + $max); + my $qr = $query; + $qr =~ s/from=[0-9]*/from=$next/; + print ""; +} +print " "; +print "
    \n"; +print "\n"; print "
    \n"; print "
    $__{'Searching for the data... please wait'}.
    "; @@ -296,169 +299,171 @@ =head1 DESCRIPTION # builds the html string push(@html,""); foreach (sort(keys(%catdisplay))) { - my ($n,$k) = split(/\|/,$_); - push(@html,"") if ($k ne "grid" || $showg); + my ($n,$k) = split(/\|/,$_); + push(@html,"") if ($k ne "grid" || $showg); } push(@html,"\n"); # result part : will read and display only the needed events my @finalevents = @events[$from-1 .. ($from + $maxdisp)-2]; + #print "

    ".join("
    ",@finalevents)."

    "; if ($#finalevents < 0 || $finalevents[0] eq "") { - @finalevents = (); - push(@html,"\n"); + @finalevents = (); + push(@html,"\n"); } my %G = WebObs::Grids::listNameGrids; my $n = 0; foreach(@finalevents) { - $evfname = $_; - my $evrel = $evfname; - $evrel =~ s/.*$NODES{SPATH_INTERVENTIONS}\///g; - my ($fname,$fext) = split(/\./,basename($evfname)); - ($node,$date1,$time1,$version) = split(/_/,basename($fname)); - $time1 =~ s/-/:/; - $time1 =~ s/NA//; - - # checks attached photos - my @attach; - my $dp = $evfname; - $dp =~ s/\.txt/\/PHOTOS/g; - if (-d $dp) { - opendir (my $dh, $dp); - @attach = grep {!/^\./} readdir $dh; - closedir $dh; - } - - @lines = readFile("$evfname"); - my ($aa,$ar,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); - my @authors = WebObs::Users::userName(@$aa); - my @remotes = WebObs::Users::userName(@$ar); - shift(@lines); # shift header line - my $comment = wiki2html(join("",@lines)); - shift(@lines) if (grep($lines[0],'^WebObs:')); # shift Wiki/MMD metadata - chomp(@lines); - my $commentcsv = join(" • ",@lines); - my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); - my @nodes; - foreach(@{$NG{$node}}) { - push(@nodes,"\"$__{'Edit...'}\""); - } - - my $tds = " class=\"td$n\""; - - # highlights results - my $hauthors = join("
    ",@authors); - my $hremotes = join("
    ",@remotes); - my $hfeature = $feature; - my $hdate1 = $date1; - my $hdate2 = $date2; - my $htitle = $title; - if ($str ne "") { - $hauthors =~ s/($str)/\1<\/SPAN>/ig if ($in eq "author"); - $hremotes =~ s/($str)/\1<\/SPAN>/ig if ($in eq "remote"); - $hfeature =~ s/($str)/\1<\/SPAN>/ig if ($in eq "feature"); - $hdate1 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "startdate"); - $hdate2 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "enddate"); - $htitle =~ s/($str)/\1<\/SPAN>/ig if ($in eq "title"); - $comment =~ s/($str)/\1<\/SPAN>/ig if ($in eq "comment"); - } - if ($str2 ne "") { - $hauthors =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "author"); - $hremotes =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "remote"); - $hfeature =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "feature"); - $hdate1 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "startdate"); - $hdate2 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "enddate"); - $htitle =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "title"); - $comment =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "comment"); - } - - push(@html,""); - #[FB]: possibility to display all edit links (procs and views) - #print ""; - push(@html,""); - - my @csvf; - foreach (sort(keys(%catdisplay))) { - my ($n,$k) = split(/\|/,$_); - switch ($k) { - case "grid" { - my @grids; - my @gridscsv; - foreach (@{$NG{$node}}) { - push(@grids,"$G{$_}"); - push(@gridscsv,$G{$_}); - } - push(@html,"") if ($showg); - push(@csvf,"\"".join(",",@gridscsv)."\""); - } - case "alias" { - my @alias; - my @aliascsv; - foreach (@{$NG{$node}}) { - push(@alias,"$N{ALIAS}".($shown ? " $N{NAME}":"").""); - push(@aliascsv,$N{ALIAS}); - } - @alias = ($alias[0]) if (!$showg); - push(@html,""); - push(@csvf,"\"".join(",",@aliascsv)."\""); - } - case "name" { - my @name; - my @namecsv; - foreach (@{$NG{$node}}) { - push(@name,"$N{NAME}"); - $N{NAME} =~ s/\"//g; - push(@namecsv,$N{NAME}); - } - @name = ($name[0]) if (!$showg); - push(@html,""); - push(@csvf,"\"".join(",",@namecsv)."\""); - } - case "feature" { - push(@html,""); - push(@csvf,"\"$feature\""); - } - case "author" { - push(@html,""); - push(@csvf,"\"".join(",",@authors)."\""); - } - case "remote" { - push(@html,""); - push(@csvf,"\"".join(",",@remotes)."\""); - } - case "startdate" { - push(@html,""); - push(@csvf,"\"$date1 $time1\""); - } - case "enddate" { - push(@html,""); - push(@csvf,"\"$date2 $time2\""); - } - case "title" { - push(@html,""); - push(@csvf,"\"$title\""); - } - case "comment" { - push(@html,""); - push(@csvf,"\"$commentcsv\""); - } - case "notebook" { - push(@html,"") if (isok($NODES{EVENTNODE_NOTEBOOK})); - push(@csvf,"\"$notebook\""); - } - case "outcome" { - push(@html,""); - push(@csvf,"\"$outcome\""); - } - } - } - push(@csv,join(";",@csvf)); - push(@html,""); - push(@html,"\n"); - $n = ($n + 1) % 2; + $evfname = $_; + my $evrel = $evfname; + $evrel =~ s/.*$NODES{SPATH_INTERVENTIONS}\///g; + my ($fname,$fext) = split(/\./,basename($evfname)); + ($node,$date1,$time1,$version) = split(/_/,basename($fname)); + $time1 =~ s/-/:/; + $time1 =~ s/NA//; + + # checks attached photos + my @attach; + my $dp = $evfname; + $dp =~ s/\.txt/\/PHOTOS/g; + if (-d $dp) { + opendir (my $dh, $dp); + @attach = grep {!/^\./} readdir $dh; + closedir $dh; + } + + @lines = readFile("$evfname"); + my ($aa,$ar,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); + my @authors = WebObs::Users::userName(@$aa); + my @remotes = WebObs::Users::userName(@$ar); + shift(@lines); # shift header line + my $comment = wiki2html(join("",@lines)); + shift(@lines) if (grep($lines[0],'^WebObs:')); # shift Wiki/MMD metadata + chomp(@lines); + my $commentcsv = join(" • ",@lines); + my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); + my @nodes; + foreach(@{$NG{$node}}) { + push(@nodes,"\"$__{'Edit...'}\""); + } + + my $tds = " class=\"td$n\""; + + # highlights results + my $hauthors = join("
    ",@authors); + my $hremotes = join("
    ",@remotes); + my $hfeature = $feature; + my $hdate1 = $date1; + my $hdate2 = $date2; + my $htitle = $title; + if ($str ne "") { + $hauthors =~ s/($str)/\1<\/SPAN>/ig if ($in eq "author"); + $hremotes =~ s/($str)/\1<\/SPAN>/ig if ($in eq "remote"); + $hfeature =~ s/($str)/\1<\/SPAN>/ig if ($in eq "feature"); + $hdate1 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "startdate"); + $hdate2 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "enddate"); + $htitle =~ s/($str)/\1<\/SPAN>/ig if ($in eq "title"); + $comment =~ s/($str)/\1<\/SPAN>/ig if ($in eq "comment"); + } + if ($str2 ne "") { + $hauthors =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "author"); + $hremotes =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "remote"); + $hfeature =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "feature"); + $hdate1 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "startdate"); + $hdate2 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "enddate"); + $htitle =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "title"); + $comment =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "comment"); + } + + push(@html,""); + + #[FB]: possibility to display all edit links (procs and views) + #print ""; + push(@html,""); + + my @csvf; + foreach (sort(keys(%catdisplay))) { + my ($n,$k) = split(/\|/,$_); + switch ($k) { + case "grid" { + my @grids; + my @gridscsv; + foreach (@{$NG{$node}}) { + push(@grids,"$G{$_}"); + push(@gridscsv,$G{$_}); + } + push(@html,"") if ($showg); + push(@csvf,"\"".join(",",@gridscsv)."\""); + } + case "alias" { + my @alias; + my @aliascsv; + foreach (@{$NG{$node}}) { + push(@alias,"$N{ALIAS}".($shown ? " $N{NAME}":"").""); + push(@aliascsv,$N{ALIAS}); + } + @alias = ($alias[0]) if (!$showg); + push(@html,""); + push(@csvf,"\"".join(",",@aliascsv)."\""); + } + case "name" { + my @name; + my @namecsv; + foreach (@{$NG{$node}}) { + push(@name,"$N{NAME}"); + $N{NAME} =~ s/\"//g; + push(@namecsv,$N{NAME}); + } + @name = ($name[0]) if (!$showg); + push(@html,""); + push(@csvf,"\"".join(",",@namecsv)."\""); + } + case "feature" { + push(@html,""); + push(@csvf,"\"$feature\""); + } + case "author" { + push(@html,""); + push(@csvf,"\"".join(",",@authors)."\""); + } + case "remote" { + push(@html,""); + push(@csvf,"\"".join(",",@remotes)."\""); + } + case "startdate" { + push(@html,""); + push(@csvf,"\"$date1 $time1\""); + } + case "enddate" { + push(@html,""); + push(@csvf,"\"$date2 $time2\""); + } + case "title" { + push(@html,""); + push(@csvf,"\"$title\""); + } + case "comment" { + push(@html,""); + push(@csvf,"\"$commentcsv\""); + } + case "notebook" { + push(@html,"") if (isok($NODES{EVENTNODE_NOTEBOOK})); + push(@csvf,"\"$notebook\""); + } + case "outcome" { + push(@html,""); + push(@csvf,"\"$outcome\""); + } + } + } + push(@csv,join(";",@csvf)); + push(@html,""); + push(@html,"\n"); + $n = ($n + 1) % 2; } push(@html,"
    $catdisplay{$_}$catdisplay{$_}

    No match.

    No match.

    ".join("
    ",@nodes)."    		".join("
    ",$nodes[0])."    		".join("
    ",@grids)."    		".join(",",@alias)."".join(",",@name)."$hfeature$hauthors$hremotes$hdate1 $time1$hdate2 $time2$htitle$comment$notebook".($outcome > 0 ? "":"")."".($#attach > 0 ? "":"")."
    ".join("
    ",@nodes)."    		".join("
    ",$nodes[0])."    		".join("
    ",@grids)."    		".join(",",@alias)."".join(",",@name)."$hfeature$hauthors$hremotes$hdate1 $time1$hdate2 $time2$htitle$comment$notebook".($outcome > 0 ? "":"")."".($#attach > 0 ? "":"")."
    \n"); @@ -487,112 +492,122 @@ =head1 DESCRIPTION ENDBOTOFPAGE - ############################################################################### # this function uses external commands (find, grep, awk ...) to get the list of # requested events following the different search criteria sub searchEvents { - my ($target,$str,$in) = @_; - my $struc = uc($str); - my $not = my $notlike = ''; - if ($struc =~ /^!/) { - $not = '!'; - $notlike = 'not'; - $struc = substr($struc,1); # removes the first character - } - my ($GRIDType,$GRIDName,$NodeID) = split(/\./,$target); - - my @evt; - my $cmd; - - # default command is all events... - my $node = ($NodeID eq "" ? "*":$NodeID); - my $base = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a ! -name \"*_Projet.txt\" \\)"; - - # alias will look for $str in the node's ALIAS and NAME configuration - if ($in eq "alias") { - $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^ALIAS\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; - } - if ($in eq "name") { - $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^NAME\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; - } - # grid will look for $str in the grid's NAME configuration - if ($in eq "grid") { - # search for grid names - my @GRIDlist = qx(find $WEBOBS{ROOT_CONF}/PROCS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1); - push(@GRIDlist,qx(find $WEBOBS{ROOT_CONF}/VIEWS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1)); - chomp(@GRIDlist); - if ($#GRIDlist < 0) { - $cmd = ""; - } else { - $cmd = "find -L $WEBOBS{PATH_GRIDS2NODES} \\( ! -name \"*_Projet.txt\" -a -name \"*.txt\" -a -path \"$node/$NODES{SPATH_INTERVENTIONS}*\" -a \\( -path \"*".join('*" -o -path "*',@GRIDlist)."*\" \\) \\)"; - } - } - # startdate will look for $str in event's start date - if ($in eq "startdate") { - my $s = $struc; - $s =~ s/:/-/; - $s =~ s/ /_/; - $cmd = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a $not -name \"*$s*\" -a ! -name \"*_Projet.txt\" \\)"; - } - # author and remote will look for $str in author's full names - if ($in eq "author" || $in eq "remote") { - # must replaces author names by their UID - my @UIDlist = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "select UID from users where FULLNAME $notlike like '%$str%'"); - chomp(@UIDlist); - if ($#UIDlist < 0) { - $cmd = ""; - } else { - my $f = "1"; - $f = "2" if ($in eq "remote"); - $cmd = $base."|xargs awk -F '[|/]' 'FNR>1 {nextfile} \$$f ~ /".join('|',@UIDlist)."/ { print FILENAME ; nextfile }'"; - } - } - # title will look for $str in event's title (2nd field in header line) - if ($in eq "title") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$2) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # enddate will look for $str in event's end date (3rd field in header line) - if ($in eq "enddate") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$3) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # feature will look for $str in event's feature (4th field in header line) - if ($in eq "feature") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$4) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # outcome will look for $str in event's outcome (5th field in header line) - if ($in eq "outcome") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$6) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # notebook will look for $str in event's outcome (6th field in header line) - if ($in eq "notebook") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$7) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # comment will look for $str in event's full text (except header line) - if ($in eq "comment") { - $cmd = $base."| xargs awk 'BEGIN{ RS = \"\" ; FS = \"\\n\" } FNR>1 && toupper(\$0) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - - @evt = qx($cmd); - chomp(@evt); - return @evt; + my ($target,$str,$in) = @_; + my $struc = uc($str); + my $not = my $notlike = ''; + if ($struc =~ /^!/) { + $not = '!'; + $notlike = 'not'; + $struc = substr($struc,1); # removes the first character + } + my ($GRIDType,$GRIDName,$NodeID) = split(/\./,$target); + + my @evt; + my $cmd; + + # default command is all events... + my $node = ($NodeID eq "" ? "*":$NodeID); + my $base = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a ! -name \"*_Projet.txt\" \\)"; + + # alias will look for $str in the node's ALIAS and NAME configuration + if ($in eq "alias") { + $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^ALIAS\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; + } + if ($in eq "name") { + $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^NAME\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; + } + + # grid will look for $str in the grid's NAME configuration + if ($in eq "grid") { + + # search for grid names + my @GRIDlist = qx(find $WEBOBS{ROOT_CONF}/PROCS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1); + push(@GRIDlist,qx(find $WEBOBS{ROOT_CONF}/VIEWS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1)); + chomp(@GRIDlist); + if ($#GRIDlist < 0) { + $cmd = ""; + } else { + $cmd = "find -L $WEBOBS{PATH_GRIDS2NODES} \\( ! -name \"*_Projet.txt\" -a -name \"*.txt\" -a -path \"$node/$NODES{SPATH_INTERVENTIONS}*\" -a \\( -path \"*".join('*" -o -path "*',@GRIDlist)."*\" \\) \\)"; + } + } + + # startdate will look for $str in event's start date + if ($in eq "startdate") { + my $s = $struc; + $s =~ s/:/-/; + $s =~ s/ /_/; + $cmd = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a $not -name \"*$s*\" -a ! -name \"*_Projet.txt\" \\)"; + } + + # author and remote will look for $str in author's full names + if ($in eq "author" || $in eq "remote") { + + # must replaces author names by their UID + my @UIDlist = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "select UID from users where FULLNAME $notlike like '%$str%'"); + chomp(@UIDlist); + if ($#UIDlist < 0) { + $cmd = ""; + } else { + my $f = "1"; + $f = "2" if ($in eq "remote"); + $cmd = $base."|xargs awk -F '[|/]' 'FNR>1 {nextfile} \$$f ~ /".join('|',@UIDlist)."/ { print FILENAME ; nextfile }'"; + } + } + + # title will look for $str in event's title (2nd field in header line) + if ($in eq "title") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$2) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # enddate will look for $str in event's end date (3rd field in header line) + if ($in eq "enddate") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$3) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # feature will look for $str in event's feature (4th field in header line) + if ($in eq "feature") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$4) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # outcome will look for $str in event's outcome (5th field in header line) + if ($in eq "outcome") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$6) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # notebook will look for $str in event's outcome (6th field in header line) + if ($in eq "notebook") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$7) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # comment will look for $str in event's full text (except header line) + if ($in eq "comment") { + $cmd = $base."| xargs awk 'BEGIN{ RS = \"\" ; FS = \"\\n\" } FNR>1 && toupper(\$0) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + @evt = qx($cmd); + chomp(@evt); + return @evt; } - sub sort_by_date ($$) { - my ($c,$d) = @_; - # keeps only the date info (removes path and nodeid) - $c = basename($c); - $c =~ s/[^_]*//; - $d = basename($d); - $d =~ s/[^_]*//; - # replaces undefined time by 00:00 - $c =~ s/_NA/_00:00/; - $d =~ s/_NA/00:00/; - return $d cmp $c; + my ($c,$d) = @_; + + # keeps only the date info (removes path and nodeid) + $c = basename($c); + $c =~ s/[^_]*//; + $d = basename($d); + $d =~ s/[^_]*//; + + # replaces undefined time by 00:00 + $c =~ s/_NA/_00:00/; + $d =~ s/_NA/00:00/; + return $d cmp $c; } - =pod =head1 AUTHOR(S) diff --git a/CODE/cgi-bin/wdir.pl b/CODE/cgi-bin/wdir.pl index f5c68990..89f44e56 100755 --- a/CODE/cgi-bin/wdir.pl +++ b/CODE/cgi-bin/wdir.pl @@ -62,16 +62,17 @@ =head1 Query string parameters # del file first if requested if ($del ne "" && -e $absdir.$del) { - if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { - unlink $absdir.$del if (-f $absdir.$del); - remove_tree $absdir.$del if (-d $absdir.$del); - } + if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { + unlink $absdir.$del if (-f $absdir.$del); + remove_tree $absdir.$del if (-d $absdir.$del); + } } + # then handle subdir creation if ($sdir ne "" && ! -e $absdir.$sdir) { - if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { - make_path($absdir.$sdir); - } + if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { + make_path($absdir.$sdir); + } } # ---- 'dir' directory list ---------------- --------------------------------- @@ -82,7 +83,7 @@ =head1 Query string parameters @files = sort {$a cmp $b} @files; if ( WebObs::Users::clientHasEdit(type=>'authwikis',name=>'*') ) { - $editALL = 1; + $editALL = 1; } # ---- create the HTML now ! ------------------------------------------------- @@ -104,54 +105,58 @@ =head1 Query string parameters print "
    "; print "
    "; print ""; + # new file + new subdir row if ( ($editALL == 1) || WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { - print ""; - print ""; - print ""; - print ""; - print ""; + print ""; + print ""; + print ""; + print ""; + print ""; } + # updir rows first if ($updir ne "") { - print ""; - if (-d "$abs/$updir" && WebObs::Users::clientHasRead(type=>'authwikis',name=>$updir) ) { - print ""; - } - print ""; + print ""; + if (-d "$abs/$updir" && WebObs::Users::clientHasRead(type=>'authwikis',name=>$updir) ) { + print ""; + } + print ""; } + # subdirs rows for $aFile (@files) { - print ""; - if (-d "$absdir/$aFile") { - if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { - print ""; - print ""; - print ""; - } - } - print ""; + print ""; + if (-d "$absdir/$aFile") { + if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { + print ""; + print ""; + print ""; + } + } + print ""; } + # files rows for $aFile (@files) { - print ""; - if (-f "$absdir/$aFile") { - my $title = qx(head -n1 $absdir/$aFile); - if (grep(/^TITRE.*\|/,$title)) { $title =~ s/^TITRE.*\|//; $title="($title)"} else { $title = ""; } - if ( ($editALL == 1) || WebObs::Users::clientHasEdit(type=>'authwikis',name=>$aFile) ) { - print ""; - print ""; - } - if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { - print ""; - } - } - print ""; + print ""; + if (-f "$absdir/$aFile") { + my $title = qx(head -n1 $absdir/$aFile); + if (grep(/^TITRE.*\|/,$title)) { $title =~ s/^TITRE.*\|//; $title="($title)"} else { $title = ""; } + if ( ($editALL == 1) || WebObs::Users::clientHasEdit(type=>'authwikis',name=>$aFile) ) { + print ""; + print ""; + } + if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { + print ""; + } + } + print ""; } print "
    "; - print ""; - print ""; - print ""; - print ""; - print "
    "; + print ""; + print ""; + print ""; + print ""; + print "
    ..
    ..
    $aFile/
    $aFile/
    $aFile $title
    $aFile $title
    "; print "
    "; diff --git a/CODE/cgi-bin/wedit.pl b/CODE/cgi-bin/wedit.pl index 1aee77f8..993a2f26 100755 --- a/CODE/cgi-bin/wedit.pl +++ b/CODE/cgi-bin/wedit.pl @@ -108,52 +108,53 @@ =head1 Markitup customization # ---- new file (create) initialization # if ($file ne "") { - $absfile = "$WEBOBS{PATH_DATA_WEB}/$file"; - #?# $absfile =~ s/^\.\.?\///; - $editOK = clientHasEdit(type=>"authwikis",name=>$file); - $admOK = clientHasAdm(type=>"authwikis",name=>$file); - unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } - if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } - if ( (!$editOK) && (!-e $absfile) ) { die "$file $__{'not found'} or $__{'not authorized'}" } + $absfile = "$WEBOBS{PATH_DATA_WEB}/$file"; + + #?# $absfile =~ s/^\.\.?\///; + $editOK = clientHasEdit(type=>"authwikis",name=>$file); + $admOK = clientHasAdm(type=>"authwikis",name=>$file); + unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } + if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } + if ( (!$editOK) && (!-e $absfile) ) { die "$file $__{'not found'} or $__{'not authorized'}" } } else { die "$__{'No filename specified'}" } # ---- action is 'save' # if ($action eq 'save') { - if ($TS0 != (stat("$absfile"))[9]) { - htmlMsgNotOK("$file has been modified while you were editing !"); - exit; - } - if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $file..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $absfile $absfile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - if ($conv eq "1") { - $txt = WebObs::Wiki::wiki2MMD($txt); - $txt = "WebObs: converted with wiki2MMD\n\n$txt"; - } - if ($html == 1) { - @lignes = ("TITRE_HTML|$titre\n"); - } elsif ($titre ne "") { - @lignes = ("TITRE|$titre\n"); - } - $txt = "$metain$txt"; - $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lignes,$txt); - print FILE @lignes ; - close(FILE); - htmlMsgOK($file); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $file"); - } - } else { htmlMsgNotOK("$me opening $file - $!") } - exit; + if ($TS0 != (stat("$absfile"))[9]) { + htmlMsgNotOK("$file has been modified while you were editing !"); + exit; + } + if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $file..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $absfile $absfile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + if ($conv eq "1") { + $txt = WebObs::Wiki::wiki2MMD($txt); + $txt = "WebObs: converted with wiki2MMD\n\n$txt"; + } + if ($html == 1) { + @lignes = ("TITRE_HTML|$titre\n"); + } elsif ($titre ne "") { + @lignes = ("TITRE|$titre\n"); + } + $txt = "$metain$txt"; + $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lignes,$txt); + print FILE @lignes ; + close(FILE); + htmlMsgOK($file); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $file"); + } + } else { htmlMsgNotOK("$me opening $file - $!") } + exit; } # ---- action is 'edit' (default) @@ -162,17 +163,19 @@ =head1 Markitup customization @lignes = readFile($absfile); $TS0 = (stat($absfile))[9] ; chomp(@lignes); + # strip off and remember the first line's optional tags TITLE* (my $x, my $y) = split(/\|/, $lignes[0]); if ( $x eq "TITRE_HTML" ) { - $titre = $y; - shift(@lignes); - $legacyhtml = 1; + $titre = $y; + shift(@lignes); + $legacyhtml = 1; } if ( $x eq "TITRE" ) { - $titre = $y; - shift(@lignes); + $titre = $y; + shift(@lignes); } + # file contents as a string and determine markup type (WO or MMD) $txt = join("\n",@lignes); ($txt, my $meta) = WebObs::Wiki::stripMDmetadata($txt); @@ -211,10 +214,10 @@ =head1 Markitup customization "; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print ""; -print ""; +print ""; print "$titre @@ -108,19 +108,18 @@ =head1 Query string parameters
    $editor
    "; -print "
    "; +print "
    "; if ($titre ne "") { - print "

    $titre

    "; + print "

    $titre

    "; } if ($html) { - print @lines; + print @lines; } else { - print WebObs::Wiki::wiki2html(join("",@lines)); + print WebObs::Wiki::wiki2html(join("",@lines)); } print "
    \n"; print ""; - __END__ =pod diff --git a/CODE/cgi-bin/xedit.pl b/CODE/cgi-bin/xedit.pl index 71b710fd..516e42a4 100755 --- a/CODE/cgi-bin/xedit.pl +++ b/CODE/cgi-bin/xedit.pl @@ -104,7 +104,7 @@ =head1 CONFIGURATION VARIABLES # ---- see what file has to be edited, and corresponding authorization for client # -my $me = $ENV{SCRIPT_NAME}; +my $me = $ENV{SCRIPT_NAME}; my $QryParm = $cgi->Vars; my $fs = $QryParm->{'fs'} // ""; my $action = $QryParm->{'action'} // "edit"; @@ -118,59 +118,59 @@ =head1 CONFIGURATION VARIABLES my $fsmsg = ""; if ($fs ne "") { - if ($fs =~ /^CONF\//) { - ($absfile = $fs) =~ s/^CONF\//$WEBOBS{ROOT_CONF}\//; - } elsif ($fs =~ /^DATA\//) { - ($absfile = $fs) =~ s/^DATA\//$WEBOBS{ROOT_DATA}\//; - } else { - my @u = split(/[()]/, $fs); - if (scalar(@u) == 2) { - my %l = readCfg($WEBOBS{$u[0]}); - $absfile = $l{$u[1]}; - } else { $absfile = "$WEBOBS{$fs}"; } - } - if (($relfile = $absfile) =~ s/^$WEBOBS{ROOT_CONF}\/+|^$WEBOBS{ROOT_DATA}\/+//) { - $readOK = clientHasRead(type=>"authmisc",name=>"$relfile"); - if ( $readOK ) { - if ( !$fbrowse ) { - $editOK = clientHasEdit(type=>"authmisc",name=>"$relfile"); - $admOK = clientHasAdm(type=>"authmisc",name=>"$relfile"); - unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } - if ( (!-e $absfile) && $admOK ) { qx(/bin/touch $absfile); $fsmsg="New file" } + if ($fs =~ /^CONF\//) { + ($absfile = $fs) =~ s/^CONF\//$WEBOBS{ROOT_CONF}\//; + } elsif ($fs =~ /^DATA\//) { + ($absfile = $fs) =~ s/^DATA\//$WEBOBS{ROOT_DATA}\//; + } else { + my @u = split(/[()]/, $fs); + if (scalar(@u) == 2) { + my %l = readCfg($WEBOBS{$u[0]}); + $absfile = $l{$u[1]}; + } else { $absfile = "$WEBOBS{$fs}"; } + } + if (($relfile = $absfile) =~ s/^$WEBOBS{ROOT_CONF}\/+|^$WEBOBS{ROOT_DATA}\/+//) { + $readOK = clientHasRead(type=>"authmisc",name=>"$relfile"); + if ( $readOK ) { + if ( !$fbrowse ) { + $editOK = clientHasEdit(type=>"authmisc",name=>"$relfile"); + $admOK = clientHasAdm(type=>"authmisc",name=>"$relfile"); + unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } + if ( (!-e $absfile) && $admOK ) { qx(/bin/touch $absfile); $fsmsg="New file" } else { $fsmsg="$relfile"; } - if ( (!$editOK) && (!-e $absfile) ) { die "$relfile $__{'not found'} or $__{'not authorized'}" } - } - } else { die "$relfile $__{'not authorized'}" } - } else { die "$relfile $__{'Not a CONF/ nor DATA/ file'}" } + if ( (!$editOK) && (!-e $absfile) ) { die "$relfile $__{'not found'} or $__{'not authorized'}" } + } + } else { die "$relfile $__{'not authorized'}" } + } else { die "$relfile $__{'Not a CONF/ nor DATA/ file'}" } } else { die "$__{'No filename specified'}" } # ---- action is 'save' # if ($action eq 'save') { - if ($TS0 != (stat("$absfile"))[9]) { - htmlMsgNotOK("$relfile has been modified while you were editing !"); - exit; - } - if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $relfile..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $absfile $absfile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lignes,u2l($txt)); # forces ISO encoding in any conf file - print FILE @lignes ; - close(FILE); - htmlMsgOK($relfile); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $relfile"); - } - } else { htmlMsgNotOK("$me opening $relfile - $!") } - exit; + if ($TS0 != (stat("$absfile"))[9]) { + htmlMsgNotOK("$relfile has been modified while you were editing !"); + exit; + } + if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $relfile..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $absfile $absfile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lignes,u2l($txt)); # forces ISO encoding in any conf file + print FILE @lignes ; + close(FILE); + htmlMsgOK($relfile); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $relfile"); + } + } else { htmlMsgNotOK("$me opening $relfile - $!") } + exit; } # ---- action is 'edit' (default) @@ -189,6 +189,7 @@ =head1 CONFIGURATION VARIABLES WebObs xedit "; + # - page, codemirror defs print " @@ -205,6 +206,7 @@ =head1 CONFIGURATION VARIABLES "; + # - page, xedit scripts print " "; print "\n"; + # - page, body print ""; print < html + # - page, edit or browse area -print "

    $relfile

    "; +print "

    $relfile

    "; print "
    @@ -238,6 +242,7 @@ =head1 CONFIGURATION VARIABLES print " readonly " if (not ($editOK || $admOK)); print ">$txt\n"; print "
    $fsmsg
    "; + # - page, button(s) area print "

    \n"; print "\n"; @@ -245,10 +250,10 @@ =head1 CONFIGURATION VARIABLES print "\n"; print "\n"; if ($editOK || $admOK) { - print "\n"; - print "\n"; + print "\n"; + print "\n"; } else { - print "\n"; + print "\n"; } print "

    "; print "
    "; @@ -259,13 +264,14 @@ =head1 CONFIGURATION VARIABLES # ---- helpers fns for returning 'save' information to client # sub htmlMsgOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - #[FBnote: does not suppress alert() window...] print "$_[0] updated successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); - print "$_[0] updated successfully !\n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + +#[FBnote: does not suppress alert() window...] print "$_[0] updated successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); + print "$_[0] updated successfully !\n"; } sub htmlMsgNotOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "Update FAILED !\n $_[0] \n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "Update FAILED !\n $_[0] \n"; } =pod diff --git a/CODE/perl/exposerc.pl b/CODE/perl/exposerc.pl index 395bb3aa..b987d0da 100755 --- a/CODE/perl/exposerc.pl +++ b/CODE/perl/exposerc.pl @@ -45,20 +45,21 @@ =head1 DESCRIPTION $prefix ||= 'WO__'; $prefix =~ s/^\s+|\s+$//g ; $ptr ||= ''; $ptr =~ s/^\s+|\s+$//g ; +if ( $ptr eq '' ) { + for (keys(%WEBOBS)) { + printf ("%s%s%s%s\n", $prefix, $_, $sep, $WEBOBS{$_}); -if ( $ptr eq '' ) { - for (keys(%WEBOBS)) { - printf ("%s%s%s%s\n", $prefix, $_, $sep, $WEBOBS{$_}); - #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $WEBOBS{$_}); - } + #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $WEBOBS{$_}); + } } else { - if (defined($WEBOBS{$ptr})) { - my %TGT = readCfg($WEBOBS{$ptr}); - for (keys(%TGT)) { - printf ("%s%s%s%s\n", $prefix, $_, $sep, $TGT{$_}) ; - #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $TGT{$_}) ; - } - } + if (defined($WEBOBS{$ptr})) { + my %TGT = readCfg($WEBOBS{$ptr}); + for (keys(%TGT)) { + printf ("%s%s%s%s\n", $prefix, $_, $sep, $TGT{$_}) ; + + #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $TGT{$_}) ; + } + } } __END__ diff --git a/CODE/perl/fbgstd.pl b/CODE/perl/fbgstd.pl index 240bad0b..1c6b2e80 100755 --- a/CODE/perl/fbgstd.pl +++ b/CODE/perl/fbgstd.pl @@ -9,21 +9,23 @@ my $u = qx(lsof -a -p $$ -d0,1,2); print LOG "---- lsof:\n$u\n"; if (-t STDIN) { print LOG "---- -t STDIN true \n" } else { print LOG "---- -t STDIN false\n"} if (-t STDOUT) { print LOG "---- -t STDOUT true \n" } else { print LOG "---- -t STDOUT false\n"} + #$u = qx(ps T -o pid,ppid,pgid,pgrp,user,args | grep $0); $u = qx(ps -u $< f -o stat,pid,ppid,pgid,tpgid,tty,sid,user,args); print LOG "---- ps:\n$u"; if (!open(TTY, "/dev/tty")) { - print LOG "---- open /dev/tty failed\n"; + print LOG "---- open /dev/tty failed\n"; } else { - my $tpgrp = tcgetpgrp(fileno(*TTY)); - #my $tpgrp = tcgetpgrp(fileno(*STDIN)); - my $pgrp = getpgrp(); - print LOG "---- pgrp = $pgrp , tpgrp = $tpgrp ==> "; - if ($tpgrp == $pgrp) { - print LOG "foreground\n"; - } else { - print LOG "background\n"; - } + my $tpgrp = tcgetpgrp(fileno(*TTY)); + + #my $tpgrp = tcgetpgrp(fileno(*STDIN)); + my $pgrp = getpgrp(); + print LOG "---- pgrp = $pgrp , tpgrp = $tpgrp ==> "; + if ($tpgrp == $pgrp) { + print LOG "foreground\n"; + } else { + print LOG "background\n"; + } } close LOG; diff --git a/CODE/perl/fdsnws-event2mc3.pl b/CODE/perl/fdsnws-event2mc3.pl index c184c779..45a48502 100755 --- a/CODE/perl/fdsnws-event2mc3.pl +++ b/CODE/perl/fdsnws-event2mc3.pl @@ -61,122 +61,123 @@ =head1 DEPENDENCIES # ---- help text when no arguments if (@ARGV == 0) { - print "WebObs FDSN event webservice to MC3 seismic bulletin\n\n", - "Usage: $0 COMMAND [OPTIONS]\n\n", - "\tThe script checks new events in FDSN event webservice and updates\n", - "\tif necessary the MC3 database by creating new events entries. List of\n", - "\tavailable commands and options:\n\n", - "\tupdate\n", - "\t\tUpdates MC3 database.\n", - "\tcheck\n", - "\t\tchecks MC3 database (read only).\n", - "\tdumper\n", - "\t\tchecks and dumps XML tree (read only).\n", - "\t-f MC3NAME\n", - "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", - "\t-s FDSN WebService server\n", - "\t\tSpecifies FDSN WebService server to use (variable name FDSNWS_EVENTS_URL_server).Default is FDSNWS_EVENTS_URL in MC3 conf file.\n", - "\t-n SEFRAN3 name\n", - "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", - "\n\tFrançois Beauducel, Jean-Marie Saurel, WEBOBS/IPGP\n\n" - ; - exit(0); + print "WebObs FDSN event webservice to MC3 seismic bulletin\n\n", + "Usage: $0 COMMAND [OPTIONS]\n\n", + "\tThe script checks new events in FDSN event webservice and updates\n", + "\tif necessary the MC3 database by creating new events entries. List of\n", + "\tavailable commands and options:\n\n", + "\tupdate\n", + "\t\tUpdates MC3 database.\n", + "\tcheck\n", + "\t\tchecks MC3 database (read only).\n", + "\tdumper\n", + "\t\tchecks and dumps XML tree (read only).\n", + "\t-f MC3NAME\n", + "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", + "\t-s FDSN WebService server\n", + "\t\tSpecifies FDSN WebService server to use (variable name FDSNWS_EVENTS_URL_server).Default is FDSNWS_EVENTS_URL in MC3 conf file.\n", + "\t-n SEFRAN3 name\n", + "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", + "\n\tFrançois Beauducel, Jean-Marie Saurel, WEBOBS/IPGP\n\n" + ; + exit(0); } # ---- check for command and option my $arg; if (@ARGV > 0) { - $arg = shift; - if (!($arg =~ /update|check|dumper/)) { - print "'$arg' invalid command\n"; - exit(1); - } - my $opt = shift || ''; - if ( $opt =~ /-f/ ) { - $opt = shift; - if ( $opt ) { - if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { - $mc3 = $opt; - $opt = shift || ''; - } else { - print "'$opt' does not exists\n"; - exit(1); - } - } else { - print "invalid -f option\n"; - exit(1); - } - } - if ( $opt =~ /-s/ ) { - $opt = shift; - if ( $opt ) { - $fdsnws_server = $opt; - print "-s option $fdsnws_server\n"; - $opt = shift || ''; - } else { - print "invalid -s option\n"; - exit(1); - } - } - if ( $opt =~ /-n/ ) { - $opt = shift; - if ( $opt ) { - $sefran3_name = $opt; - print "-n option $sefran3_name\n"; - $opt = shift || ''; - } else { - print "invalid -n option\n"; - exit(1); - } - } + $arg = shift; + if (!($arg =~ /update|check|dumper/)) { + print "'$arg' invalid command\n"; + exit(1); + } + my $opt = shift || ''; + if ( $opt =~ /-f/ ) { + $opt = shift; + if ( $opt ) { + if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { + $mc3 = $opt; + $opt = shift || ''; + } else { + print "'$opt' does not exists\n"; + exit(1); + } + } else { + print "invalid -f option\n"; + exit(1); + } + } + if ( $opt =~ /-s/ ) { + $opt = shift; + if ( $opt ) { + $fdsnws_server = $opt; + print "-s option $fdsnws_server\n"; + $opt = shift || ''; + } else { + print "invalid -s option\n"; + exit(1); + } + } + if ( $opt =~ /-n/ ) { + $opt = shift; + if ( $opt ) { + $sefran3_name = $opt; + print "-n option $sefran3_name\n"; + $opt = shift || ''; + } else { + print "invalid -n option\n"; + exit(1); + } + } } # ---- read config my %MC3 = readCfg("$WEBOBS{ROOT_CONF}/$mc3.conf"); my $oper = $MC3{SC3_USER}; my @blacklist_types = split(/,/,$MC3{SC3_EVENT_TYPES_BLACKLIST}); + # ---- FDSN WebService server my $fdsnws_url = ""; my $fdsnws_search = ""; my $fdsnws_detail = ""; if (defined($MC3{FDSNWS_EVENTS_URL})) { - $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; + $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; } if (defined($MC3{FDSNWS_EVENTS_OPT})) { - $fdsnws_search = $MC3{FDSNWS_EVENTS_OPT}; + $fdsnws_search = $MC3{FDSNWS_EVENTS_OPT}; } elsif (defined($MC3{FDSNWS_EVENTS_SEARCH})) { - $fdsnws_search = $MC3{FDSNWS_EVENTS_SEARCH}; + $fdsnws_search = $MC3{FDSNWS_EVENTS_SEARCH}; } if (defined($MC3{FDSNWS_EVENTS_DETAIL})) { - $fdsnws_detail = $MC3{FDSNWS_EVENTS_DETAIL}; + $fdsnws_detail = $MC3{FDSNWS_EVENTS_DETAIL}; } if (length($fdsnws_server) > 0) { - my $varname = "FDSNWS_EVENTS_URL_$fdsnws_server"; - $fdsnws_url = $MC3{$varname}; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; - $varname = "FDSNWS_EVENTS_OPT_$fdsnws_server"; - if (defined($MC3{$varname})) { - $fdsnws_search = $MC3{$varname}; - } - else { - $varname = "FDSNWS_EVENTS_SEARCH_$fdsnws_server"; - if (defined($MC3{$varname})) { - $fdsnws_search = $MC3{$varname}; - } - } - $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_server"; - if (defined($MC3{$varname})) { - $fdsnws_detail = $MC3{$varname}; - } + my $varname = "FDSNWS_EVENTS_URL_$fdsnws_server"; + $fdsnws_url = $MC3{$varname}; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; + $varname = "FDSNWS_EVENTS_OPT_$fdsnws_server"; + if (defined($MC3{$varname})) { + $fdsnws_search = $MC3{$varname}; + } + else { + $varname = "FDSNWS_EVENTS_SEARCH_$fdsnws_server"; + if (defined($MC3{$varname})) { + $fdsnws_search = $MC3{$varname}; + } + } + $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_server"; + if (defined($MC3{$varname})) { + $fdsnws_detail = $MC3{$varname}; + } } if (! -d $MC3{SC3_EVENTS_ROOT} ) { - print "creating $MC3{SC3_EVENTS_ROOT}\n"; - my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); + print "creating $MC3{SC3_EVENTS_ROOT}\n"; + my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); } # ---- gets the list of last events @@ -187,286 +188,293 @@ =head1 DEPENDENCIES # checks if events exist in MC database for (@last) { - my $evt_id = $_; - print "--- $evt_id ---\n"; - - my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; - my @lines = qx(grep "${fdsnws_server}:\/\/${evt_id}" $mc_path|xargs echo -n); - my $mc_file; - - if (@lines) { - # event's ID already exists in MC: do nothing (for the moment...) - $mc_file = ""; - } else { - - # ------------------------------------------------------------------------- - # event seems new: updates MC file - - my @tab; - my $s; - - my @event = qx(curl -s -S --globoff "${fdsnws_url}${fdsnws_detail}&format=xml&eventid=$evt_id" | $WEBOBS{XML2_PRGM}); - - $s = '/q:quakeml/eventParameters/event'; - foreach (@event) { s/^$s//g; } - - if ($arg =~ /dumper/) { - print join('',@event); - } - chomp(@event); - - # --- gets event type - my $evt_type = findvalue('/type=',\@event) // ''; - print "event type = $evt_type\n"; - if (grep(/^$evt_type$/,@blacklist_types)) { - print "Warning: Event type '$evt_type' is blacklisted!\n"; - } else { - - # --- gets preferred origin ID - my $evt_origID = findvalue('/preferredOriginID=',\@event); - print "origin ID = $evt_origID\n"; - - # --- selects preferred origin - my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); - - # --- gets origin:time - my $evt_time = findvalue('/time/value=',\@origin); - print "origin time = $evt_time\n"; - - # --- gets origin:latitude - my $evt_lat = findvalue('/latitude/value=',\@origin); - print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; - - # --- gets origin:longitude - my $evt_lon = findvalue('/longitude/value=',\@origin); - print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; - - # --- gets origin:methodID - my $evt_mcID = findvalue('/methodID=',\@origin) // ''; - print "origin methodID (MCID) = $evt_mcID\n"; - my $mcIDname = (split(/\//,$evt_mcID))[-3]; - my $mcIDym = (split(/\//,$evt_mcID))[-2]; - my $mcIDid = (split(/\//,$evt_mcID))[-1]; - - # --- gets origin:depth - my $evt_dep = findvalue('/depth/value=',\@origin); - $evt_dep /= 1000 if ($evt_dep ne ""); - print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; - - # --- gets description:text - my $evt_txt = findvalue('/description/text=',\@event); - print "origin description = $evt_txt \n"; - - # --- gets origin:evaluationMode and origin:evaluationStatus - my $evt_mode = findvalue('/evaluationMode=',\@origin); - my $evt_status = findvalue('/evaluationStatus=',\@origin); - if ($evt_status && $evt_status eq 'confirmed') { - $evt_type = 'UNKNOWN'; - } else { - $evt_type = 'AUTO'; - } - - print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; - print "origin status = ".($evt_status ? "$evt_status":"")."\n"; - - # --- gets preferred magnitude ID - my $evt_magID = findvalue('/preferredMagnitudeID=',\@event); - - my $evt_mag = ''; - my $evt_magtyp = ''; - my $evt_smag = ''; - my @magnitude; - if ($evt_magID) { - print "origin magnitude ID = $evt_magID\n"; - @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@event); - } else { - @magnitude = findnode('/magnitude','/\@publicID=',\@event); - print "* Warning: no preferred magnitude! Takes first...\n"; - } - if (@magnitude) { - $evt_mag = findvalue('/mag/value=',\@magnitude); - print "origin magnitude = $evt_mag\n"; - $evt_smag = $evt_mag; - $evt_magtyp = findvalue('/type=',\@magnitude); - print "origin magnitude type = $evt_magtyp\n"; - } else { - print "* Warning: no magnitude!\n"; - } - - - # --- selects first pick - # sorting pick:time:value = chronological order - @tab = sort(findvalues('/pick/time/value=',\@event)); - my $evt_pick = $tab[0]; - my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); - my $evt_pickID = findvalue('/\@publicID=',\@pick); - my $evt_sdate = substr($evt_pick,0,10) // ''; - my $evt_stime = substr($evt_pick,11,11) // ''; - $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" - my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; - my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; - my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; - my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; - my $evt_scode = "$NET.$STA.$LOC.$CHA"; - print "station pickID = $evt_pickID\n"; - print "station time = $evt_pick\n"; - print "station code = $evt_scode\n"; - - - my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); - - my $evt_pha = ''; - my $evt_dist = ''; - my $evt_unique = 0; - my $evt_SP = ''; - if (@arrival) { - # --- unique arrival or not - if (scalar(@arrival) == 1) { - $evt_unique = 1; - } - - # --- finds first station phase and distance (using "origin:arrival") - $evt_pha = findvalue('/phase=',\@arrival); - $evt_dist = findvalue('/distance=',\@arrival); - $evt_dist *= 111 if ($evt_dist); - print "station phase = $evt_pha\n"; - print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; - # --- computes S-P and duration from distance and magnitude - $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); - print "station S-P = $evt_SP\n"; - } else { - print "* Warning: no arrivals (phase, distance, S-P)!\n"; - } - - # --- computes duration from distance and magnitude - my $evt_dur = ''; - if ($evt_smag && $evt_dist) { - $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); - print "station duration = $evt_dur\n"; - if ($evt_dur == 0) { - $evt_dur = ''; - } - } else { - print "* Warning: no duration!\n"; - } - - - my $lockFile = "/tmp/.$mc3.lock"; - - if ($arg =~ /update/) { - # --- checks lock file - if (-e $lockFile) { - my $lockWho = qx(cat $lockFile | xargs echo -n); - die "WEBOBS: MC is presently edited by $lockWho ..."; - } else { - my $retLock = qx(echo "$oper" > $lockFile); - } - } - - my $mc_id; - my $newID = 1; - my $maxID = 0; - - # --- reads MC file - my ($mcy,$mcm) = split(/-/,$evt_sdate); - $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; - my @lignes; - if (-e $mc_file) { - print "MC file: $mc_file ..."; - open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); - while() { - my $line = $_; - ($mc_id) = split(/\|/,$line); - # --- check if $evt_mcID found - if ($evt_mcID ne '' && $mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { - $newID = 0; - my @txt = split(/\|/,$line); - $txt[13] = "$fdsnws_server:\/\/$evt_id"; - # @txt last field already contains "\n" - $line = join('|',@txt); - } - $maxID = abs($mc_id) if (abs($mc_id) > $maxID); - push(@lignes,$line); - } - close(FILE); - print " imported (max ID = $maxID).\n"; - } else { - # MC file does not exist: need to create directory and empty file. - if ($arg =~ /update/) { - qx(mkdir -p `dirname $mc_file`); - open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); - print FILE (""); - close(FILE); - $mc_id = 1; - } - } - - # --- outputs for MC - if ($newID > 0) { - $mc_id = $maxID + 1; - my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$fdsnws_server:\/\/$evt_id||$oper|$evt_magtyp$evt_mag $evt_txt\n"; - print "$newline\n"; - push(@lignes,$newline); - } - - - if ($arg =~ /update/) { - @lignes = sort Sort_date_with_id(@lignes); - - # Temporary file for sanity check before replacing - my $mc_file_temp="$mc_file.tmp"; - # Open temporary file for writing - open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); - # Write the updated lines - print FILE @lignes; - close(FILE); - # Sanity check : the columns number must always be 17 - if (system("awk -F'|' 'NF!=17{exit 1}' $mc_file") == 0) { - # Test passed, the file isn't corrupted - # The update should have increased the file size - if ( -s $mc_file_temp >= -s $mc_file ) { - # The file size is increased - # Replace the old file by the new one - if ( system("mv $mc_file_temp $mc_file") == 0 ) { - print "MC file: $mc_file updated\n"; - } else { - Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); - } - } - } else { - print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; - } - - # --- deletes lock file - if (-e $lockFile) { - unlink $lockFile; - } - } - } - } - - setlocale(LC_NUMERIC,$old_locale); + my $evt_id = $_; + print "--- $evt_id ---\n"; + + my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; + my @lines = qx(grep "${fdsnws_server}:\/\/${evt_id}" $mc_path|xargs echo -n); + my $mc_file; + + if (@lines) { + + # event's ID already exists in MC: do nothing (for the moment...) + $mc_file = ""; + } else { + + # ------------------------------------------------------------------------- + # event seems new: updates MC file + + my @tab; + my $s; + + my @event = qx(curl -s -S --globoff "${fdsnws_url}${fdsnws_detail}&format=xml&eventid=$evt_id" | $WEBOBS{XML2_PRGM}); + + $s = '/q:quakeml/eventParameters/event'; + foreach (@event) { s/^$s//g; } + + if ($arg =~ /dumper/) { + print join('',@event); + } + chomp(@event); + + # --- gets event type + my $evt_type = findvalue('/type=',\@event) // ''; + print "event type = $evt_type\n"; + if (grep(/^$evt_type$/,@blacklist_types)) { + print "Warning: Event type '$evt_type' is blacklisted!\n"; + } else { + + # --- gets preferred origin ID + my $evt_origID = findvalue('/preferredOriginID=',\@event); + print "origin ID = $evt_origID\n"; + + # --- selects preferred origin + my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); + + # --- gets origin:time + my $evt_time = findvalue('/time/value=',\@origin); + print "origin time = $evt_time\n"; + + # --- gets origin:latitude + my $evt_lat = findvalue('/latitude/value=',\@origin); + print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; + + # --- gets origin:longitude + my $evt_lon = findvalue('/longitude/value=',\@origin); + print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; + + # --- gets origin:methodID + my $evt_mcID = findvalue('/methodID=',\@origin) // ''; + print "origin methodID (MCID) = $evt_mcID\n"; + my $mcIDname = (split(/\//,$evt_mcID))[-3]; + my $mcIDym = (split(/\//,$evt_mcID))[-2]; + my $mcIDid = (split(/\//,$evt_mcID))[-1]; + + # --- gets origin:depth + my $evt_dep = findvalue('/depth/value=',\@origin); + $evt_dep /= 1000 if ($evt_dep ne ""); + print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; + + # --- gets description:text + my $evt_txt = findvalue('/description/text=',\@event); + print "origin description = $evt_txt \n"; + + # --- gets origin:evaluationMode and origin:evaluationStatus + my $evt_mode = findvalue('/evaluationMode=',\@origin); + my $evt_status = findvalue('/evaluationStatus=',\@origin); + if ($evt_status && $evt_status eq 'confirmed') { + $evt_type = 'UNKNOWN'; + } else { + $evt_type = 'AUTO'; + } + + print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; + print "origin status = ".($evt_status ? "$evt_status":"")."\n"; + + # --- gets preferred magnitude ID + my $evt_magID = findvalue('/preferredMagnitudeID=',\@event); + + my $evt_mag = ''; + my $evt_magtyp = ''; + my $evt_smag = ''; + my @magnitude; + if ($evt_magID) { + print "origin magnitude ID = $evt_magID\n"; + @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@event); + } else { + @magnitude = findnode('/magnitude','/\@publicID=',\@event); + print "* Warning: no preferred magnitude! Takes first...\n"; + } + if (@magnitude) { + $evt_mag = findvalue('/mag/value=',\@magnitude); + print "origin magnitude = $evt_mag\n"; + $evt_smag = $evt_mag; + $evt_magtyp = findvalue('/type=',\@magnitude); + print "origin magnitude type = $evt_magtyp\n"; + } else { + print "* Warning: no magnitude!\n"; + } + + # --- selects first pick + # sorting pick:time:value = chronological order + @tab = sort(findvalues('/pick/time/value=',\@event)); + my $evt_pick = $tab[0]; + my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); + my $evt_pickID = findvalue('/\@publicID=',\@pick); + my $evt_sdate = substr($evt_pick,0,10) // ''; + my $evt_stime = substr($evt_pick,11,11) // ''; + $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" + my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; + my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; + my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; + my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; + my $evt_scode = "$NET.$STA.$LOC.$CHA"; + print "station pickID = $evt_pickID\n"; + print "station time = $evt_pick\n"; + print "station code = $evt_scode\n"; + + my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); + + my $evt_pha = ''; + my $evt_dist = ''; + my $evt_unique = 0; + my $evt_SP = ''; + if (@arrival) { + + # --- unique arrival or not + if (scalar(@arrival) == 1) { + $evt_unique = 1; + } + + # --- finds first station phase and distance (using "origin:arrival") + $evt_pha = findvalue('/phase=',\@arrival); + $evt_dist = findvalue('/distance=',\@arrival); + $evt_dist *= 111 if ($evt_dist); + print "station phase = $evt_pha\n"; + print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; + + # --- computes S-P and duration from distance and magnitude + $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); + print "station S-P = $evt_SP\n"; + } else { + print "* Warning: no arrivals (phase, distance, S-P)!\n"; + } + + # --- computes duration from distance and magnitude + my $evt_dur = ''; + if ($evt_smag && $evt_dist) { + $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); + print "station duration = $evt_dur\n"; + if ($evt_dur == 0) { + $evt_dur = ''; + } + } else { + print "* Warning: no duration!\n"; + } + + my $lockFile = "/tmp/.$mc3.lock"; + + if ($arg =~ /update/) { + + # --- checks lock file + if (-e $lockFile) { + my $lockWho = qx(cat $lockFile | xargs echo -n); + die "WEBOBS: MC is presently edited by $lockWho ..."; + } else { + my $retLock = qx(echo "$oper" > $lockFile); + } + } + + my $mc_id; + my $newID = 1; + my $maxID = 0; + + # --- reads MC file + my ($mcy,$mcm) = split(/-/,$evt_sdate); + $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; + my @lignes; + if (-e $mc_file) { + print "MC file: $mc_file ..."; + open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); + while() { + my $line = $_; + ($mc_id) = split(/\|/,$line); + + # --- check if $evt_mcID found + if ($evt_mcID ne '' && $mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { + $newID = 0; + my @txt = split(/\|/,$line); + $txt[13] = "$fdsnws_server:\/\/$evt_id"; + + # @txt last field already contains "\n" + $line = join('|',@txt); + } + $maxID = abs($mc_id) if (abs($mc_id) > $maxID); + push(@lignes,$line); + } + close(FILE); + print " imported (max ID = $maxID).\n"; + } else { + + # MC file does not exist: need to create directory and empty file. + if ($arg =~ /update/) { + qx(mkdir -p `dirname $mc_file`); + open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); + print FILE (""); + close(FILE); + $mc_id = 1; + } + } + + # --- outputs for MC + if ($newID > 0) { + $mc_id = $maxID + 1; + my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$fdsnws_server:\/\/$evt_id||$oper|$evt_magtyp$evt_mag $evt_txt\n"; + print "$newline\n"; + push(@lignes,$newline); + } + + if ($arg =~ /update/) { + @lignes = sort Sort_date_with_id(@lignes); + + # Temporary file for sanity check before replacing + my $mc_file_temp="$mc_file.tmp"; + + # Open temporary file for writing + open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); + + # Write the updated lines + print FILE @lignes; + close(FILE); + + # Sanity check : the columns number must always be 17 + if (system("awk -F'|' 'NF!=17{exit 1}' $mc_file") == 0) { + + # Test passed, the file isn't corrupted + # The update should have increased the file size + if ( -s $mc_file_temp >= -s $mc_file ) { + + # The file size is increased + # Replace the old file by the new one + if ( system("mv $mc_file_temp $mc_file") == 0 ) { + print "MC file: $mc_file updated\n"; + } else { + Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); + } + } + } else { + print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; + } + + # --- deletes lock file + if (-e $lockFile) { + unlink $lockFile; + } + } + } + } + + setlocale(LC_NUMERIC,$old_locale); } - #-------------------------------------------------------------------------------------------------------------------------------------- sub Sort_date_with_id ($$) { - my ($c,$d) = @_; + my ($c,$d) = @_; - # removes the first field (ID) - $c =~ s/^[\-0-9]+\|//; - $d =~ s/^[\-0-9]+\|//; + # removes the first field (ID) + $c =~ s/^[\-0-9]+\|//; + $d =~ s/^[\-0-9]+\|//; - return $d cmp $c; + return $d cmp $c; } #-------------------------------------------------------------------------------------------------------------------------------------- sub Quit { - if (-e $_[0]) { - unlink $_[0]; - } - die "WEBOBS: $_[1]"; + if (-e $_[0]) { + unlink $_[0]; + } + die "WEBOBS: $_[1]"; } __END__ diff --git a/CODE/perl/jobq.pl b/CODE/perl/jobq.pl index dab2b35b..3f392b8b 100755 --- a/CODE/perl/jobq.pl +++ b/CODE/perl/jobq.pl @@ -20,7 +20,7 @@ =head1 DESCRIPTION use strict; use warnings; use FindBin; -use lib $FindBin::Bin; +use lib $FindBin::Bin; use Time::HiRes qw/time gettimeofday tv_interval usleep/; use POSIX qw/strftime :signal_h :errno_h :sys_wait_h/; use IO::Socket; @@ -44,34 +44,35 @@ =head1 DESCRIPTION our %SCHED; if ($configf ne '' && -e $configf) { %SCHED = readCfg($configf) } else { if (defined($WEBOBS{CONF_SCHEDULER})) { %SCHED = readCfg($WEBOBS{CONF_SCHEDULER}) }} -if ( scalar(keys(%SCHED)) <= 1 ) { - printf ("%16.6f %s",time,"can't start: no|invalid configuration file\n"); - exit(1); +if ( scalar(keys(%SCHED)) <= 1 ) { + printf ("%16.6f %s",time,"can't start: no|invalid configuration file\n"); + exit(1); } # ---- send command / receive reply from scheduler # ---------------------------------------------------------------------------- my $SOCK = undef; -my $server = "localhost"; +my $server = "localhost"; my $TIMEOUT=5; # create socket $SOCK = IO::Socket::INET->new(Proto => 'udp', PeerPort => $SCHED{PORT}, PeerAddr => $server ); if ( !$SOCK ) { - printf "couldn't create socket on port $SCHED{PORT}\n"; - exit(2); + printf "couldn't create socket on port $SCHED{PORT}\n"; + exit(2); } + # send / receive if ( $SOCK->send($msg) ) { - if ( $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) ) { - print "Server ".$SOCK->peerhost.":".$SOCK->peerport." replied:\n$msg\n"; - } else { - print "socket recv error\n"; - exit(3); - } + if ( $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) ) { + print "Server ".$SOCK->peerhost.":".$SOCK->peerport." replied:\n$msg\n"; + } else { + print "socket recv error\n"; + exit(3); + } } else { - print "socket send error\n"; - exit(3); + print "socket send error\n"; + exit(3); } exit(0); diff --git a/CODE/perl/lib/Config.pm b/CODE/perl/lib/Config.pm index 48f629e7..bce27a33 100644 --- a/CODE/perl/lib/Config.pm +++ b/CODE/perl/lib/Config.pm @@ -99,31 +99,30 @@ $VERSION = "2.00"; my $confF1 = "/etc/webobs.d/WEBOBS.rc"; if (-e $confF1) { - %WEBOBS = readCfg($confF1) ; - $WEBOBS_LFN = "from $confF1 (".(stat($confF1))[9].")"; + %WEBOBS = readCfg($confF1) ; + $WEBOBS_LFN = "from $confF1 (".(stat($confF1))[9].")"; } our $cgi_msg_html = ""; if ( defined($WEBOBS{CGI_MSG}) && -e $WEBOBS{CGI_MSG} ) { - if (open(FILE, "<$WEBOBS{CGI_MSG}")) { - while() { $cgi_msg_html .= $_ } - close(FILE); - } + if (open(FILE, "<$WEBOBS{CGI_MSG}")) { + while() { $cgi_msg_html .= $_ } + close(FILE); + } } else { - $cgi_msg_html = "

    WebObs Error

    "; + $cgi_msg_html = "

    WebObs Error

    "; } sub webobs_cgi_msg { - my $msg = shift; - print $cgi_msg_html; - $msg =~ s/\n/ /g; # \n once found nullifying the following match - $msg =~ /^(.*)( at.*line.*)/; - my $p1 = "$1
    "; - my $p2 = "".basename($2)." on ".localtime(time())."<\/span>"; - print "

    $p1

    $p2"; + my $msg = shift; + print $cgi_msg_html; + $msg =~ s/\n/ /g; # \n once found nullifying the following match + $msg =~ /^(.*)( at.*line.*)/; + my $p1 = "$1
    "; + my $p2 = "".basename($2)." on ".localtime(time())."<\/span>"; + print "

    $p1

    $p2"; } - =pod =head2 readFile @@ -144,22 +143,22 @@ readFile blocks until it acquires a shared lock on the file to be read. sub readFile { - my $File=$_[0]; - my @raw; my @contenu; - my $line = ""; - if (-f $File) { - open(FILE, "<$File") || die "couldn't open file $File. $!"; - unless ( flock(FILE, LOCK_SH | LOCK_NB)) { - warn "waiting for lock on $File..."; - flock(FILE, LOCK_SH); - } - seek(FILE, 0, SEEK_SET); - if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } - else { while() { push(@raw,$_)} } - close(FILE); # close automatically releases LOCK - } - for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } - return @contenu; + my $File=$_[0]; + my @raw; my @contenu; + my $line = ""; + if (-f $File) { + open(FILE, "<$File") || die "couldn't open file $File. $!"; + unless ( flock(FILE, LOCK_SH | LOCK_NB)) { + warn "waiting for lock on $File..."; + flock(FILE, LOCK_SH); + } + seek(FILE, 0, SEEK_SET); + if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } + else { while() { push(@raw,$_)} } + close(FILE); # close automatically releases LOCK + } + for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } + return @contenu; } =pod @@ -183,23 +182,23 @@ Reference (pointer) to file contents might help perf/storage on huge files. sub xreadFile { - my $File=$_[0]; - my @raw; my @contenu; my $ts=''; - my $line = ""; - if (-f $File) { - open(FILE, "<$File") || die "couldn't open file $File. $!"; - unless ( flock(FILE, LOCK_SH | LOCK_NB)) { - warn "waiting for lock on $File..."; - flock(FILE, LOCK_SH); - } - $ts = (stat($File))[9]; - seek(FILE, 0, SEEK_SET); - if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } - else { while() { push(@raw,$_)} } - close(FILE); # close automatically releases LOCK - } - for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } - return (\@contenu, $ts); + my $File=$_[0]; + my @raw; my @contenu; my $ts=''; + my $line = ""; + if (-f $File) { + open(FILE, "<$File") || die "couldn't open file $File. $!"; + unless ( flock(FILE, LOCK_SH | LOCK_NB)) { + warn "waiting for lock on $File..."; + flock(FILE, LOCK_SH); + } + $ts = (stat($File))[9]; + seek(FILE, 0, SEEK_SET); + if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } + else { while() { push(@raw,$_)} } + close(FILE); # close automatically releases LOCK + } + for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } + return (\@contenu, $ts); } =pod @@ -215,20 +214,20 @@ and removing commented lines (# in col1), blank lines, and all \r (CR). sub readCfgFile { - my $configFile = $_[0]; - my $utf8 = $_[1]; - my @raw; my @contenu; - my $line = ""; - my @fraw = readFile($configFile); - for (@fraw) { - $_ =~ s/\r//g; - chomp($_); - push(@contenu,($utf8 ? $_:l2u($_))); - } - @contenu = grep(!/^#/, @contenu); - @contenu = grep(!/^$/, @contenu); - for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } - return @contenu; + my $configFile = $_[0]; + my $utf8 = $_[1]; + my @raw; my @contenu; + my $line = ""; + my @fraw = readFile($configFile); + for (@fraw) { + $_ =~ s/\r//g; + chomp($_); + push(@contenu,($utf8 ? $_:l2u($_))); + } + @contenu = grep(!/^#/, @contenu); + @contenu = grep(!/^$/, @contenu); + for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } + return @contenu; } =pod @@ -247,58 +246,60 @@ if none is specified). See DESCRIPTION above for a description of readCfg interp sub readCfg { - my $fn = $_[0]; - my $sort = grep( /^sorted$/, @_[1..$#_] ); - my $escape = grep ( /^escape$/, @_[1..$#_] ); - my $novsub = grep ( /^novsub$/, @_[1..$#_] ); - my $id = 0; - my (@df, @wrk, $i, $l, %H, @A); - my @fraw = readFile($fn); - chomp(@fraw); - for (@fraw) { - s/(? 2) { # key|val1|...|valN ? build an HoH - for ($i = 1; $i < @df; $i++) { - $H{$wrk[0]}{$df[$i]} = $wrk[$i]; - } - $H{$wrk[0]}{_SO_} = sprintf("%03d",++$id) if ($sort); - next; - } - push(@A, [@wrk]); # otherwise build an AoA - } - if (@A) { return @A; } - if (%H) { - no warnings "uninitialized"; - if (!$novsub) { + my $fn = $_[0]; + my $sort = grep( /^sorted$/, @_[1..$#_] ); + my $escape = grep ( /^escape$/, @_[1..$#_] ); + my $novsub = grep ( /^novsub$/, @_[1..$#_] ); + my $id = 0; + my (@df, @wrk, $i, $l, %H, @A); + my @fraw = readFile($fn); + chomp(@fraw); + for (@fraw) { + s/(? 2) { # key|val1|...|valN ? build an HoH + for ($i = 1; $i < @df; $i++) { + $H{$wrk[0]}{$df[$i]} = $wrk[$i]; + } + $H{$wrk[0]}{_SO_} = sprintf("%03d",++$id) if ($sort); + next; + } + push(@A, [@wrk]); # otherwise build an AoA + } + if (@A) { return @A; } + if (%H) { + no warnings "uninitialized"; + if (!$novsub) { for my $key (keys %H) { $H{$key} =~ s/[\$][\{](.*?)[\}]/$H{$1}/g; } + # need two passes, last one also handling %WEBOBS substitution - for my $key (keys %H) { - $H{$key} =~ s/[\$][\{](.*?)[\}]/$H{$1}/g; - $H{$key} =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; - } - } - use warnings; - return %H; - } - # Use an explicit return in case $fn is undefined or the file is empty - # (otherwise an implicit return would return [0]). - return; + for my $key (keys %H) { + $H{$key} =~ s/[\$][\{](.*?)[\}]/$H{$1}/g; + $H{$key} =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; + } + } + use warnings; + return %H; + } + + # Use an explicit return in case $fn is undefined or the file is empty + # (otherwise an implicit return would return [0]). + return; } =pod @@ -331,42 +332,47 @@ Return codes from notify: =cut sub notify { - my $req = shift; - - if (not $WEBOBS{POSTBOARD_NPIPE}) { - # Cannot contact postboard: fifo is not defined - return 98; - } - if (not $req) { - # No argument: nothing to send - return 97; - } - - my @cmd = (time, split(/\|/, $req)); - if (@cmd == 3) { - # The message argument may be empty (action without argument). - push(@cmd, ''); - } - - if (@cmd != 4) { - # There must be 4 fields in the notification message - return 99; - } - - my $rc = sysopen(my $fifo, "$WEBOBS{POSTBOARD_NPIPE}", O_NONBLOCK|O_WRONLY); - if (not $rc) { - # Error while opening the fifo - return 96; - } - - # Rebuild and write the final request to the pipe - # avoiding any \n over the pipe. - my $postboard_request = join('|', @cmd) =~ s/\n/\0/gr; - print($fifo "$postboard_request\n"); - close($fifo) - or warn "An error occurred while closing '$WEBOBS{POSTBOARD_NPIPE}'"; - - return 0; + my $req = shift; + + if (not $WEBOBS{POSTBOARD_NPIPE}) { + + # Cannot contact postboard: fifo is not defined + return 98; + } + if (not $req) { + + # No argument: nothing to send + return 97; + } + + my @cmd = (time, split(/\|/, $req)); + if (@cmd == 3) { + + # The message argument may be empty (action without argument). + push(@cmd, ''); + } + + if (@cmd != 4) { + + # There must be 4 fields in the notification message + return 99; + } + + my $rc = sysopen(my $fifo, "$WEBOBS{POSTBOARD_NPIPE}", O_NONBLOCK|O_WRONLY); + if (not $rc) { + + # Error while opening the fifo + return 96; + } + + # Rebuild and write the final request to the pipe + # avoiding any \n over the pipe. + my $postboard_request = join('|', @cmd) =~ s/\n/\0/gr; + print($fifo "$postboard_request\n"); + close($fifo) + or warn "An error occurred while closing '$WEBOBS{POSTBOARD_NPIPE}'"; + + return 0; } 1; diff --git a/CODE/perl/lib/DBForm.pm b/CODE/perl/lib/DBForm.pm index dc7112a4..47735e58 100644 --- a/CODE/perl/lib/DBForm.pm +++ b/CODE/perl/lib/DBForm.pm @@ -146,219 +146,221 @@ set_message(\&webobs_cgi_msg); # DBFORM constructor sub new { my ( $class, $Name ) = @_; - my $self = {}; + my $self = {}; - # name : Form name + # name : Form name die "Missing form name" if !defined($Name); - $self->{name} = $Name; + $self->{name} = $Name; + + # path : path to configs dir + $self->{path} = "$WEBOBS{PATH_FORMS}/$Name"; + + # conf : full path to this config + die "No configuration found for $Name" if (! -e $self->{path}."/$Name.conf"); + $self->{conf} = { readCfg($self->{path}."/$Name.conf") }; + + # dbname : database name - create if needed and ddl is available + $self->{dbname} = "$WEBOBS{PATH_DATA_DB}/".$self->{conf}{DBNAME}; + if (! -e $self->{dbname}) { + die "No database and no ddl to create it for $Name" if (! -e $self->{path}."/$Name.ddl"); + xddl($self->{dbname}, $self->{path}."/$Name.ddl"); + } + + # _procs : PROCS referencing this form + opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); + my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; + for my $proc ( @Ps ) { + my %P = readProc($proc); + $self->{_procs}{$proc} = $P{$proc}{NAME} ; + } + closedir(DIR); - # path : path to configs dir - $self->{path} = "$WEBOBS{PATH_FORMS}/$Name"; + # dbh : DB Handle from connect to DB + my %dbattr = ( RaiseError => 0, PrintError => 0 ); + $self->{dbh} = DBI->connect("dbi:SQLite:$self->{dbname}","","",\%dbattr) + or die "couldn't connect to $self->{dbname}: $DBI::errstr\n"; + $self->{dbh}->do("pragma foreign_keys = ON"); - # conf : full path to this config - die "No configuration found for $Name" if (! -e $self->{path}."/$Name.conf"); - $self->{conf} = { readCfg($self->{path}."/$Name.conf") }; + # _icols , _dcols : resp. hash of IDS and DATA columns' info + $self->{_icols} = $self->{dbh}->selectall_hashref("pragma table_info(ids)","cid") ; + $self->{_dcols} = $self->{dbh}->selectall_hashref("pragma table_info(data)","cid"); - # dbname : database name - create if needed and ddl is available - $self->{dbname} = "$WEBOBS{PATH_DATA_DB}/".$self->{conf}{DBNAME}; - if (! -e $self->{dbname}) { - die "No database and no ddl to create it for $Name" if (! -e $self->{path}."/$Name.ddl"); - xddl($self->{dbname}, $self->{path}."/$Name.ddl"); - } + # the sql 'where' clause used by select method (without leading "and") + $self->{where} = " ids.hidden = 'N' "; - # _procs : PROCS referencing this form - opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); - my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; - for my $proc ( @Ps ) { - my %P = readProc($proc); - $self->{_procs}{$proc} = $P{$proc}{NAME} ; - } - closedir(DIR); - - # dbh : DB Handle from connect to DB - my %dbattr = ( RaiseError => 0, PrintError => 0 ); - $self->{dbh} = DBI->connect("dbi:SQLite:$self->{dbname}","","",\%dbattr) - or die "couldn't connect to $self->{dbname}: $DBI::errstr\n"; - $self->{dbh}->do("pragma foreign_keys = ON"); - - # _icols , _dcols : resp. hash of IDS and DATA columns' info - $self->{_icols} = $self->{dbh}->selectall_hashref("pragma table_info(ids)","cid") ; - $self->{_dcols} = $self->{dbh}->selectall_hashref("pragma table_info(data)","cid"); - - # the sql 'where' clause used by select method (without leading "and") - $self->{where} = " ids.hidden = 'N' "; - - # the sql 'order by' clause used by select method - $self->{order} = " ORDER BY ids.ts1 ASC"; - - bless $self, $class; + # the sql 'order by' clause used by select method + $self->{order} = " ORDER BY ids.ts1 ASC"; + + bless $self, $class; return $self; } # system's resource mngt might use DESTROY: make sure we disconnect from DB sub DESTROY { - my $self = shift; - $self->{sth}->finish if ($self->{sth}); - $self->{dbh}->disconnect if $self->{dbh}; + my $self = shift; + $self->{sth}->finish if ($self->{sth}); + $self->{dbh}->disconnect if $self->{dbh}; } # get the configuration parameter named $k sub conf { - my ($self, $k) = @_; - return $self->{conf}{$k} if (defined($k)); -} + my ($self, $k) = @_; + return $self->{conf}{$k} if (defined($k)); +} # select all rows or row matching the optional $id (ie. column 'id') argument # following a call to 'select', the 'fetch' method is used to retrieve # results one row at a time. sub select { - my ($self, $id) = @_; - undef($self->{errstr}) if ($self->{errstr}); - undef($self->{cols}) if ($self->{cols}); - $self->{sth}->finish if ($self->{sth}); - my $where = ($self->{where} && $self->{where} ne "") ? " and $self->{where} " : ""; - $where .= (defined($id)) ? " AND ids.id = $id " : ""; - - $self->{cols} = join(',', map { "ids.$self->{_icols}{$_}{name}" } sort keys($self->{_icols})) . "," ; - $self->{cols} .= join(",", map { "data.$self->{_dcols}{$_}{name}" } grep { $self->{_dcols}{$_}{name} !~ /ID/ } sort keys($self->{_dcols})); - - my $stmt = "SELECT $self->{cols} FROM ids, data WHERE ids.id = data.id $where $self->{order}"; - - if ($self->{sth} = $self->{dbh}->prepare($stmt)) { - if (! $self->{sth}->execute) { $self->{errstr} = "failed to execute: $DBI::errstr"; } - } else { $self->{errstr} = "failed to prepare: $DBI::errstr"; } - return; + my ($self, $id) = @_; + undef($self->{errstr}) if ($self->{errstr}); + undef($self->{cols}) if ($self->{cols}); + $self->{sth}->finish if ($self->{sth}); + my $where = ($self->{where} && $self->{where} ne "") ? " and $self->{where} " : ""; + $where .= (defined($id)) ? " AND ids.id = $id " : ""; + + $self->{cols} = join(',', map { "ids.$self->{_icols}{$_}{name}" } sort keys($self->{_icols})) . "," ; + $self->{cols} .= join(",", map { "data.$self->{_dcols}{$_}{name}" } grep { $self->{_dcols}{$_}{name} !~ /ID/ } sort keys($self->{_dcols})); + + my $stmt = "SELECT $self->{cols} FROM ids, data WHERE ids.id = data.id $where $self->{order}"; + + if ($self->{sth} = $self->{dbh}->prepare($stmt)) { + if (! $self->{sth}->execute) { $self->{errstr} = "failed to execute: $DBI::errstr"; } + } else { $self->{errstr} = "failed to prepare: $DBI::errstr"; } + return; } # fetch next single row of a previously 'select' result set # returns a reference to a hash of column => value sub fetch { - my $self = shift; - undef($self->{errstr}) if ($self->{errstr}); - return $self->{sth}->fetchrow_hashref if ($self->{sth}); + my $self = shift; + undef($self->{errstr}) if ($self->{errstr}); + return $self->{sth}->fetchrow_hashref if ($self->{sth}); } # returns array of column-names used in last select sub cols { - my ($self, $k) = @_; - return grep { s/^.*\.// } split(/,/,$self->{cols}) if ($self->{cols}); -} + my ($self, $k) = @_; + return grep { s/^.*\.// } split(/,/,$self->{cols}) if ($self->{cols}); +} # insert : insert row from a CGI query-parameters reference $QP ($QP = $cgi->Vars) # returns ID of new row if successfull, -1 otherwise with {errstr} sub insert { - my ($self, $QP) = @_; - undef($self->{errstr}) if ($self->{errstr}); - $self->{sth}->finish if ($self->{sth}); - my $value = my $id = ''; - my $cIDS = my $cDATA = my $vIDS = my $vDATA = my $val = ""; - # scanning all defined columns, build the cols and values lists of the insert statement : - # only the columns found in QueryString (ie: colname=val); quote values when needed; - for (sort keys($self->{_icols})) { - next if ($_ == 0); # ignore 1st col that must be ID - $val = $QP->{$self->{_icols}{$_}{name}} || undef ; - next if ( !defined($val) ); - $cIDS .= "$self->{_icols}{$_}{name},"; - if ( uc($self->{_icols}{$_}{type}) eq 'TEXT' || uc($self->{_icols}{$_}{type}) eq 'TIMESTAMP' ) { - $vIDS .= "'".$val."'," ; - } else { $vIDS .= $val."," } - } - $cIDS =~ s/,$//; $vIDS =~ s/,$//; # remove extra trailing comma - for (sort keys($self->{_dcols})) { - next if ($_ == 0); # ignore 1st col that must be ID - $val = $QP->{$self->{_dcols}{$_}{name}} || undef ; - next if ( !defined($val) ); - $cDATA .= "$self->{_dcols}{$_}{name},"; - if ( uc($self->{_dcols}{$_}{type}) eq 'TEXT' || uc($self->{_dcols}{$_}{type}) eq 'TIMESTAMP' ) { - $vDATA .= "'".$val."'," ; - } else { $vDATA .= $val."," } - } - $cDATA =~ s/,$//; $vDATA =~ s/,$//; # remove extra trailing comma - # inserts transaction - my $i1 = "INSERT INTO ids($cIDS) VALUES($vIDS)"; - $self->{dbh}->begin_work(); - eval { - local $self->{dbh}->{RaiseError} = 1; - $self->{dbh}->do($i1); - $id = $self->{dbh}->last_insert_id(undef, undef, qw(ids id)); - my $i2 = "INSERT INTO data(id,$cDATA) VALUES($id,$vDATA)\n"; - $self->{dbh}->do($i2); - $self->{dbh}->commit(); - }; - if ($@) { - $self->{errstr} = "insert aborted: $@"; - $id = -1; - eval { $self->{dbh}->rollback }; - } - return $id; + my ($self, $QP) = @_; + undef($self->{errstr}) if ($self->{errstr}); + $self->{sth}->finish if ($self->{sth}); + my $value = my $id = ''; + my $cIDS = my $cDATA = my $vIDS = my $vDATA = my $val = ""; + +# scanning all defined columns, build the cols and values lists of the insert statement : +# only the columns found in QueryString (ie: colname=val); quote values when needed; + for (sort keys($self->{_icols})) { + next if ($_ == 0); # ignore 1st col that must be ID + $val = $QP->{$self->{_icols}{$_}{name}} || undef ; + next if ( !defined($val) ); + $cIDS .= "$self->{_icols}{$_}{name},"; + if ( uc($self->{_icols}{$_}{type}) eq 'TEXT' || uc($self->{_icols}{$_}{type}) eq 'TIMESTAMP' ) { + $vIDS .= "'".$val."'," ; + } else { $vIDS .= $val."," } + } + $cIDS =~ s/,$//; $vIDS =~ s/,$//; # remove extra trailing comma + for (sort keys($self->{_dcols})) { + next if ($_ == 0); # ignore 1st col that must be ID + $val = $QP->{$self->{_dcols}{$_}{name}} || undef ; + next if ( !defined($val) ); + $cDATA .= "$self->{_dcols}{$_}{name},"; + if ( uc($self->{_dcols}{$_}{type}) eq 'TEXT' || uc($self->{_dcols}{$_}{type}) eq 'TIMESTAMP' ) { + $vDATA .= "'".$val."'," ; + } else { $vDATA .= $val."," } + } + $cDATA =~ s/,$//; $vDATA =~ s/,$//; # remove extra trailing comma + + # inserts transaction + my $i1 = "INSERT INTO ids($cIDS) VALUES($vIDS)"; + $self->{dbh}->begin_work(); + eval { + local $self->{dbh}->{RaiseError} = 1; + $self->{dbh}->do($i1); + $id = $self->{dbh}->last_insert_id(undef, undef, qw(ids id)); + my $i2 = "INSERT INTO data(id,$cDATA) VALUES($id,$vDATA)\n"; + $self->{dbh}->do($i2); + $self->{dbh}->commit(); + }; + if ($@) { + $self->{errstr} = "insert aborted: $@"; + $id = -1; + eval { $self->{dbh}->rollback }; + } + return $id; } # get an array of all CHECKS constraints in table DATA sub datachecks { - my $self = shift; - my $row = $self->{dbh}->selectrow_array("SELECT sql FROM sqlite_master WHERE type='table' and name='data' ;"); - return ($row =~ m/check.*\((.*)\)/g); + my $self = shift; + my $row = $self->{dbh}->selectrow_array("SELECT sql FROM sqlite_master WHERE type='table' and name='data' ;"); + return ($row =~ m/check.*\((.*)\)/g); } # delete data : delete row matching $id (ie. column 'id') # delete ID from both 'ids' and 'data' table (using on cascade) sub delete { - my ($self, $id) = @_; - undef($self->{errstr}) if ($self->{errstr}); - $self->{sth}->finish if ($self->{sth}); - if (defined($id)) { - $self->{dbh}->do("DELETE FROM ids WHERE id=$id"); - $self->{errstr} = $self->{dbh}->errstr() if ($self->{dbh}->err()); - } - return; + my ($self, $id) = @_; + undef($self->{errstr}) if ($self->{errstr}); + $self->{sth}->finish if ($self->{sth}); + if (defined($id)) { + $self->{dbh}->do("DELETE FROM ids WHERE id=$id"); + $self->{errstr} = $self->{dbh}->errstr() if ($self->{dbh}->err()); + } + return; } # get PROC(s) of this FORM as a hash of their 'long' name (NAME) sub procs { my ($self) = @_; - return %{$self->{_procs}} if ($self->{_procs}); + return %{$self->{_procs}} if ($self->{_procs}); } # get valid nodes of a PROC of this FORM, returned as a hash of their NAME, ALIAS and FID sub nodes { - my ($self, $proc) = @_; - undef($self->{errstr}) if ($self->{errstr}); - if (defined($proc)) { - if (! $proc ~~ [ map "$_", keys(%{$self->{_procs}})] ) { - my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); - return %L; - } else { - $self->{errstr} = "$proc not in ".$self->{name}."\n" ; - } - } else { - $self->{errstr} = "no proc requested\n" if (!defined($proc)); - } + my ($self, $proc) = @_; + undef($self->{errstr}) if ($self->{errstr}); + if (defined($proc)) { + if (! $proc ~~ [ map "$_", keys(%{$self->{_procs}})] ) { + my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); + return %L; + } else { + $self->{errstr} = "$proc not in ".$self->{name}."\n" ; + } + } else { + $self->{errstr} = "no proc requested\n" if (!defined($proc)); + } } # get a dump of this DBFORM as a string # usage: print $F->dump sub dump { my ($self) = @_; - my $dmp = ''; + my $dmp = ''; $dmp .= sprintf( "Name: %s\n", $self->{name} ); $dmp .= sprintf( "Configuration: %s\n", $self->{path} ); - map { $dmp .= sprintf " $_ => $self->{conf}{$_}\n" } keys %{ $self->{conf}}; + map { $dmp .= sprintf " $_ => $self->{conf}{$_}\n" } keys %{ $self->{conf}}; $dmp .= sprintf( "Database: %s\n", $self->{dbname} ); $dmp .= sprintf( " specific columns: %s\n", join(', ', map { $self->{_dcols}{$_}{name}."($self->{_dcols}{$_}{type})" } sort keys($self->{_dcols})) ); - $dmp .= sprintf( " number of rows: %s\n", $self->{dbh}->selectrow_array( "SELECT COUNT(*) FROM ids") ); - $dmp .= "Related PROC(s): "; - for ( keys(%{$self->{_procs}}) ) { - $dmp .= sprintf(" %s(%s) ", $_, $self->{_procs}{$_}); - } - $dmp .= "\n"; - return $dmp; + $dmp .= sprintf( " number of rows: %s\n", $self->{dbh}->selectrow_array( "SELECT COUNT(*) FROM ids") ); + $dmp .= "Related PROC(s): "; + for ( keys(%{$self->{_procs}}) ) { + $dmp .= sprintf(" %s(%s) ", $_, $self->{_procs}{$_}); + } + $dmp .= "\n"; + return $dmp; } # execute a DDL file $ddl for DataBase $db # ** not requiring db connection ** -sub xddl { - my ($db, $ddl) = @_; - my @qrs = qx(sqlite3 $db < $ddl); +sub xddl { + my ($db, $ddl) = @_; + my @qrs = qx(sqlite3 $db < $ddl); } 1; diff --git a/CODE/perl/lib/Dates.pm b/CODE/perl/lib/Dates.pm index 0bd5f3b9..ba6acd8f 100644 --- a/CODE/perl/lib/Dates.pm +++ b/CODE/perl/lib/Dates.pm @@ -44,7 +44,7 @@ use CGI::Cookie; # Find out if Calendar() can use Date::Calc or has to use our own hack our $HACK_DATE_CALC = 0 ; eval { require Date::Calc; }; -$HACK_DATE_CALC = 1 if (! $@) ; +$HACK_DATE_CALC = 1 if (! $@) ; =pod @@ -65,59 +65,61 @@ If it is not installed (ie. $HACK_DATE_CALC true), it computes the date with a s sub readFeries { - my $s; - - my %KWARGS = @_; - my $file = $KWARGS{conf} ? $KWARGS{conf} : $WEBOBS{FILE_DAYSOFF}; - my $year = $KWARGS{year} ? $KWARGS{year} : strftime('%Y',localtime()); - - my @data = (""); - my @feries = (""); - - # ---- Lecture du fichier de conf - open(FILE, "<$file") || die "readFeries couldn't open $file\n"; - while() { push(@data,l2u($_)); } - close(FILE); - - @data = grep(!/^(#|$)/, @data); - - my($pqy,$pqm,$pqd); - if ($HACK_DATE_CALC) { - eval { ($pqy,$pqm,$pqd)=Date::Calc::Easter_Sunday($year); }; - } else { - my $H = (19*($year%19) + int($year/100) - int($year/400) - int((8*int($year/100) + 13)/25) + 15)%30; - my $I = (int($H/28)*int(29/($H + 1)) * int((21 - $year%19)/11) - 1)*int($H/28) + $H; - my $J = (int($year/4) + $year + $I + 2 + int($year/400) - int($year/100))%7; - my $D = $I - $J; - ($pqy,$pqm,$pqd) = split(/\//,strftime('%Y/%m/%d',localtime(timelocal(0,0,0,28,2,$year-1900) + $D*86400))); # Easter Sunday - } - for (@data) { - my ($dt,$dn) = split(/\|/,$_); - chomp($dn); - if ($dt =~ /^\$Y-/) { - $dt =~ s/\$Y/$year/g; - $s=$dt; - # Easter Sunday (dimanche de Pâques) - } elsif ($dt =~ /^\$PQ /) { - $dt =~ s/\$PQ //g; - if ($HACK_DATE_CALC) { - eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Add_Delta_Days($pqy,$pqm,$pqd,$dt)); }; - } else { - $s = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$pqd,$pqm-1,$pqy-1900) + $dt*86400)); - } - # Nth weekday of the month (nième jour de la semaine dans le mois) - } elsif ($dt =~ /^\$NWM /) { - $dt =~ s/\$NWM //g; - my ($mm,$dw,$nn) = split(/ /,$dt); - if ($HACK_DATE_CALC) { - eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Nth_Weekday_of_Month_Year($year,$mm,$dw,$nn)); }; - } else { - $s = ""; - } - } - push(@feries,"$s|$dn"); - } - return @feries; + my $s; + + my %KWARGS = @_; + my $file = $KWARGS{conf} ? $KWARGS{conf} : $WEBOBS{FILE_DAYSOFF}; + my $year = $KWARGS{year} ? $KWARGS{year} : strftime('%Y',localtime()); + + my @data = (""); + my @feries = (""); + + # ---- Lecture du fichier de conf + open(FILE, "<$file") || die "readFeries couldn't open $file\n"; + while() { push(@data,l2u($_)); } + close(FILE); + + @data = grep(!/^(#|$)/, @data); + + my($pqy,$pqm,$pqd); + if ($HACK_DATE_CALC) { + eval { ($pqy,$pqm,$pqd)=Date::Calc::Easter_Sunday($year); }; + } else { + my $H = (19*($year%19) + int($year/100) - int($year/400) - int((8*int($year/100) + 13)/25) + 15)%30; + my $I = (int($H/28)*int(29/($H + 1)) * int((21 - $year%19)/11) - 1)*int($H/28) + $H; + my $J = (int($year/4) + $year + $I + 2 + int($year/400) - int($year/100))%7; + my $D = $I - $J; + ($pqy,$pqm,$pqd) = split(/\//,strftime('%Y/%m/%d',localtime(timelocal(0,0,0,28,2,$year-1900) + $D*86400))); # Easter Sunday + } + for (@data) { + my ($dt,$dn) = split(/\|/,$_); + chomp($dn); + if ($dt =~ /^\$Y-/) { + $dt =~ s/\$Y/$year/g; + $s=$dt; + + # Easter Sunday (dimanche de Pâques) + } elsif ($dt =~ /^\$PQ /) { + $dt =~ s/\$PQ //g; + if ($HACK_DATE_CALC) { + eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Add_Delta_Days($pqy,$pqm,$pqd,$dt)); }; + } else { + $s = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$pqd,$pqm-1,$pqy-1900) + $dt*86400)); + } + + # Nth weekday of the month (nième jour de la semaine dans le mois) + } elsif ($dt =~ /^\$NWM /) { + $dt =~ s/\$NWM //g; + my ($mm,$dw,$nn) = split(/ /,$dt); + if ($HACK_DATE_CALC) { + eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Nth_Weekday_of_Month_Year($year,$mm,$dw,$nn)); }; + } else { + $s = ""; + } + } + push(@feries,"$s|$dn"); + } + return @feries; } =pod @@ -134,63 +136,66 @@ eg. @calhtml = WebObs::Dates::Calendar(month=>'2012-12',ptri=>'Calendar',today=> sub Calendar { - my @tod = localtime(); - my %HEBDO = readCfg("$WEBOBS{HEBDO_CONF}"); - my %KWARGS = @_; - my $moisCalendrier = $KWARGS{month} ? $KWARGS{month} : strftime('%Y-%m',@tod); - my $parametreTri = $KWARGS{ptri} ? $KWARGS{ptri} : $HEBDO{DEFAULT_TRI}; - my $todayDate = $KWARGS{today} ? $KWARGS{today} : strftime('%Y-%m-%d',@tod); - my (@contenu,$j,$s); - - my $anneeCalendrier = substr($moisCalendrier,0,4); - my @feries = readFeries(year=>$anneeCalendrier); - my $displayMoisCalendrier = l2u(qx(date -d "$moisCalendrier-01" +"\%B \%Y")); chomp($displayMoisCalendrier); - my $moisPrecedent = qx(date -d "$moisCalendrier-01 1 month ago" +"\%Y-\%m"); - my $moisSuivant = qx(date -d "$moisCalendrier-01 1 month" +"\%Y-\%m"); - my $lundiCalendrier = WebObs::Dates::lundi("$moisCalendrier-01"); - - push(@contenu," + my @tod = localtime(); + my %HEBDO = readCfg("$WEBOBS{HEBDO_CONF}"); + my %KWARGS = @_; + my $moisCalendrier = $KWARGS{month} ? $KWARGS{month} : strftime('%Y-%m',@tod); + my $parametreTri = $KWARGS{ptri} ? $KWARGS{ptri} : $HEBDO{DEFAULT_TRI}; + my $todayDate = $KWARGS{today} ? $KWARGS{today} : strftime('%Y-%m-%d',@tod); + my (@contenu,$j,$s); + + my $anneeCalendrier = substr($moisCalendrier,0,4); + my @feries = readFeries(year=>$anneeCalendrier); + my $displayMoisCalendrier = l2u(qx(date -d "$moisCalendrier-01" +"\%B \%Y")); chomp($displayMoisCalendrier); + my $moisPrecedent = qx(date -d "$moisCalendrier-01 1 month ago" +"\%Y-\%m"); + my $moisSuivant = qx(date -d "$moisCalendrier-01 1 month" +"\%Y-\%m"); + my $lundiCalendrier = WebObs::Dates::lundi("$moisCalendrier-01"); + + push(@contenu,"
    \n"); - push(@contenu,""); - # il faut balayer 6 semaines pour être sûr d'avoir le mois complet dans toutes les situations... - for (0..41) { - $j = qx(date -I -d "$lundiCalendrier $_ days"); chomp($j); - if (($_ % 7) == 0) { - if (($_ != 0) && (substr($j,5,2) ne substr($moisCalendrier,5,2))) { - last; - } else { - #$s = qx(date -d "$j" +"\%W"); chomp($s); - # permet de choisir le n° semaine suivant l'année du calendrier (dernière semaine Y ou première semaine Y+1) - if (substr($j,0,4) != $anneeCalendrier) { $s = qx(date -d "$j 6 days" +%V); } - else { $s = qx(date -d "$j" +%V); } - chomp($s); - #push(@contenu,"\n"); - push(@contenu,"\n"); - } - } - if (substr($j,5,2) ne substr($moisCalendrier,5,2)) { - $s = "class=\"CalendarOutMonth\""; - } else { - $s = "class=\"CalendarInMonth\""; - if (($_%7) >= 5) { $s = "class=\"CalendarWeekend\""; } - my @jf = grep(/$j/,@feries); - if (@jf and length($jf[0]) > 0) { - my ($dd,$ss) = split(/\|/,$jf[0]); - chomp($ss); - $ss =~ s/\'/’/g; - $ss =~ s/\"/"/g; - $s = "class=\"CalendarFerie\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\""; - } - } - if ($j eq $todayDate) { $s = "class=\"CalendarToday\""; } - push(@contenu,""); - } - push(@contenu,"
    ⇐ $displayMoisCalendrier ⇒
    ".join("",split(/,/,"$__{'hebdo_weekday_first_letter'}"))."
    $s
    $s".sprintf("%1.0f",substr($j,8,2))."
    "); - - return @contenu; + push(@contenu,"
    		".join("",split(/,/,"$__{'hebdo_weekday_first_letter'}"))."
    $s
    $s".sprintf("%1.0f",substr($j,8,2))."
    "); + + return @contenu; } =pod @@ -207,59 +212,59 @@ Newer version of Calendar function. =cut sub DCalendar { - my @tod = localtime(); - my %KWARGS = @_; - my ($nowY, $nowM, $nowD) = split(/ /,strftime('%Y %m %d',@tod)); - my ($YY, $MM, $DD) = $KWARGS{month} ? split(/-/,"$KWARGS{month}-01") : ($nowY, $nowM, $nowD ); - my $url = $KWARGS{url} ? $KWARGS{url} : ""; - my @feries = readFeries(year=>$YY); - my (@html,$w); - - my $DOW1 = qx(date -d "$YY-$MM-01" +'%u'); chomp($DOW1); - my $nextM = ($MM == 12) ? 1 : sprintf("%02d",$MM+1); my $nextY = $YY+1 ; - my $prevM = ($MM == 1) ? 12 : sprintf("%02d",$MM-1); my $prevY = $YY-1 ; - my $days = qx(date -d "$nextY-$nextM-1 yesterday" +'%d'); chomp($days); - my $th1 = qx(date -d "$YY-$MM-01" '+%b %Y'); chomp($th1); - my $th2 = qx(locale -k LC_TIME | awk 'BEGIN {FS=";"} /^abday=/ { for(i=2;i<=7;i++){ printf "%2.2s ",\$i}; printf "%2.2s",substr(\$1,8,2)}') ; - chomp($th2); - - push(@html,"\n"); - push(@html,"\n"); - - $w = qx(date -d "$YY-$MM-01" +'%-V'); chomp($w); - push(@html,sprintf("
    «"); - push(@html,"‹$th1"); - push(@html,"›»
    $th2
    %02d",$w,$w)); - - for (my $ix = 1; $ix <= $DOW1-1; $ix++) { push(@html,"") } - - my $ixW = $DOW1; my $ixM = 1; - while ( $ixM <= $days ) { - my $class=""; my $hattr=""; - my $aDay = sprintf("$YY-$MM-%02s",$ixM); - if ( $aDay eq "$nowY-$nowM-$nowD" ) { $class .= "today " } - if (($ixW%8) >= 6) { $class .= "SD "; } - my @jf = grep(/$aDay/,@feries); - if (@jf and length($jf[0]) > 0) { - my ($dd,$ss) = split(/\|/,$jf[0]); chomp($ss); - $ss =~ s/\'/’/g; $ss =~ s/\"/"/g; - $class .= "off "; - $hattr = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\" "; - } - - push(@html,sprintf("%2d",$class,$hattr,$ixM)); - if ( ++$ixM <= $days ) { - if ( $ixW >= 7 ) { - $w = qx(date -d "$YY-$MM-$ixM" +'%-V'); chomp($w); - push(@html,sprintf("\n
    %02d ",$w,$w)); - $ixW = 0; - } - } - $ixW++; - } - for (my $ix = 1; $ix <= 8-$ixW; $ix++) { push(@html,"") } - push(@html,"
    "); - return @html; + my @tod = localtime(); + my %KWARGS = @_; + my ($nowY, $nowM, $nowD) = split(/ /,strftime('%Y %m %d',@tod)); + my ($YY, $MM, $DD) = $KWARGS{month} ? split(/-/,"$KWARGS{month}-01") : ($nowY, $nowM, $nowD ); + my $url = $KWARGS{url} ? $KWARGS{url} : ""; + my @feries = readFeries(year=>$YY); + my (@html,$w); + + my $DOW1 = qx(date -d "$YY-$MM-01" +'%u'); chomp($DOW1); + my $nextM = ($MM == 12) ? 1 : sprintf("%02d",$MM+1); my $nextY = $YY+1 ; + my $prevM = ($MM == 1) ? 12 : sprintf("%02d",$MM-1); my $prevY = $YY-1 ; + my $days = qx(date -d "$nextY-$nextM-1 yesterday" +'%d'); chomp($days); + my $th1 = qx(date -d "$YY-$MM-01" '+%b %Y'); chomp($th1); + my $th2 = qx(locale -k LC_TIME | awk 'BEGIN {FS=";"} /^abday=/ { for(i=2;i<=7;i++){ printf "%2.2s ",\$i}; printf "%2.2s",substr(\$1,8,2)}') ; + chomp($th2); + + push(@html,"\n"); + push(@html,"\n"); + + $w = qx(date -d "$YY-$MM-01" +'%-V'); chomp($w); + push(@html,sprintf("
    «"); + push(@html,"‹$th1"); + push(@html,"›»
    $th2
    %02d",$w,$w)); + + for (my $ix = 1; $ix <= $DOW1-1; $ix++) { push(@html,"") } + + my $ixW = $DOW1; my $ixM = 1; + while ( $ixM <= $days ) { + my $class=""; my $hattr=""; + my $aDay = sprintf("$YY-$MM-%02s",$ixM); + if ( $aDay eq "$nowY-$nowM-$nowD" ) { $class .= "today " } + if (($ixW%8) >= 6) { $class .= "SD "; } + my @jf = grep(/$aDay/,@feries); + if (@jf and length($jf[0]) > 0) { + my ($dd,$ss) = split(/\|/,$jf[0]); chomp($ss); + $ss =~ s/\'/’/g; $ss =~ s/\"/"/g; + $class .= "off "; + $hattr = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\" "; + } + + push(@html,sprintf("%2d",$class,$hattr,$ixM)); + if ( ++$ixM <= $days ) { + if ( $ixW >= 7 ) { + $w = qx(date -d "$YY-$MM-$ixM" +'%-V'); chomp($w); + push(@html,sprintf("\n
    %02d ",$w,$w)); + $ixW = 0; + } + } + $ixW++; + } + for (my $ix = 1; $ix <= 8-$ixW; $ix++) { push(@html,"") } + push(@html,"
    "); + return @html; } #fixJul added ymdhms2s @@ -282,19 +287,19 @@ eg. $secs = WebObs::Dates::ymdhms2s('2012-09-15 10:25:02') # secs = 1347697502 =cut -sub ymdhms2s +sub ymdhms2s { - my($s) = @_; - my($year, $month, $day, $hour, $minute, $second); - - if ($s =~ m{^\s*(\d{1,4})\W*0*(\d{1,2})\W*0*(\d{1,2})\W*0*(\d{0,2})\W*0*(\d{0,2})\W*0*(\d{0,2})}x) { - $year = $1; $month = $2; $day = $3; - $hour = $4; $minute = $5; $second = $6; - $hour ||= 0; $minute ||= 0; $second ||= 0; # default hms = 00:00:00 - $year = ($year<100 ? ($year<70 ? 2000+$year : 1900+$year) : $year); - return timelocal($second,$minute,$hour,$day,$month-1,$year); - } - return -1; + my($s) = @_; + my($year, $month, $day, $hour, $minute, $second); + + if ($s =~ m{^\s*(\d{1,4})\W*0*(\d{1,2})\W*0*(\d{1,2})\W*0*(\d{0,2})\W*0*(\d{0,2})\W*0*(\d{0,2})}x) { + $year = $1; $month = $2; $day = $3; + $hour = $4; $minute = $5; $second = $6; + $hour ||= 0; $minute ||= 0; $second ||= 0; # default hms = 00:00:00 + $year = ($year<100 ? ($year<70 ? 2000+$year : 1900+$year) : $year); + return timelocal($second,$minute,$hour,$day,$month-1,$year); + } + return -1; } =pod @@ -309,14 +314,14 @@ eg. $monday = lundi('2012-09-14'); # $monday = 2012-09-10 sub lundi { - my ($y,$m,$d) = split(/[-\/]/,shift); - - my $j = strftime('%w',0,0,0,$d,$m-1,$y-1900); - $j = ($j+6)%7; - my $lundi = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$d,$m-1,$y-1900) - $j*86400)); - chomp($lundi); - - return $lundi; + my ($y,$m,$d) = split(/[-\/]/,shift); + + my $j = strftime('%w',0,0,0,$d,$m-1,$y-1900); + $j = ($j+6)%7; + my $lundi = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$d,$m-1,$y-1900) - $j*86400)); + chomp($lundi); + + return $lundi; } =pod @@ -326,18 +331,18 @@ sub lundi =cut sub weton { - my ($year,$month,$day) = split(/-/,shift); - - my @pasaran = ('Pon','Wagé','Kliwon','Legi','Pahing'); - my @minggu = ('Senèn','Selasa','Rebo','Kemis','Jemuwah','Setu','Akad'); - - my $sec = strftime('%s',0,0,0,$day,$month-1,$year-1900) - strftime('%s',0,0,0,1,0,70); - my $ndays = int($sec/86400) + 3500*35; - my $p = ($ndays+1)%5; - my $m = ($ndays+3)%7; - - #return l2u(sprintf("%s %s",$minggu[$m],$pasaran[$p])); - return sprintf("%s %s",$minggu[$m],$pasaran[$p]); + my ($year,$month,$day) = split(/-/,shift); + + my @pasaran = ('Pon','Wagé','Kliwon','Legi','Pahing'); + my @minggu = ('Senèn','Selasa','Rebo','Kemis','Jemuwah','Setu','Akad'); + + my $sec = strftime('%s',0,0,0,$day,$month-1,$year-1900) - strftime('%s',0,0,0,1,0,70); + my $ndays = int($sec/86400) + 3500*35; + my $p = ($ndays+1)%5; + my $m = ($ndays+3)%7; + + #return l2u(sprintf("%s %s",$minggu[$m],$pasaran[$p])); + return sprintf("%s %s",$minggu[$m],$pasaran[$p]); } 1; diff --git a/CODE/perl/lib/Events.pm b/CODE/perl/lib/Events.pm index 15685ad9..b77e63e4 100644 --- a/CODE/perl/lib/Events.pm +++ b/CODE/perl/lib/Events.pm @@ -104,13 +104,13 @@ NOTE: nodename will be made equals to gridname for normalized grids. =cut sub struct { - return undef if (@_ != 1); - my @obj = split(/\./,$_[0]); - return ($obj[0],$obj[1],$obj[2],"$NODES{PATH_NODES}/$obj[2]/$NODES{SPATH_INTERVENTIONS}","$NODES{PATH_EVENTNODE_TRASH}","N") if ($#obj == 2); - if (defined($GRIDS{PATH_GRIDS}) && $#obj == 1) { - return ($obj[0],$obj[1],$obj[1],"$GRIDS{PATH_GRIDS}/$obj[0]/$obj[1]/$GRIDS{SPATH_INTERVENTIONS}","$GRIDS{PATH_EVENTGRID_TRASH}","G"); - } - return undef; + return undef if (@_ != 1); + my @obj = split(/\./,$_[0]); + return ($obj[0],$obj[1],$obj[2],"$NODES{PATH_NODES}/$obj[2]/$NODES{SPATH_INTERVENTIONS}","$NODES{PATH_EVENTNODE_TRASH}","N") if ($#obj == 2); + if (defined($GRIDS{PATH_GRIDS}) && $#obj == 1) { + return ($obj[0],$obj[1],$obj[1],"$GRIDS{PATH_GRIDS}/$obj[0]/$obj[1]/$GRIDS{SPATH_INTERVENTIONS}","$GRIDS{PATH_EVENTGRID_TRASH}","G"); + } + return undef; } # ------------------------------------------------------------------------------------------- @@ -129,18 +129,19 @@ eventnameSplit(eventname) decodes event name string and returns an array of elem =cut sub eventnameSplit { - # grid name might contain '_' so reads date and time by splitting '-' first - my @pn = split(/-/,$_[0]); # object_year month day_hour minute_version - my @p1 = split(/_/,$pn[0]); - my @p2 = split(/_/,$pn[2]); - my @p3 = split(/_/,$pn[3]); - my $obj = join('_',$p1[0 .. $#p1-1]); - my $date = "$p1[$#p1]-$pn[1]-$p2[0]"; - my $time = "$p2[1]:$p3[0]"; - $time =~ s/NA//; - my $ver = ($#p3 > 0 ? $p3[1]:""); - - return ($obj,$date,$time,$ver); + + # grid name might contain '_' so reads date and time by splitting '-' first + my @pn = split(/-/,$_[0]); # object_year month day_hour minute_version + my @p1 = split(/_/,$pn[0]); + my @p2 = split(/_/,$pn[2]); + my @p3 = split(/_/,$pn[3]); + my $obj = join('_',$p1[0 .. $#p1-1]); + my $date = "$p1[$#p1]-$pn[1]-$p2[0]"; + my $time = "$p2[1]:$p3[0]"; + $time =~ s/NA//; + my $ver = ($#p3 > 0 ? $p3[1]:""); + + return ($obj,$date,$time,$ver); } # ------------------------------------------------------------------------------------------- @@ -164,28 +165,29 @@ headersplit(header) decodes header string and returns an array of elements: =cut sub headersplit { - my ($title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = ""; - # event metadata are stored in the header line of file as pipe-separated fields: - # UID1[+UID2+...][/RUID1[+RUID2+...]]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd - my $pipes = $_[0] =~ tr/\|//; # count the number of pipes in header - my @header = split(/\|/,$_[0]); # splits pipe-separated arguments - my @people = split(/\//,$header[0]); # splits authors and remotes (forward slash separator) - my @UIDs = split(/\+/,$people[0]); # array of authors - my @RUIDs = split(/\+/,$people[1]) if ($#people > 0); # array of remotes - if ($pipes > 1 && $pipes < 6) { - $title = join("\|",@header[1..$#header]); # rare case of a former header with unescaped pipe in the title... - } else { - $title = $header[1] if ($#header > 0); - ($date2,$time2) = split(/ /,$header[2]) if ($#header > 1); - $feature = $header[3] if ($#header > 2); - $channel = $header[4] if ($#header > 3); - $outcome = $header[5] if ($#header > 4); - $notebook = $header[6] if ($#header > 5); - $notebookfwd = $header[7] if ($#header > 6); - } - $title =~ s/\"/\'\'/g; - - return (\@UIDs,\@RUIDs,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd); + my ($title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = ""; + +# event metadata are stored in the header line of file as pipe-separated fields: +# UID1[+UID2+...][/RUID1[+RUID2+...]]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd + my $pipes = $_[0] =~ tr/\|//; # count the number of pipes in header + my @header = split(/\|/,$_[0]); # splits pipe-separated arguments + my @people = split(/\//,$header[0]); # splits authors and remotes (forward slash separator) + my @UIDs = split(/\+/,$people[0]); # array of authors + my @RUIDs = split(/\+/,$people[1]) if ($#people > 0); # array of remotes + if ($pipes > 1 && $pipes < 6) { + $title = join("\|",@header[1..$#header]); # rare case of a former header with unescaped pipe in the title... + } else { + $title = $header[1] if ($#header > 0); + ($date2,$time2) = split(/ /,$header[2]) if ($#header > 1); + $feature = $header[3] if ($#header > 2); + $channel = $header[4] if ($#header > 3); + $outcome = $header[5] if ($#header > 4); + $notebook = $header[6] if ($#header > 5); + $notebookfwd = $header[7] if ($#header > 6); + } + $title =~ s/\"/\'\'/g; + + return (\@UIDs,\@RUIDs,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd); } # ------------------------------------------------------------------------------------------- @@ -207,18 +209,19 @@ sorted by descending dates. =cut sub eventsTree { - return if (@_ != 2) ; - my ($list, $path) = @_; - return if(ref($list) ne 'ARRAY'); - my @entries = sort {$b cmp $a} glob($path."/*"); - foreach my $entry (@entries) { - next if ($entry =~ /_Projet\.txt$|.*\.txt~$|.*backup$/); - next if ($entry =~ /\/PHOTOS\//); - #DL-err5.10: push($list, $entry) if -f $entry; - push(@$list, $entry) if -f $entry; - eventsTree($list, $entry) if -d $entry; - } - return; + return if (@_ != 2) ; + my ($list, $path) = @_; + return if(ref($list) ne 'ARRAY'); + my @entries = sort {$b cmp $a} glob($path."/*"); + foreach my $entry (@entries) { + next if ($entry =~ /_Projet\.txt$|.*\.txt~$|.*backup$/); + next if ($entry =~ /\/PHOTOS\//); + + #DL-err5.10: push($list, $entry) if -f $entry; + push(@$list, $entry) if -f $entry; + eventsTree($list, $entry) if -d $entry; + } + return; } # ------------------------------------------------------------------------------------------- @@ -239,14 +242,15 @@ eventsChrono(list, path) appends to list the sorted (dates descending) events fi =cut sub eventsChrono { - return if (@_ != 2) ; - my ($list, $path) = @_; - return if(ref($list) ne 'ARRAY'); - my @tree; - eventsTree(\@tree, $path); - #DL-err5.10: map { push($list,$_) } sort {basename($b) cmp basename($a)} @tree; - map { push(@$list,$_) } sort {basename($b) cmp basename($a)} @tree; - return; + return if (@_ != 2) ; + my ($list, $path) = @_; + return if(ref($list) ne 'ARRAY'); + my @tree; + eventsTree(\@tree, $path); + + #DL-err5.10: map { push($list,$_) } sort {basename($b) cmp basename($a)} @tree; + map { push(@$list,$_) } sort {basename($b) cmp basename($a)} @tree; + return; } # ------------------------------------------------------------------------------------------- @@ -263,12 +267,12 @@ countProject is an alias for existProject. =cut sub existProject { - return 0 if (@_ != 1); - my ($gt,$gn,$n,$p,$t) = struct($_[0]); - if (defined($p)) { - return 1 if (-e "$p/$n\_Projet.txt"); - } - return 0; + return 0 if (@_ != 1); + my ($gt,$gn,$n,$p,$t) = struct($_[0]); + if (defined($p)) { + return 1 if (-e "$p/$n\_Projet.txt"); + } + return 0; } sub countProject { return existProject(@_) } @@ -286,12 +290,12 @@ countEvents is an alias for existEvents. =cut sub existEvents { - return 0 if (@_ != 1); - my ($gt,$gn,$n,$p,$t) = struct($_[0]); - if (defined($p)) { - return qx(/usr/bin/find $p -name "$n*.txt" 2>/dev/null | wc -l); - } - return 0; + return 0 if (@_ != 1); + my ($gt,$gn,$n,$p,$t) = struct($_[0]); + if (defined($p)) { + return qx(/usr/bin/find $p -name "$n*.txt" 2>/dev/null | wc -l); + } + return 0; } sub countEvents { return existEvents(@_) } @@ -311,96 +315,101 @@ editYN indicates wether current viewing client has authorization to edit events =cut sub eventsShow { - return undef if (@_ != 3); - my ($sortedBy, $objectname, $editOK) = @_; - return undef if ($sortedBy !~ /events|date|feature/i); - - my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); - return undef if (!defined($GRIDType)); - my $html = ''; - my @list; - - eventsTree(\@list, $path) if ($sortedBy =~ /events/i); - eventsChrono(\@list, $path) if ($sortedBy =~ /date|feature/i); - - $html .= "
      \n"; - my $currentIndent = 0; - for my $evt (@list) { - (my $relevt = $evt) =~ s/$path\/// ; # evt = full path to event file; relevt = relative path to event file - (my $extevt = $evt) =~ s/\.txt//; # extevt = full path to event extensions directory - (my $relextevt = $extevt) =~ s/$path\/// ; # relextevt = relative path to event extensions directory - #my ($obj,$date,$time,$ver) = split(/_/,basename($extevt)); + return undef if (@_ != 3); + my ($sortedBy, $objectname, $editOK) = @_; + return undef if ($sortedBy !~ /events|date|feature/i); + + my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); + return undef if (!defined($GRIDType)); + my $html = ''; + my @list; + + eventsTree(\@list, $path) if ($sortedBy =~ /events/i); + eventsChrono(\@list, $path) if ($sortedBy =~ /date|feature/i); + + $html .= "
        \n"; + my $currentIndent = 0; + for my $evt (@list) { + (my $relevt = $evt) =~ s/$path\/// ; # evt = full path to event file; relevt = relative path to event file + (my $extevt = $evt) =~ s/\.txt//; # extevt = full path to event extensions directory + (my $relextevt = $extevt) =~ s/$path\/// ; # relextevt = relative path to event extensions directory + + #my ($obj,$date,$time,$ver) = split(/_/,basename($extevt)); # grid name might contain '_' so reads date and time by splitting '-' - my ($obj,$date,$time,$ver) = eventnameSplit(basename($extevt)); - - my @file = readFile($evt); - #DL-beforeMMD # ignore blank lines and LF - #DL-beforeMMD @file = grep(!/^$/, @file); - #DL-beforeMMD chomp(@file); - - # first line = usersList|title with usersList = a + separated list of userIds, and optional |title - if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' - unshift(@file,"|untitled\n"); # force our own default (add a line) - } - my ($author,$remote,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = headersplit($file[0]); - my @authors = @$author; - my @remotes = @$remote; - my $EVTusers = join(", ",WebObs::Users::userName(@authors)); - my $EVTroper = join(", ",WebObs::Users::userName(@remotes)); - if ($EVTusers ne "" || $EVTroper ne "") { - $EVTusers = "(".($EVTusers ne "" ? $EVTusers:"").($EVTroper ne "" ? " / $EVTroper":"").")"; - } - my $EVTtitle = "".ucfirst($title).""; - my $EVTdate = "$date $time".($date eq $date2 ? ($time eq $time2 || $time2 eq "" ? "":" → $time2"):" → $date2 $time2"); - #my $EVTver = (defined($ver)) ? " v$ver" : ""; - my $EVToutcome = ($outcome > 0 ? "":""); - my $EVTinfo = ucfirst($feature); - $EVTinfo .= ($channel ne "" ? " • $__{Channel} $channel":""); - $EVTinfo .= ($notebook > 0 ? " • $__{Notebook} # $notebook".($notebookfwd > 0 ? " ($__{forward})":""):""); - - # remaining lines = event text contents - shift(@file); - #DL-beforeMMD my $EVTtext = wiki2html(join("\n",@file)); - my $EVTtext = wiki2html(join("",@file)); - - # event's photos if any - my $direvtphotos = $extevt."/PHOTOS"; - my @photos = qx(/usr/bin/find $direvtphotos -maxdepth 1 -type f 2>/dev/null); - chomp(@photos); - my $EVTphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; - - # event's edit icons - my $EVTedit = ""; - if ($editOK) { - $EVTedit .= "\"$__{'Edit...'}\""; - $EVTedit .= "\"$__{'Remove...'}\""; - $EVTedit .= " \"$__{'Manage"; - $EVTedit .= " \"$__{'Add"; - } - - # indent this event in "events" list - if ($sortedBy =~ /events/i) { - my $thisLevel = ($relevt =~ tr/\///); # count "/"s - if ($thisLevel > $currentIndent) { - for (1..($thisLevel-$currentIndent)) { $html .= "
          \n"; $currentIndent++ } - } elsif ($thisLevel < $currentIndent) { - for (1..($currentIndent-$thisLevel)) { $html .= "
        \n"; $currentIndent-- } - } - } - - # event header - $html .= ""; - $html .= "

      • "; - $html .= "$EVTdate $EVTtitle $EVTusers " if ($sortedBy =~ /date|feature/i); - $html .= "$EVTtitle $EVTdate $EVTusers " if ($sortedBy =~ /events/i); - $html .= "$EVToutcome $EVTedit

        \n"; - # event body - $html .= "

        ".parents($path,$relextevt)."

        \n"; - $html .= "

        $EVTinfo

        \n" if ($EVTinfo ne ""); - $html .= "
        $EVTphotos$EVTtext
        • \n"; - } - $html .= "
      \n"; - return $html; + my ($obj,$date,$time,$ver) = eventnameSplit(basename($extevt)); + + my @file = readFile($evt); + + #DL-beforeMMD # ignore blank lines and LF + #DL-beforeMMD @file = grep(!/^$/, @file); + #DL-beforeMMD chomp(@file); + +# first line = usersList|title with usersList = a + separated list of userIds, and optional |title + if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' + unshift(@file,"|untitled\n"); # force our own default (add a line) + } + my ($author,$remote,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = headersplit($file[0]); + my @authors = @$author; + my @remotes = @$remote; + my $EVTusers = join(", ",WebObs::Users::userName(@authors)); + my $EVTroper = join(", ",WebObs::Users::userName(@remotes)); + if ($EVTusers ne "" || $EVTroper ne "") { + $EVTusers = "(".($EVTusers ne "" ? $EVTusers:"").($EVTroper ne "" ? " / $EVTroper":"").")"; + } + my $EVTtitle = "".ucfirst($title).""; + my $EVTdate = "$date $time".($date eq $date2 ? ($time eq $time2 || $time2 eq "" ? "":" → $time2"):" → $date2 $time2"); + + #my $EVTver = (defined($ver)) ? " v$ver" : ""; + my $EVToutcome = ($outcome > 0 ? "":""); + my $EVTinfo = ucfirst($feature); + $EVTinfo .= ($channel ne "" ? " • $__{Channel} $channel":""); + $EVTinfo .= ($notebook > 0 ? " • $__{Notebook} # $notebook".($notebookfwd > 0 ? " ($__{forward})":""):""); + + # remaining lines = event text contents + shift(@file); + + #DL-beforeMMD my $EVTtext = wiki2html(join("\n",@file)); + my $EVTtext = wiki2html(join("",@file)); + + # event's photos if any + my $direvtphotos = $extevt."/PHOTOS"; + my @photos = qx(/usr/bin/find $direvtphotos -maxdepth 1 -type f 2>/dev/null); + chomp(@photos); + my $EVTphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; + + # event's edit icons + my $EVTedit = ""; + if ($editOK) { + $EVTedit .= "\"$__{'Edit...'}\""; + $EVTedit .= "\"$__{'Remove...'}\""; + $EVTedit .= " \"$__{'Manage"; + $EVTedit .= " \"$__{'Add"; + } + + # indent this event in "events" list + if ($sortedBy =~ /events/i) { + my $thisLevel = ($relevt =~ tr/\///); # count "/"s + if ($thisLevel > $currentIndent) { + for (1..($thisLevel-$currentIndent)) { $html .= "
        \n"; $currentIndent++ } + } elsif ($thisLevel < $currentIndent) { + for (1..($currentIndent-$thisLevel)) { $html .= "
      \n"; $currentIndent-- } + } + } + + # event header + $html .= ""; + $html .= "

    • "; + $html .= "$EVTdate $EVTtitle $EVTusers " if ($sortedBy =~ /date|feature/i); + $html .= "$EVTtitle $EVTdate $EVTusers " if ($sortedBy =~ /events/i); + $html .= "$EVToutcome $EVTedit

      \n"; + + # event body + $html .= "

      ".parents($path,$relextevt)."

      \n"; + $html .= "

      $EVTinfo

      \n" if ($EVTinfo ne ""); + $html .= "
      $EVTphotos$EVTtext
      • \n"; + } + $html .= "
    \n"; + return $html; } # ------------------------------------------------------------------------------------------- @@ -417,53 +426,53 @@ editYN indicates wether current viewing client has authorization to edit Project =cut sub projectShow { - return undef if (@_ != 2); - my ($objectname, $editOK) = @_; - - my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); - return undef if (!defined($GRIDType)); - my $projdir = "$NODEName\_Projet" ; - my $projphotos = "$path/$projdir/PHOTOS" ; - my $projname = "$projdir.txt"; - my $projpath = "$path/$projname"; - - my $html = ''; - if (-e $projpath) { - my $Pts = Time::Piece->strptime((stat($projpath))[9],"%s"); - my @file = readFile($projpath); - chomp(@file); - - # first line = usersList|title with usersList = a + separated list of userIds, and optional |title - if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' - unshift(@file,"|untitled\n"); # force our own default (add a line) - } - my @firstline = split(/\|/,$file[0]); - my @users = split(/\+/,$firstline[0]); - my $Pusers = join(", ",WebObs::Users::userName(@users)); - my $Ptitle = ($#firstline > 0) ? ucfirst($firstline[1]) : "NA" ; - - # remaining lines = event text contents - shift(@file); - my $Ptext = wiki2html(join("\n",@file)); - - # event's photos if any - my @photos = qx(/usr/bin/find $projphotos -maxdepth 1 -type f 2>/dev/null); - chomp(@photos); - my $Pphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; - - my $Pedit = ""; - if ($editOK) { - $Pedit .= "\"$__{'Edit...'}\""; - $Pedit .= "\"$__{'Remove...'}\""; - $Pedit .= "\"$__{'Manage"; - } - my $Pfts = $Pts->strftime("%Y-%m-%d %H:%M"); - $html .= "
    "; - $html .= "

    $Ptitle".($Pusers ne "" ? " ($Pusers)":"")." modified:$Pfts $Pedit

    \n"; - $html .= "
    $Pphotos$Ptext
    "; - $html .= "
    "; - } - return $html; + return undef if (@_ != 2); + my ($objectname, $editOK) = @_; + + my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); + return undef if (!defined($GRIDType)); + my $projdir = "$NODEName\_Projet" ; + my $projphotos = "$path/$projdir/PHOTOS" ; + my $projname = "$projdir.txt"; + my $projpath = "$path/$projname"; + + my $html = ''; + if (-e $projpath) { + my $Pts = Time::Piece->strptime((stat($projpath))[9],"%s"); + my @file = readFile($projpath); + chomp(@file); + +# first line = usersList|title with usersList = a + separated list of userIds, and optional |title + if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' + unshift(@file,"|untitled\n"); # force our own default (add a line) + } + my @firstline = split(/\|/,$file[0]); + my @users = split(/\+/,$firstline[0]); + my $Pusers = join(", ",WebObs::Users::userName(@users)); + my $Ptitle = ($#firstline > 0) ? ucfirst($firstline[1]) : "NA" ; + + # remaining lines = event text contents + shift(@file); + my $Ptext = wiki2html(join("\n",@file)); + + # event's photos if any + my @photos = qx(/usr/bin/find $projphotos -maxdepth 1 -type f 2>/dev/null); + chomp(@photos); + my $Pphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; + + my $Pedit = ""; + if ($editOK) { + $Pedit .= "\"$__{'Edit...'}\""; + $Pedit .= "\"$__{'Remove...'}\""; + $Pedit .= "\"$__{'Manage"; + } + my $Pfts = $Pts->strftime("%Y-%m-%d %H:%M"); + $html .= "
    "; + $html .= "

    $Ptitle".($Pusers ne "" ? " ($Pusers)":"")." modified:$Pfts $Pedit

    \n"; + $html .= "
    $Pphotos$Ptext
    "; + $html .= "
    "; + } + return $html; } # ------------------------------------------------------------------------------------------- @@ -477,20 +486,20 @@ photoStrip(photo-files-list) returns the html string displaying thumbnails =cut sub photoStrip { - my $ret = "
    "; - foreach(@_) { - my ( $name, $path ) = fileparse ( $_ ); - (my $urnpath = $path) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $urnpath =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... - my $thumb = makeThumbnail( "$path/$name", "x$NODES{THUMBNAILS_PIXV}", "$path/THUMBNAILS","$NODES{THUMBNAILS_EXT}"); - if ( $thumb ne "" ) { - (my $turn = $thumb) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $turn =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... - my $olmsg = htmlspecialchars(__x("Click to enlarge
    Image={image}",image=>$name)); - $ret .= "\"".__x('Image$urnpath."/".$name)."\">\n"; - } - } - return $ret."
    "; + my $ret = "
    "; + foreach(@_) { + my ( $name, $path ) = fileparse ( $_ ); + (my $urnpath = $path) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $urnpath =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... + my $thumb = makeThumbnail( "$path/$name", "x$NODES{THUMBNAILS_PIXV}", "$path/THUMBNAILS","$NODES{THUMBNAILS_EXT}"); + if ( $thumb ne "" ) { + (my $turn = $thumb) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $turn =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... + my $olmsg = htmlspecialchars(__x("Click to enlarge
    Image={image}",image=>$name)); + $ret .= "\"".__x('Image$urnpath."/".$name)."\">\n"; + } + } + return $ret."
    "; } # ------------------------------------------------------------------------------------------- @@ -513,26 +522,26 @@ account for grids events as well as nodes events =cut sub parents { - my $html = ""; - if (@_ == 2) { - my ($path, $relextevt) = @_; - my @parents = split(/\//,$relextevt); - for (my $i=$#parents-1; $i>=0; $i--) { - my $f = "$path/".join("/",@parents[0..$i]).".txt"; - my ($s,$d,$h) = split(/_/,$parents[$i]); - $h =~ s/-/:/; - my $t = "???"; - if (-e $f) { - my @xx = readFile($f); - @xx = grep(!/^$/, @xx); - chomp(@xx); - my $o; - ($o,$t) = split(/\|/,$xx[0]); - } - $html .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; - } - } - return $html; + my $html = ""; + if (@_ == 2) { + my ($path, $relextevt) = @_; + my @parents = split(/\//,$relextevt); + for (my $i=$#parents-1; $i>=0; $i--) { + my $f = "$path/".join("/",@parents[0..$i]).".txt"; + my ($s,$d,$h) = split(/_/,$parents[$i]); + $h =~ s/-/:/; + my $t = "???"; + if (-e $f) { + my @xx = readFile($f); + @xx = grep(!/^$/, @xx); + chomp(@xx); + my $o; + ($o,$t) = split(/\|/,$xx[0]); + } + $html .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; + } + } + return $html; } # ------------------------------------------------------------------------------------------- @@ -553,25 +562,26 @@ a deleted event will overwrite a previously deleted one with the same name. =cut sub deleteit { - if (@_ == 3 && $_[2] =~ /.*\.txt$/) { - my ($evbase, $evtrash, $evpath) = @_; - qx(/bin/mkdir -p $evtrash 2>&1); # make sure root trash exists - qx(/bin/mv "$evbase/$evpath" "$evtrash/" 2>&1); - return "$__{'Could not move event to trash'} , $?" if ($? != 0); - $evpath =~ s/\.txt$//; # event extensions dir - my $evname = basename($evpath); # event extensions dir name - if (-e "$evbase/$evpath/") { - qx(mkdir -p "$evtrash/$evname/" 2>&1); - qx(/bin/mv "$evbase/$evpath/" "$evtrash/$evname/" 2>&1); - if ($? != 0) { - # extensions dir move failed, try reverting *txt move - # move $evname.txt -> back to $evbase/.../ - return "$__{'Could not move event extensions to trash'} , $?"; - } - } - return "OK"; - } - return "deleteit: $__{'invalid argument'}"; + if (@_ == 3 && $_[2] =~ /.*\.txt$/) { + my ($evbase, $evtrash, $evpath) = @_; + qx(/bin/mkdir -p $evtrash 2>&1); # make sure root trash exists + qx(/bin/mv "$evbase/$evpath" "$evtrash/" 2>&1); + return "$__{'Could not move event to trash'} , $?" if ($? != 0); + $evpath =~ s/\.txt$//; # event extensions dir + my $evname = basename($evpath); # event extensions dir name + if (-e "$evbase/$evpath/") { + qx(mkdir -p "$evtrash/$evname/" 2>&1); + qx(/bin/mv "$evbase/$evpath/" "$evtrash/$evname/" 2>&1); + if ($? != 0) { + + # extensions dir move failed, try reverting *txt move + # move $evname.txt -> back to $evbase/.../ + return "$__{'Could not move event extensions to trash'} , $?"; + } + } + return "OK"; + } + return "deleteit: $__{'invalid argument'}"; } # ------------------------------------------------------------------------------------------- @@ -591,16 +601,16 @@ eventfile = reference of the event full path name to be 'versioned' if needed. =cut sub versionit { - if (@_ == 1 && ref($_[0])eq "SCALAR") { - my $rf = $_[0]; - if (-e $$rf) { # if eventfile already exists - my ($n,$d,$s) = fileparse($$rf, qr/\.[^.]*/); - my @nx = split(/_/,$n); - my $nx = join('_',@nx[0..2]); - my @lst = qx(ls $d$nx\_*.txt 2>/dev/null); - $$rf = "$d$nx\_".(scalar(@lst)+1).".txt"; - } - } + if (@_ == 1 && ref($_[0])eq "SCALAR") { + my $rf = $_[0]; + if (-e $$rf) { # if eventfile already exists + my ($n,$d,$s) = fileparse($$rf, qr/\.[^.]*/); + my @nx = split(/_/,$n); + my $nx = join('_',@nx[0..2]); + my @lst = qx(ls $d$nx\_*.txt 2>/dev/null); + $$rf = "$d$nx\_".(scalar(@lst)+1).".txt"; + } + } } # ------------------------------------------------------------------------------------------- @@ -609,7 +619,6 @@ sub versionit { # @list = rev( ("a","b","c") ); # @list: ("c","b","a") sub rev { my @r; push @r, pop @_ while @_ ; return @r } - 1; __END__ diff --git a/CODE/perl/lib/Form.pm b/CODE/perl/lib/Form.pm index 3eb74c9e..ce706431 100644 --- a/CODE/perl/lib/Form.pm +++ b/CODE/perl/lib/Form.pm @@ -59,92 +59,92 @@ require Exporter; our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); @ISA = qw(Exporter); @EXPORT = qw(datetime2array datetime2maxmin - extract_formula extract_list extract_type extract_text count_inputs); + extract_formula extract_list extract_type extract_text count_inputs); # FORM constructor sub new { my ( $class, $Name ) = @_; - my $self = {}; + my $self = {}; die "Missing form name" if !defined($Name); - $self->{_name} = $Name; - - $self->{_path} = "$WEBOBS{PATH_FORMS}/$Name"; - die "No configuration found for FORM.$Name" if !(-e $self->{_path}."/$Name.conf"); - $self->{_conf} = { readCfg($self->{_path}."/$Name.conf") }; - $self->{_fnam} = "$WEBOBS{PATH_DATA_DB}/".$self->{_conf}{FILE_NAME}; - - opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); - my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; - for my $proc ( @Ps ) { - my %P = readProc($proc); - $self->{_procs}{$proc} = $P{$proc}{NAME} ; - } + $self->{_name} = $Name; + + $self->{_path} = "$WEBOBS{PATH_FORMS}/$Name"; + die "No configuration found for FORM.$Name" if !(-e $self->{_path}."/$Name.conf"); + $self->{_conf} = { readCfg($self->{_path}."/$Name.conf") }; + $self->{_fnam} = "$WEBOBS{PATH_DATA_DB}/".$self->{_conf}{FILE_NAME}; + + opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); + my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; + for my $proc ( @Ps ) { + my %P = readProc($proc); + $self->{_procs}{$proc} = $P{$proc}{NAME} ; + } closedir(DIR); - - bless $self, $class; + + bless $self, $class; return $self; } # get path to this FORM's configuration files sub path { - my ($self) = @_; - return $self->{_path}; + my ($self) = @_; + return $self->{_path}; } # get configuration parameter sub conf { - my ($self, $k) = @_; - return $self->{_conf}{$k} if (defined($k)); - return %{$self->{_conf}}; + my ($self, $k) = @_; + return $self->{_conf}{$k} if (defined($k)); + return %{$self->{_conf}}; } # get data (all or matching $id) for this FORM using WebObs::xreadFile sub data { - my ($self, $id) = @_; - my $fptr = 0; - my $fts = -1; - if (defined($id)) { - my $fid = qr/^$id\|/; - ($fptr,$fts) = xreadFile($self->{_fnam}, $fid); - } else { - ($fptr,$fts) = xreadFile($self->{_fnam}); - } - return ($fptr, $fts); + my ($self, $id) = @_; + my $fptr = 0; + my $fts = -1; + if (defined($id)) { + my $fid = qr/^$id\|/; + ($fptr,$fts) = xreadFile($self->{_fnam}, $fid); + } else { + ($fptr,$fts) = xreadFile($self->{_fnam}); + } + return ($fptr, $fts); } # get PROC(s) of this FORM as a hash of their 'long' name (NAME) sub procs { my ($self) = @_; - return %{$self->{_procs}}; + return %{$self->{_procs}}; } # get nodes of a PROC of this FORM, returned as a hash of their NAME, ALIAS and FID sub nodes { - my ($self, $proc) = @_; - die "no proc requested" unless defined($proc); - die "$proc not in ".$self->{_name} unless exists($self->{_procs}{$proc}); - my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); - return %L; + my ($self, $proc) = @_; + die "no proc requested" unless defined($proc); + die "$proc not in ".$self->{_name} unless exists($self->{_procs}{$proc}); + my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); + return %L; } # get a dump of this FORM as a string # usage, eg: print $F->dump sub dump { my ($self) = @_; - my $dmp = ''; + my $dmp = ''; $dmp .= sprintf( "Form %s\n", $self->{_name} ); $dmp .= sprintf( "Form configuration path: %s\n", $self->{_path} ); - for my $k ( keys %{ $self->{_conf} } ) { - $dmp .= sprintf( " %s => %s\n",$k, $self->{_conf}{$k}); - } + for my $k ( keys %{ $self->{_conf} } ) { + $dmp .= sprintf( " %s => %s\n",$k, $self->{_conf}{$k}); + } $dmp .= sprintf( "Form data file is: %s\n", $self->{_fnam} ); - $dmp .= "Related proc(s): "; - for ( keys(%{$self->{_procs}}) ) { - $dmp .= sprintf("%s(%s) ", $_, $self->{_procs}{$_}); - } - $dmp .= "\n"; - return $dmp; + $dmp .= "Related proc(s): "; + for ( keys(%{$self->{_procs}}) ) { + $dmp .= sprintf("%s(%s) ", $_, $self->{_procs}{$_}); + } + $dmp .= "\n"; + return $dmp; } 1; @@ -152,86 +152,86 @@ sub dump { # ---- GENFORM sub sub datetime2array { - my $date = shift; - my $date_min = shift; - my @d = split(/[-: ]/,$date); - my @dm = split(/[-: ]/,$date_min); - if ($date eq $date_min || $date_min eq "") { return @d }; - @d = ($d[0], "", "", "","") if ($d[1] ne $dm[1]); - @d = ($d[0],$d[1], "", "","") if ($d[2] ne $dm[2]); - @d = ($d[0],$d[1],$d[2], "","") if ($d[3] ne $dm[3]); - @d = ($d[0],$d[1],$d[2],$d[3],"") if ($d[4] ne $dm[4]); - return @d; + my $date = shift; + my $date_min = shift; + my @d = split(/[-: ]/,$date); + my @dm = split(/[-: ]/,$date_min); + if ($date eq $date_min || $date_min eq "") { return @d }; + @d = ($d[0], "", "", "","") if ($d[1] ne $dm[1]); + @d = ($d[0],$d[1], "", "","") if ($d[2] ne $dm[2]); + @d = ($d[0],$d[1],$d[2], "","") if ($d[3] ne $dm[3]); + @d = ($d[0],$d[1],$d[2],$d[3],"") if ($d[4] ne $dm[4]); + return @d; } sub datetime2maxmin { - my ($y,$m,$d,$hr,$mn) = @_; - my $date_min = "$y-$m-$d $hr:$mn"; - my $date_max = "$y-$m-$d $hr:$mn"; - if ($m eq "") { - $date_min = "$y-01-01"; - $date_max = "$y-12-31"; - } elsif ($d eq "") { - $date_min = qx(date -d "$y-$m-01" "+%Y-%m-%d 00:00"); - chomp($date_min); - $date_max = qx(date -d "$y-$m-01 1 month 1 day ago" "+%Y-%m-%d 23:59"); - chomp($date_max); - } elsif ($hr eq "") { - $date_min = "$y-$m-$d 00:00"; - $date_max = "$y-$m-$d 23:59"; - } elsif ($mn eq "") { - $date_min = "$y-$m-$d $hr:00"; - $date_max = "$y-$m-$d $hr:59"; - } - return ("$date_max","$date_min"); + my ($y,$m,$d,$hr,$mn) = @_; + my $date_min = "$y-$m-$d $hr:$mn"; + my $date_max = "$y-$m-$d $hr:$mn"; + if ($m eq "") { + $date_min = "$y-01-01"; + $date_max = "$y-12-31"; + } elsif ($d eq "") { + $date_min = qx(date -d "$y-$m-01" "+%Y-%m-%d 00:00"); + chomp($date_min); + $date_max = qx(date -d "$y-$m-01 1 month 1 day ago" "+%Y-%m-%d 23:59"); + chomp($date_max); + } elsif ($hr eq "") { + $date_min = "$y-$m-$d 00:00"; + $date_max = "$y-$m-$d 23:59"; + } elsif ($mn eq "") { + $date_min = "$y-$m-$d $hr:00"; + $date_max = "$y-$m-$d $hr:59"; + } + return ("$date_max","$date_min"); } # extract_formula ($type) returns $formula and @x an array of used fields (input or output) sub extract_formula { - my $type = shift; - my @x; - my ($size, $formula) = extract_type($type); - while ($formula =~ /((IN|OUT)PUT[0-9]{2})/g) { - push(@x,$1); - } - return ($formula, $size, @x); + my $type = shift; + my @x; + my ($size, $formula) = extract_type($type); + while ($formula =~ /((IN|OUT)PUT[0-9]{2})/g) { + push(@x,$1); + } + return ($formula, $size, @x); } sub extract_list { - my $list = shift; - my $form = shift; - my $filename = (split /\: /, $list)[1]; - my %list = readCfg("$WEBOBS{PATH_FORMS}/$form/$filename"); + my $list = shift; + my $form = shift; + my $filename = (split /\: /, $list)[1]; + my %list = readCfg("$WEBOBS{PATH_FORMS}/$form/$filename"); - return %list; + return %list; } sub extract_type { - my $type = shift; - my ($size, $default) = (split /:/, $type); - if ($size =~ /\(\d+\)$/) { - $size =~ s/^[a-z]+\((\d+)\)/$1/; - } else { - $size = 5; - } - return ($size, $default); + my $type = shift; + my ($size, $default) = (split /:/, $type); + if ($size =~ /\(\d+\)$/) { + $size =~ s/^[a-z]+\((\d+)\)/$1/; + } else { + $size = 5; + } + return ($size, $default); } sub extract_text { - my $text = shift; - $text =~ s/^text[:]*//; - return (trim($text)); + my $text = shift; + $text =~ s/^text[:]*//; + return (trim($text)); } # count_inputs (@keys) returns max index of INPUTnn fields in array @keys sub count_inputs { - my $count = 0; - foreach(@_) { - if ($_ =~ /INPUT([0-9]{2})_NAME/) { - $count = $1 if ($count < $1); - } - } - return $count; + my $count = 0; + foreach(@_) { + if ($_ =~ /INPUT([0-9]{2})_NAME/) { + $count = $1 if ($count < $1); + } + } + return $count; } __END__ diff --git a/CODE/perl/lib/GML.pm b/CODE/perl/lib/GML.pm index cf9cd466..dcdbec7a 100644 --- a/CODE/perl/lib/GML.pm +++ b/CODE/perl/lib/GML.pm @@ -9,252 +9,255 @@ #--------------------------------------------------------------s use strict; use WebObs::XML2; + #-------------------------------------------------------------- sub gmlarray2nodearray { - # - # Convert **reference** XML/GeodesyML array - # (imported with xml2 buildin fct) - # to - # a "Node Array" i.e. one device change - # OR - # a list of Node Arrays if 'all' is used as index - - ### Inputs - my @GmlArray = @{$_[0]}; # an **reference** GeodesyML array parsed with XML2 Linux bin - my $nodename = $_[1]; # rec, ant, etc.... - my $idx = $_[2]; # node index, we recommend -1 (last one per default) - # OR - # 'all' to get all the nodes - my $root ; - my $root0 ; - - $root0 = '/geo:GeodesyML/geo:siteLog'; - - if ( $nodename eq "rec" ) { - $root = "$root0/geo:gnssReceiver/geo:GnssReceiver"; - } elsif ( $nodename eq "ant" ) { - $root = "$root0/geo:gnssAntenna/geo:GnssAntenna"; - } else { - die ("nodename not defined !!") - } - - ## get all ids for all nodes - my @Ids = findvalues("$root/\@gml:id=",\@GmlArray); - - ## Case 1: we want all nodes (idx == "all") - if ( $idx eq "all" ){ - my @NodesList; - my $id; - foreach $id (@Ids){ - $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed - ## Get the Node we want - my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); - ## stack it - push(@NodesList,[ @Node ]); # [] are very important, to force Node as a list - } - return @NodesList; - - ## Case 2: we want a specific node (idx € int) - } else { - ## find id of the node we want - my $id = @Ids[$idx]; - $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed - ## Get the Node we want - my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); - return @Node; - } + # + # Convert **reference** XML/GeodesyML array + # (imported with xml2 buildin fct) + # to + # a "Node Array" i.e. one device change + # OR + # a list of Node Arrays if 'all' is used as index + + ### Inputs + my @GmlArray = @{$_[0]}; # an **reference** GeodesyML array parsed with XML2 Linux bin + my $nodename = $_[1]; # rec, ant, etc.... + my $idx = $_[2]; # node index, we recommend -1 (last one per default) + + # OR + # 'all' to get all the nodes + my $root ; + my $root0 ; + + $root0 = '/geo:GeodesyML/geo:siteLog'; + + if ( $nodename eq "rec" ) { + $root = "$root0/geo:gnssReceiver/geo:GnssReceiver"; + } elsif ( $nodename eq "ant" ) { + $root = "$root0/geo:gnssAntenna/geo:GnssAntenna"; + } else { + die ("nodename not defined !!") + } + + ## get all ids for all nodes + my @Ids = findvalues("$root/\@gml:id=",\@GmlArray); + + ## Case 1: we want all nodes (idx == "all") + if ( $idx eq "all" ){ + my @NodesList; + my $id; + foreach $id (@Ids){ + $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed + ## Get the Node we want + my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); + ## stack it + push(@NodesList,[ @Node ]); # [] are very important, to force Node as a list + } + return @NodesList; + + ## Case 2: we want a specific node (idx € int) + } else { + ## find id of the node we want + my $id = @Ids[$idx]; + $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed + ## Get the Node we want + my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); + return @Node; + } } sub rec_nodearray2hash { - # - # Convert a **reference** Receiver Node Array - # (created with gmlarray2nodearray) - # to - # a hash (i.e. a dict-like) - # - my @Rec = @{$_[0]}; - my %hashrec; - - $hashrec{model} = findvalue('/geo:igsModelCode=',\@Rec); - $hashrec{satsys} = findvalue('/geo:satelliteSystem=',\@Rec); - $hashrec{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Rec); - $hashrec{vfirm} = findvalue('/geo:firmwareVersion=',\@Rec); - $hashrec{cutoff} = findvalue('/geo:elevationCutoffSetting=',\@Rec); - $hashrec{dinsta} = findvalue('/geo:dateInstalled=',\@Rec); - $hashrec{dremov} = findvalue('/geo:dateRemoved=',\@Rec); - - return %hashrec; + # + # Convert a **reference** Receiver Node Array + # (created with gmlarray2nodearray) + # to + # a hash (i.e. a dict-like) + # + my @Rec = @{$_[0]}; + my %hashrec; + + $hashrec{model} = findvalue('/geo:igsModelCode=',\@Rec); + $hashrec{satsys} = findvalue('/geo:satelliteSystem=',\@Rec); + $hashrec{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Rec); + $hashrec{vfirm} = findvalue('/geo:firmwareVersion=',\@Rec); + $hashrec{cutoff} = findvalue('/geo:elevationCutoffSetting=',\@Rec); + $hashrec{dinsta} = findvalue('/geo:dateInstalled=',\@Rec); + $hashrec{dremov} = findvalue('/geo:dateRemoved=',\@Rec); + + return %hashrec; } sub ant_nodearray2hash { - # - # Convert a **reference** Antenna Node Array - # (created with gmlarray2nodearray) - # to - # a hash (i.e. a dict-like) - # - my @Ant = @{$_[0]}; - my %hashant; - - $hashant{model} = findvalue('/geo:igsModelCode=',\@Ant); - $hashant{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Ant); - $hashant{radome} = findvalue('/geo:antennaRadomeType=',\@Ant); - $hashant{alignN} = findvalue('/geo:alignmentFromTrueNorth=',\@Ant); - $hashant{lcable} = findvalue('/geo:antennaCableLength=',\@Ant); - $hashant{dinsta} = findvalue('/geo:dateInstalled=',\@Ant); - $hashant{dremov} = findvalue('/geo:dateRemoved=',\@Ant); - - return %hashant; + # + # Convert a **reference** Antenna Node Array + # (created with gmlarray2nodearray) + # to + # a hash (i.e. a dict-like) + # + my @Ant = @{$_[0]}; + my %hashant; + + $hashant{model} = findvalue('/geo:igsModelCode=',\@Ant); + $hashant{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Ant); + $hashant{radome} = findvalue('/geo:antennaRadomeType=',\@Ant); + $hashant{alignN} = findvalue('/geo:alignmentFromTrueNorth=',\@Ant); + $hashant{lcable} = findvalue('/geo:antennaCableLength=',\@Ant); + $hashant{dinsta} = findvalue('/geo:dateInstalled=',\@Ant); + $hashant{dremov} = findvalue('/geo:dateRemoved=',\@Ant); + + return %hashant; } sub gmlread_feature { - # - # Wrapper function - # - # Convert a XML/GeodesyML file - # to - # **reference** hashes (rec, ant, misc) - # for the CURRENT instrumentation - # - my $file = $_[0]; - my %hashrec; - my %hashant; - my %hashmisc; - my @Gml; - - if ( not -f $file) - { - die "$file not found" - } - - #### HARDCODED XML2 -# my @Gml = qx($WEBOBS{XML2_PRGM} < $file); - my @Gml = qx(/usr/bin/xml2 < $file); - - ###### Receiver - my @Rec = gmlarray2nodearray(\@Gml,"rec",-1); - %hashrec = rec_nodearray2hash(\@Rec); - - ###### Antenna - my @Ant = gmlarray2nodearray(\@Gml,"ant",-1); - %hashant = ant_nodearray2hash(\@Ant); - - ####### Misc Info - ## common root path - my $rootdomes = '/geo:GeodesyML/geo:siteLog/geo:siteIdentification/geo:iersDOMESNumber'; - $hashmisc{'domes'} = findvalue("$rootdomes",\@Gml); - - ## backslash because we need to output a reference - # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html - return (\%hashrec, \%hashant, \%hashmisc); + # + # Wrapper function + # + # Convert a XML/GeodesyML file + # to + # **reference** hashes (rec, ant, misc) + # for the CURRENT instrumentation + # + my $file = $_[0]; + my %hashrec; + my %hashant; + my %hashmisc; + my @Gml; + + if ( not -f $file) + { + die "$file not found" + } + + #### HARDCODED XML2 + # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); + my @Gml = qx(/usr/bin/xml2 < $file); + + ###### Receiver + my @Rec = gmlarray2nodearray(\@Gml,"rec",-1); + %hashrec = rec_nodearray2hash(\@Rec); + + ###### Antenna + my @Ant = gmlarray2nodearray(\@Gml,"ant",-1); + %hashant = ant_nodearray2hash(\@Ant); + + ####### Misc Info + ## common root path + my $rootdomes = '/geo:GeodesyML/geo:siteLog/geo:siteIdentification/geo:iersDOMESNumber'; + $hashmisc{'domes'} = findvalue("$rootdomes",\@Gml); + + ## backslash because we need to output a reference + # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html + return (\%hashrec, \%hashant, \%hashmisc); } sub gml2mmdfeature { - # - # Wrapper function - # - # Convert a XML/GeodesyML file - # to - # a WebObs markdown feature text for the CURRENT instrumentation - # + # + # Wrapper function + # + # Convert a XML/GeodesyML file + # to + # a WebObs markdown feature text for the CURRENT instrumentation + # my $gmlfile = $_[0]; my $featsection = $_[1]; - - - if ( not -f $gmlfile) - { - die "$gmlfile not found" - } - - ## dollar sign ($) because we need to get references - # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html - my ($hashrec, $hashant, $hashmisc) = gmlread_feature($gmlfile); - - my @outlines ; - - # here we need $hashrec->{'blabla'} and not simply $hashrec{'blabla'} - # because $hashrec is a reference of a hash - # abd not a hash it self - if ( $featsection eq "gnssrec" ) { - push(@outlines,"//Model//: $hashrec->{'model'} \n"); - push(@outlines,"Satellite system: $hashrec->{'satsys'}\n"); - push(@outlines,"Serial number: $hashrec->{'sn'}\n"); - push(@outlines,"Firmware version: $hashrec->{'vfirm'} \n"); - push(@outlines,"Date installed: $hashrec->{'dinsta'}\n"); - push(@outlines,"Date removed: $hashrec->{'dremov'}\n"); - } elsif ( $featsection eq "gnssant" ) { - push(@outlines,"Model: $hashant->{'model'} \n"); - push(@outlines,"Radome: $hashant->{'radome'} \n"); - push(@outlines,"Serial number: $hashant->{'sn'}\n"); - push(@outlines,"Alignment from North: $hashant->{'alignN'} \n"); - push(@outlines,"Cable length (m): $hashant->{'lcable'} \n"); - push(@outlines,"Date installed: $hashant->{'dinsta'}\n"); - push(@outlines,"Date removed: $hashant->{'dremov'}\n"); - } - - return @outlines; - #### !!!! EXCEPTION HERE IF FILE NOT FOUND GMLFILE!!!! - #### !!!! EXCEPTION HERE IF $featsection NOT FOUND !!!! + + if ( not -f $gmlfile) + { + die "$gmlfile not found" + } + + ## dollar sign ($) because we need to get references + # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html + my ($hashrec, $hashant, $hashmisc) = gmlread_feature($gmlfile); + + my @outlines ; + + # here we need $hashrec->{'blabla'} and not simply $hashrec{'blabla'} + # because $hashrec is a reference of a hash + # abd not a hash it self + if ( $featsection eq "gnssrec" ) { + push(@outlines,"//Model//: $hashrec->{'model'} \n"); + push(@outlines,"Satellite system: $hashrec->{'satsys'}\n"); + push(@outlines,"Serial number: $hashrec->{'sn'}\n"); + push(@outlines,"Firmware version: $hashrec->{'vfirm'} \n"); + push(@outlines,"Date installed: $hashrec->{'dinsta'}\n"); + push(@outlines,"Date removed: $hashrec->{'dremov'}\n"); + } elsif ( $featsection eq "gnssant" ) { + push(@outlines,"Model: $hashant->{'model'} \n"); + push(@outlines,"Radome: $hashant->{'radome'} \n"); + push(@outlines,"Serial number: $hashant->{'sn'}\n"); + push(@outlines,"Alignment from North: $hashant->{'alignN'} \n"); + push(@outlines,"Cable length (m): $hashant->{'lcable'} \n"); + push(@outlines,"Date installed: $hashant->{'dinsta'}\n"); + push(@outlines,"Date removed: $hashant->{'dremov'}\n"); + } + + return @outlines; + #### !!!! EXCEPTION HERE IF FILE NOT FOUND GMLFILE!!!! + #### !!!! EXCEPTION HERE IF $featsection NOT FOUND !!!! } sub gml2mmdtable { - # - # Wrapper function - # - # Convert a XML/GeodesyML file - # to - # a WebObs markdown table for the COMPLETE history - # - my $gmlfile = $_[0]; - my $featsection = $_[1]; - - if ( not -f $gmlfile) - { - die "$gmlfile not found" - } - - my @outlines; - ### add the "meta" line, thus the text is considered as MarkDown - push(@outlines,"WebObs: converted with wiki2MMD\n\n"); - - #### HARDCODED XML2 -# my @Gml = qx($WEBOBS{XML2_PRGM} < $file); - my @Gml = qx(/usr/bin/xml2 < $gmlfile); - - ###### Receiver - if ( $featsection eq "gnssrec" ) { - push(@outlines,"| Date installed | Date removed | Model | Satellite system | Serial number | Firmware version |\n"); - push(@outlines,"| ---------------------------------------------------------------------------------------------------------------------|\n"); - #my @RecList = [ gmlarray2nodearray(\@Gml,"rec",-1) ]; - my @RecList = gmlarray2nodearray(\@Gml,"rec","all"); - my $Rec; - foreach $Rec ( @RecList ){ - my %hashrec; - %hashrec = rec_nodearray2hash($Rec); - my $line = sprintf("|%22s|%22s|%18s|%18s|%15s|%18s|",$hashrec{'dinsta'},$hashrec{'dremov'},$hashrec{'model'},$hashrec{'satsys'},$hashrec{'sn'},$hashrec{'vfirm'}); - push(@outlines,$line); - } - } elsif ( $featsection eq "gnssant" ) { - - push(@outlines,"| Date installed | Date removed | Model | Radome | Serial number | N. Align. (°) | Cable len. (m) |\n"); - push(@outlines,"| -------------------------------------------------------------------------------------------------------------------------|\n"); - #my @AntList = [ gmlarray2nodearray(\@Gml,"ant",-1) ]; - my @AntList = gmlarray2nodearray(\@Gml,"ant","all"); - my $Ant; - foreach $Ant ( @AntList ){ - my %hashant; - %hashant = ant_nodearray2hash($Ant); - my $line = sprintf("|%22s|%22s|%18s|%8s|%15s|%16s|%16s|",$hashant{'dinsta'},$hashant{'dremov'},$hashant{'model'},$hashant{'radome'},$hashant{'sn'},$hashant{'alignN'},$hashant{'lcable'}); - push(@outlines,$line); - } - } - - return @outlines; + # + # Wrapper function + # + # Convert a XML/GeodesyML file + # to + # a WebObs markdown table for the COMPLETE history + # + my $gmlfile = $_[0]; + my $featsection = $_[1]; + + if ( not -f $gmlfile) + { + die "$gmlfile not found" + } + + my @outlines; + ### add the "meta" line, thus the text is considered as MarkDown + push(@outlines,"WebObs: converted with wiki2MMD\n\n"); + + #### HARDCODED XML2 + # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); + my @Gml = qx(/usr/bin/xml2 < $gmlfile); + + ###### Receiver + if ( $featsection eq "gnssrec" ) { + push(@outlines,"| Date installed | Date removed | Model | Satellite system | Serial number | Firmware version |\n"); + push(@outlines,"| ---------------------------------------------------------------------------------------------------------------------|\n"); + + #my @RecList = [ gmlarray2nodearray(\@Gml,"rec",-1) ]; + my @RecList = gmlarray2nodearray(\@Gml,"rec","all"); + my $Rec; + foreach $Rec ( @RecList ){ + my %hashrec; + %hashrec = rec_nodearray2hash($Rec); + my $line = sprintf("|%22s|%22s|%18s|%18s|%15s|%18s|",$hashrec{'dinsta'},$hashrec{'dremov'},$hashrec{'model'},$hashrec{'satsys'},$hashrec{'sn'},$hashrec{'vfirm'}); + push(@outlines,$line); + } + } elsif ( $featsection eq "gnssant" ) { + + push(@outlines,"| Date installed | Date removed | Model | Radome | Serial number | N. Align. (°) | Cable len. (m) |\n"); + push(@outlines,"| -------------------------------------------------------------------------------------------------------------------------|\n"); + + #my @AntList = [ gmlarray2nodearray(\@Gml,"ant",-1) ]; + my @AntList = gmlarray2nodearray(\@Gml,"ant","all"); + my $Ant; + foreach $Ant ( @AntList ){ + my %hashant; + %hashant = ant_nodearray2hash($Ant); + my $line = sprintf("|%22s|%22s|%18s|%8s|%15s|%16s|%16s|",$hashant{'dinsta'},$hashant{'dremov'},$hashant{'model'},$hashant{'radome'},$hashant{'sn'},$hashant{'alignN'},$hashant{'lcable'}); + push(@outlines,$line); + } + } + + return @outlines; } sub gml2date { - + } 1; diff --git a/CODE/perl/lib/Gazette.pm b/CODE/perl/lib/Gazette.pm index a2fe0e2e..8dcd8fab 100644 --- a/CODE/perl/lib/Gazette.pm +++ b/CODE/perl/lib/Gazette.pm @@ -31,7 +31,7 @@ use WebObs::Grids; use POSIX qw(ceil); use WebObs::i18n; use Locale::TextDomain('webobs'); - + our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); require Exporter; @@ -44,7 +44,7 @@ our $dbname = $GAZETTE{DB_NAME}; our $dbtable = "gazette"; our %GAZETTECAT = readCfg("$GAZETTE{CATEGORIES_FILE}"); foreach (keys %GAZETTECAT) { - delete $GAZETTECAT{$_} if (!WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") && !WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE")); + delete $GAZETTECAT{$_} if (!WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") && !WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE")); } our $allCATlist = join(',',keys(%GAZETTECAT)); our @editableCat; @@ -55,21 +55,22 @@ our $calweekn = (defined($GAZETTE{CALENDAR_WEEKNUMBER})) ? $GAZETTE{CALENDAR_W our $ongoing = (defined($GAZETTE{SHOW_BYDATE_ONGOING})) ? $GAZETTE{SHOW_BYDATE_ONGOING} : "TEXT"; our $tdtrunc = (defined($GAZETTE{CALENDAR_TRUNCLENGTH})) ? $GAZETTE{CALENDAR_TRUNCLENGTH} : 25; -use constant { - # column indexes for a full DB table row array - G_ID => 0, - G_STARTDATE => 1, - G_STARTTIME => 2, - G_ENDDATE => 3, - G_ENDTIME => 4, - G_CATEGORY => 5, - G_UID => 6, - G_OTHERS => 7, - G_PLACE => 8, - G_SUBJECT => 9, - G_LASTUPD => 10, - G_LASTUPDUID => 11, -}; +use constant { + + # column indexes for a full DB table row array + G_ID => 0, + G_STARTDATE => 1, + G_STARTTIME => 2, + G_ENDDATE => 3, + G_ENDTIME => 4, + G_CATEGORY => 5, + G_UID => 6, + G_OTHERS => 7, + G_PLACE => 8, + G_SUBJECT => 9, + G_LASTUPD => 10, + G_LASTUPDUID => 11, + }; # ------------------------------------------------------------------------------------------- @@ -103,418 +104,435 @@ Arguments: =cut sub Show { - # parse/check arguments - my %KWARGS = @_; - return undef if ( !exists($KWARGS{view}) || !($KWARGS{view} =~ /calendar|datelist|categorylist|ical|dump|stats/i) ); - return undef if ( !exists($KWARGS{from}) ); - my $dtfrom = eval { Time::Piece->strptime($KWARGS{from},'%Y-%m-%d');} or return undef; - my $dtto = $dtfrom; - if ( exists($KWARGS{to}) ) { - $dtto = eval { Time::Piece->strptime($KWARGS{to},'%Y-%m-%d');} or return undef; - if ($KWARGS{view} =~ /calendar/i && $dtfrom == $dtto ) { $KWARGS{view} = "day" } - } - my $filter = (exists($KWARGS{textfilter})) ? $KWARGS{textfilter} : ""; - my $jsedit = (exists($KWARGS{jseditor})) ? $KWARGS{jseditor} : ""; - my $jsevent = (exists($KWARGS{jsevent})) ? $KWARGS{jsevent} : ""; - my @html = (); - # @cat : valid and $CLIENT-readable categories (all or within $KWARGS{categories} subset) - # $incat : @cat suitable for an sql select IN clause - my $categories = (!exists($KWARGS{categories}) || $KWARGS{categories} =~ /^$|all/i) ? $allCATlist : $KWARGS{categories}; - my @cat = grep { exists($GAZETTECAT{$_}) && (WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") || WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE") ) } split(/,/,$categories); - return @html if (@cat == 0) ; - my $incat = join( ',', map { "'$_'" } @cat); - # build holidays for $dtfrom year and $dtto year - my @daysoff = (WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtfrom->year)); - push(@daysoff,WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtto->year)) if ($dtfrom->year != $dtto->year); - my $today = new Time::Piece; - - # ---- Show as weekly calendar ----------------------------------------------------------- - - if ($KWARGS{view} =~ /calendar/i ) { - # make sure $dtfrom and $dtto are week boundaries - $dtfrom = $dtfrom - (($dtfrom->day_of_week+6)%7)*86400; - $dtto = $dtto + ((0-$dtto->day_of_week)%7)*86400; - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - # from 'number of weeks displayed' in requested date frame, derive the preceeding and next date frames - my $wn = ($dtto->epoch - $dtfrom->epoch)/(60*60*24*7); # nb of weeks in requested date frame - # previous date frame is same nunber of weeks before requested frame's start - my $prevdtto = $dtfrom-86400 + ((0-($dtfrom-86400)->day_of_week)%7)*86400; - my $prevdtfrom = $prevdtto-(86400*7*$wn) -((($prevdtto-(86400*7*$wn))->day_of_week+6)%7)*86400; - # next date frame is same number of weeks after requested frame's end - my $nextdtfrom = $dtto+86400 -((($dtto+86400)->day_of_week+6)%7)*86400; - my $nextdtto = $nextdtfrom+(86400*7*$wn) + ((0-($nextdtfrom+(86400*7*$wn))->day_of_week)%7)*86400; - my $prevrange=$prevdtfrom->strftime('%Y-%m-%d').",".$prevdtto->strftime('%Y-%m-%d'); - my $prevw=sprintf("w%02s",$prevdtfrom->week); if ($prevdtto->week ne $prevdtfrom->week) { $prevw .= sprintf(",w%02s",$prevdtto->week) }; - my $nextrange=$nextdtfrom->strftime('%Y-%m-%d').",".$nextdtto->strftime('%Y-%m-%d'); - my $nextw=sprintf("w%02s",$nextdtfrom->week); if ($nextdtto->week ne $nextdtfrom->week) { $nextw .= sprintf(",w%02s",$nextdtto->week) }; - my $prevnextbar = "$prevw"; - $prevnextbar .= "$nextw"; - my $caltr = ""; - push(@html, "
    $prevnextbar
    "); - my $ww; # week first day's Time::Piece object - for ( my $w=$dtfrom, my $cnt=0; $w<=$dtto; $w+=7*86400, $cnt++) { # for each week starting on $w - my $altclass = ($cnt%2 == 0) ? 'even' : 'odd'; - push(@html,"\n\n"); - # identify week (iso notation) - if ($calweekn eq "VERTICAL") { - push(@html,"\n"); - push(@html,""); - $caltr = "\n"; - } else { - push(@html,''); - $caltr = "\n"; - push(@html,$caltr); - } - # 1 row to identify each day of week - for ($ww=$w; $ww<$w+(7*86400); $ww+=86400 ) { - my $dclass=""; my $tst = $ww->strftime('%Y-%m-%d'); - $dclass .= "\"holidays\"" if (grep(/$tst/,@daysoff)); - $dclass .= " today" if ($tst eq $today->strftime('%Y-%m-%d')); - $dclass = "class=$dclass" if($dclass ne ""); - push(@html,""); - } - my @prehtml = ([(undef)x7]); - # now 1 row per article occuring this week and identified by its result-set-array index - my $actualRowsInWeek = 0; - my @ixs = ixApplicable($articles,$w,$w+(6*86400)); # all articles indexes in result set this week - for my $ix (@ixs) { # for each article - my $art = @{$articles}[$ix]; - my $artstart = Time::Piece->strptime($art->[G_STARTDATE],'%Y-%m-%d'); - my $artend = ($art->[G_ENDDATE] eq '') ? Time::Piece->strptime($maxdate,'%Y-%m-%d') : Time::Piece->strptime($art->[G_ENDDATE],'%Y-%m-%d'); - if ($artstart != $artend) { - # article spans n-days ==> 1 row per article & 'long' ") if ($before > 0); - - my $tdtext = calendarTD($w, $art, $artstart, $artend); # td contents - my $bgcolor = "transparent"; # td 'no-category' color just in case - if ( $art->[G_CATEGORY] ne "" ) { - $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; - } - my $tip = articleTip($art); - my $click = ""; - if ($jsedit ne "") { - $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; - } - if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { - $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; - } - my $attr = " colspan='$item' onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word; background-color: $bgcolor' $click "; - push(@html, ""); - - push(@html, "") if ($after > 0); - } else { - # article spans 1-day ==> optimize placement (less rows) for this single "); - } else { - push(@html, ""); - } - } - } - } - if ($calweekn eq "VERTICAL") { - push(@html, "") for (1..3-$actualRowsInWeek); # make week have 3 rows minimum - push(@html,"\n
    ".$w->strftime('%G-w%V')."
    '.$w->strftime('%G-w%V').'
    ".l2u($ww->strftime('%a %d %b'))." - push(@html,$caltr);$actualRowsInWeek++; - my $dur = 1+($artend-$artstart)/86400; - my $before = (($artstart-$w)/86400); if ($before <= 0) { $dur += $before; $before = 0; }; - my $item = ($dur,7-$before)[$dur > 7-$before]; - my $after = 7 - ($before+$item); - - push(@html, "$tdtext. - # @prehtml initially represents an empty week row (ie. 7 spots) populated as required with articles; - # number of rows grows as required (ie. when new articles use already populated spots). - my $i = ($artstart-$w)/86400; - my $done=0; - for my $row (@prehtml) { - if (!defined($row->[$i])) { $row->[$i] = [($w,@{$articles}[$ix],$artstart)]; $done=1; last } - } - if (!$done) { push(@prehtml,[(undef)x7]); $prehtml[-1]->[$i]= [($w,@{$articles}[$ix],$artstart)] } - } - } - # format the @prehtml rows , adding them to calendar - for my $row (@prehtml) { - push(@html,$caltr);$actualRowsInWeek++; - for my $d ($row) { - for my $i (0..6) { - if (defined($d->[$i])) { - my ($w, $art, $artstart) = @{$d->[$i]}; - my $tdtext = calendarTD($w, $art, $artstart, $artstart); - my $bgcolor = "transparent"; - if ( $art->[G_CATEGORY] ne "" ) { - $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; - } - my $tip = articleTip($art); - my $click = ""; - if ($jsedit ne "") { - $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; - } - if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { - $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; - } - my $attr = " onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word;background-color: $bgcolor' $click "; - push(@html, "$tdtext
    \n"); - } else { - push(@html,"\n\n"); - } - } - push(@html, "
    $prevnextbar
    "); - return @html; - } - - # ---- Show one day, calendar like ------------------------------------------------------- - - if ($KWARGS{view} =~ /day/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtfrom->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - my $prevday=($dtfrom-86400)->strftime('%Y-%m-%d'); - my $nextday=($dtfrom+86400)->strftime('%Y-%m-%d'); - my $prevnextbar = "$prevday"; - $prevnextbar .= "$nextday"; - push(@html, "
    $prevnextbar
    "); - push(@html,""); - push(@html,''); - # now 1 row per article - for my $art (@{$articles}) { - push(@html,''); - - my $tdtext = ""; - $tdtext .= articleTimes($art,$art->[G_STARTDATE]); - $tdtext .= $art->[G_SUBJECT]." "; - $tdtext .= articleWho($art)." "; - my $bgcolor = "transparent"; # td 'no-category' color just in case - if ( $art->[G_CATEGORY] ne "" ) { - $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; - } - # TODO: mouseover - my $tip = articleTip($art); - my $click = ""; - if ($jsedit ne "") { - $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; - } - if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { - $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; - } - my $attr = " onMouseOver='showtip(event,\"$art->[G_CATEGORY]\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='background-color: $bgcolor' $click "; - push(@html, ""); - } - push(@html,'
    '.l2u($dtfrom->strftime("$__{'gzt_fmt_long_date'}")).'
    $tdtext
    '); - - return @html; - } - # ---- Show by date -------------------------------------------------------- - - if ($KWARGS{view} =~ /datelist/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - for ( my $d=$dtfrom, my $cnt=0; $d<=$dtto; $d+=86400, $cnt++) { # for each day starting on $d - my $ymd = $d->strftime('%Y-%m-%d'); - my $dayhtml = ""; - my @ixs = ixApplicable($articles,$d); # all articles indexes in result set, this day - for my $ix (@ixs) { # for each article - my $li = ""; - # find wether article starts or ends on currently processed day - if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] || $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { - if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] && $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { - $li .= '
  • '.articleTimes(@{$articles}[$ix],$ymd)." "; - } else { - if ($ymd eq @{$articles}[$ix]->[G_STARTDATE]) { - my $until = @{$articles}[$ix]->[G_ENDDATE] eq '' ? "$__{'from now on'}" : "$__{until} @{$articles}[$ix]->[G_ENDDATE]"; - $li .= '
  • '."$until "; - } elsif ($ymd eq @{$articles}[$ix]->[G_ENDDATE]) { - $li .= '
  • '."$__{since} @{$articles}[$ix]->[G_STARTDATE] "; - } - } - } else { - # not starting nor ending this day => report depending on SHOW_BYDATE_ONGOING variable - if ($ongoing !~ /NO/i) { - $li .= '
  • '; - $li .= "$__{'on going'} " if ($ongoing =~ /TEXT/i); - $li .= "$__{'since'} @{$articles}[$ix]->[G_STARTDATE] $__{until} @{$articles}[$ix]->[G_ENDDATE] " if ($ongoing =~ /DATE/i); - } else { next; } - } - my $rqcat = @{$articles}[$ix]->[G_CATEGORY]; - $li .= "$GAZETTECAT{$rqcat}{Name} "; - $li .= "@{$articles}[$ix]->[G_PLACE] "; - $li .= "- @{$articles}[$ix]->[G_SUBJECT] "; - $li .= "- ".articleWho(@{$articles}[$ix])." " ; - if ($jsedit ne "") { - $li .= (grep { /@{$articles}[$ix]->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; - } - $li .= "
    • "; - $dayhtml .= $li; - } - if ($dayhtml ne "") { # found things to display for this day - push(@html, "

    ".l2u($d->strftime("$__{gzt_fmt_date}"))."

    "."
      $dayhtml
    "); - } - - } - return @html; - } - - # ---- Show by category ------------------------------------------------ - - if ($KWARGS{view} =~ /categorylist/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'category,startdate,starttime'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - my $currentCat = ""; - for my $art (@{$articles}) { # for each article (ordered by category) - if ($art->[G_CATEGORY] ne $currentCat) { - push(@html,"") if ($currentCat ne ""); - $currentCat = $art->[G_CATEGORY]; - push(@html, "

    $GAZETTECAT{$currentCat}{Name}

      "); - } - my $htmlDate = ""; - if ($art->[G_STARTDATE] eq $art->[G_ENDDATE]) { - if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= $art->[G_STARTDATE]; } - elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME])" } - elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] (⇒ $art->[G_ENDTIME])"} - else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME] ⇒ $art->[G_ENDTIME])" } - } else { - if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE]" } - elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) " } - elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE] ($art->[G_ENDTIME])"} - else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) - $art->[G_ENDDATE] ($art->[G_ENDTIME])" } - } - - #articleWho() returns : [user1, user2] + others - my $allNames = articleWho($art); - my ($htmlNames,$htmlOthers) = split(/ \+ /,$allNames); - - my $htmlLi = ""; - if ($GAZETTECAT{$currentCat}{Format} eq "ndol") { - $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "ndlo") { - $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_PLACE] - $art->[G_SUBJECT]"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "ldon") { - $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "dlon") { - $htmlLi .= "$htmlDate - $art->[G_PLACE] - $art->[G_SUBJECT] - $htmlNames"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "andol") { - $htmlLi .= "$htmlOthers".($htmlNames ne "" ? ($htmlOthers ne "" ? ", ":"")."$htmlNames":"")." - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "adon") { - $htmlLi .= "$htmlOthers - [$htmlDate] - $art->[G_SUBJECT] - [$htmlNames]"; - } else { - $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; - } - my $editicon = ""; - if ($jsedit ne "") { - $editicon = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; - } - push(@html, "
    • $htmlLi $editicon
      • \n"); - } - push(@html, "
    ") if (@html); - return @html; - } - - # ---- Show raw selection for admins only------------------------------------------------ - - if ($KWARGS{view} =~ /dump/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { - my $articles; - if ($KWARGS{categories} =~ /^$|all/i) { # for dump, 'all' really means 'any' (known or unknown) categories - $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), order=> 'startdate,starttime,category'); - } else { - $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - } - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - push(@html,""); - for my $art (@{$articles}) { # each article - push(@html, "\n"); - } - push(@html, "
    IDSTARTDATESTARTTIMEENDDATEENDTIMECATEGORYUIDOTHERSPLACESUBJECTUpdatedUpdID
    ".join('', map { "$art->[$_]" } (0..11))."
    "); - return @html; - } - - # ---- Show statistics for admins only------------------------------------------------ - - if ($KWARGS{view} =~ /stats/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { - my ($dbh, $sql, $sth, $art); - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - push(@html,"

    Figures below apply to full Gazette (ie. selection criteria do NOT apply)

    "); - - $sql = "select count(*) from $dbtable"; - $sth = $dbh->prepare($sql); - $sth->execute(); - my $rsCountRows = $sth->fetchall_arrayref(); - push(@html,""); - for $art (@{$rsCountRows}) { - push(@html, "\n"); - } - push(@html, "
    Total number of articles
    $art->[0]
    "); - push(@html, "
    "); - - $sql = "select category, count(*) from $dbtable where category in (select distinct(category)) group by category order by category"; - $sth = $dbh->prepare($sql); - $sth->execute(); - my $rsCountCategories = $sth->fetchall_arrayref(); - push(@html,""); - for $art (@{$rsCountCategories}) { - my $catdef = "undefined"; - $catdef = "defined" if (exists($GAZETTECAT{$art->[0]})); - push(@html, "\n"); - } - push(@html, "
    Categoryin CATEGORIES_FILENumber of articles
    $art->[0]$catdef$art->[1]
    "); - - $dbh->disconnect; - return @html; - } - - # ---- Show as iCal --------------------------------------------------------------------- - - if ($KWARGS{view} =~ /ical/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - push(@html,"BEGIN:VCALENDAR\n"); - push(@html,"PRODID:-//webobs.ipgp.fr/gazette//EN\n"); - push(@html,"VERSION:2.0\n"); - for my $art (@{$articles}) { # each article - # if "startdate starttime" can't parse : ignore article - # if "enddate endtime" can't parse : behave like no enddate specified - my $ds = eval { Time::Piece->strptime($art->[G_STARTDATE]." ".$art->[G_STARTTIME],'%Y-%m-%d %H:%M') } or next; - my $de = eval { Time::Piece->strptime($art->[G_ENDDATE]." ".$art->[G_ENDTIME],'%Y-%m-%d %H:%M') } or $art->[G_ENDDATE] = ""; - push(@html, "BEGIN:VEVENT\n"); - push(@html, "SUMMARY:$art->[G_SUBJECT]\n"); - push(@html, "DTSTART:".$ds->datetime."\n"); - if ($art->[G_ENDDATE] eq '') { - push(@html, "RRULE:FREQ=DAILY\n"); - } else { - push(@html, "DTEND:".$de->datetime."\n"); - } - push(@html, "LOCATION:$art->[G_PLACE]\n"); - push(@html, "CATEGORIES:$art->[G_CATEGORY]\n"); - my $id = $art->[G_UID]; $id =~ s/\+.*//; # take first id only - push(@html, "UID:$USERS{$USERIDS{$id}}{EMAIL}\n"); - push(@html, "END:VEVENT\n"); - } - push(@html, "END:VCALENDAR"); - - my $icsfn = "Gazette_".$WebObs::Users::CLIENT."_".$dtfrom->strftime('%Y-%m-%d')."_".$dtto->strftime('%Y-%m-%d').".ics"; - my $icsrc = ""; - if (open(WRT,">$WEBOBS{PATH_TMP_APACHE}/$icsfn")) { - print WRT @html; - close(WRT); - $icsrc = "$__{'saved as'} $icsfn"; - } else { $icsrc = "$__{'not saved'}" } - - #unshift(@html, "

    $icsrc

    "); - unshift(@html, "Download
    \n"); - - s/\n/
    / for @html; - return @html; - } + # parse/check arguments + my %KWARGS = @_; + return undef if ( !exists($KWARGS{view}) || !($KWARGS{view} =~ /calendar|datelist|categorylist|ical|dump|stats/i) ); + return undef if ( !exists($KWARGS{from}) ); + my $dtfrom = eval { Time::Piece->strptime($KWARGS{from},'%Y-%m-%d');} or return undef; + my $dtto = $dtfrom; + if ( exists($KWARGS{to}) ) { + $dtto = eval { Time::Piece->strptime($KWARGS{to},'%Y-%m-%d');} or return undef; + if ($KWARGS{view} =~ /calendar/i && $dtfrom == $dtto ) { $KWARGS{view} = "day" } + } + my $filter = (exists($KWARGS{textfilter})) ? $KWARGS{textfilter} : ""; + my $jsedit = (exists($KWARGS{jseditor})) ? $KWARGS{jseditor} : ""; + my $jsevent = (exists($KWARGS{jsevent})) ? $KWARGS{jsevent} : ""; + my @html = (); + +# @cat : valid and $CLIENT-readable categories (all or within $KWARGS{categories} subset) +# $incat : @cat suitable for an sql select IN clause + my $categories = (!exists($KWARGS{categories}) || $KWARGS{categories} =~ /^$|all/i) ? $allCATlist : $KWARGS{categories}; + my @cat = grep { exists($GAZETTECAT{$_}) && (WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") || WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE") ) } split(/,/,$categories); + return @html if (@cat == 0) ; + my $incat = join( ',', map { "'$_'" } @cat); + + # build holidays for $dtfrom year and $dtto year + my @daysoff = (WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtfrom->year)); + push(@daysoff,WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtto->year)) if ($dtfrom->year != $dtto->year); + my $today = new Time::Piece; + +# ---- Show as weekly calendar ----------------------------------------------------------- + + if ($KWARGS{view} =~ /calendar/i ) { + + # make sure $dtfrom and $dtto are week boundaries + $dtfrom = $dtfrom - (($dtfrom->day_of_week+6)%7)*86400; + $dtto = $dtto + ((0-$dtto->day_of_week)%7)*86400; + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + +# from 'number of weeks displayed' in requested date frame, derive the preceeding and next date frames + my $wn = ($dtto->epoch - $dtfrom->epoch)/(60*60*24*7); # nb of weeks in requested date frame + + # previous date frame is same nunber of weeks before requested frame's start + my $prevdtto = $dtfrom-86400 + ((0-($dtfrom-86400)->day_of_week)%7)*86400; + my $prevdtfrom = $prevdtto-(86400*7*$wn) -((($prevdtto-(86400*7*$wn))->day_of_week+6)%7)*86400; + + # next date frame is same number of weeks after requested frame's end + my $nextdtfrom = $dtto+86400 -((($dtto+86400)->day_of_week+6)%7)*86400; + my $nextdtto = $nextdtfrom+(86400*7*$wn) + ((0-($nextdtfrom+(86400*7*$wn))->day_of_week)%7)*86400; + my $prevrange=$prevdtfrom->strftime('%Y-%m-%d').",".$prevdtto->strftime('%Y-%m-%d'); + my $prevw=sprintf("w%02s",$prevdtfrom->week); if ($prevdtto->week ne $prevdtfrom->week) { $prevw .= sprintf(",w%02s",$prevdtto->week) }; + my $nextrange=$nextdtfrom->strftime('%Y-%m-%d').",".$nextdtto->strftime('%Y-%m-%d'); + my $nextw=sprintf("w%02s",$nextdtfrom->week); if ($nextdtto->week ne $nextdtfrom->week) { $nextw .= sprintf(",w%02s",$nextdtto->week) }; + my $prevnextbar = "$prevw"; + $prevnextbar .= "$nextw"; + my $caltr = ""; + push(@html, "
    $prevnextbar
    "); + my $ww; # week first day's Time::Piece object + for ( my $w=$dtfrom, my $cnt=0; $w<=$dtto; $w+=7*86400, $cnt++) { # for each week starting on $w + my $altclass = ($cnt%2 == 0) ? 'even' : 'odd'; + push(@html,"\n\n"); + + # identify week (iso notation) + if ($calweekn eq "VERTICAL") { + push(@html,"\n"); + push(@html,""); + $caltr = "\n"; + } else { + push(@html,''); + $caltr = "\n"; + push(@html,$caltr); + } + + # 1 row to identify each day of week + for ($ww=$w; $ww<$w+(7*86400); $ww+=86400 ) { + my $dclass=""; my $tst = $ww->strftime('%Y-%m-%d'); + $dclass .= "\"holidays\"" if (grep(/$tst/,@daysoff)); + $dclass .= " today" if ($tst eq $today->strftime('%Y-%m-%d')); + $dclass = "class=$dclass" if($dclass ne ""); + push(@html,""); + } + my @prehtml = ([(undef)x7]); + +# now 1 row per article occuring this week and identified by its result-set-array index + my $actualRowsInWeek = 0; + my @ixs = ixApplicable($articles,$w,$w+(6*86400)); # all articles indexes in result set this week + for my $ix (@ixs) { # for each article + my $art = @{$articles}[$ix]; + my $artstart = Time::Piece->strptime($art->[G_STARTDATE],'%Y-%m-%d'); + my $artend = ($art->[G_ENDDATE] eq '') ? Time::Piece->strptime($maxdate,'%Y-%m-%d') : Time::Piece->strptime($art->[G_ENDDATE],'%Y-%m-%d'); + if ($artstart != $artend) { + + # article spans n-days ==> 1 row per article & 'long' ") if ($before > 0); + + my $tdtext = calendarTD($w, $art, $artstart, $artend); # td contents + my $bgcolor = "transparent"; # td 'no-category' color just in case + if ( $art->[G_CATEGORY] ne "" ) { + $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; + } + my $tip = articleTip($art); + my $click = ""; + if ($jsedit ne "") { + $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; + } + if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { + $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; + } + my $attr = " colspan='$item' onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word; background-color: $bgcolor' $click "; + push(@html, ""); + + push(@html, "") if ($after > 0); + } else { + +# article spans 1-day ==> optimize placement (less rows) for this single "); + } else { + push(@html, ""); + } + } + } + } + if ($calweekn eq "VERTICAL") { + push(@html, "") for (1..3-$actualRowsInWeek); # make week have 3 rows minimum + push(@html,"\n
    ".$w->strftime('%G-w%V')."
    '.$w->strftime('%G-w%V').'
    ".l2u($ww->strftime('%a %d %b'))." + push(@html,$caltr);$actualRowsInWeek++; + my $dur = 1+($artend-$artstart)/86400; + my $before = (($artstart-$w)/86400); if ($before <= 0) { $dur += $before; $before = 0; }; + my $item = ($dur,7-$before)[$dur > 7-$before]; + my $after = 7 - ($before+$item); + + push(@html, "$tdtext. +# @prehtml initially represents an empty week row (ie. 7 spots) populated as required with articles; +# number of rows grows as required (ie. when new articles use already populated spots). + my $i = ($artstart-$w)/86400; + my $done=0; + for my $row (@prehtml) { + if (!defined($row->[$i])) { $row->[$i] = [($w,@{$articles}[$ix],$artstart)]; $done=1; last } + } + if (!$done) { push(@prehtml,[(undef)x7]); $prehtml[-1]->[$i]= [($w,@{$articles}[$ix],$artstart)] } + } + } + + # format the @prehtml rows , adding them to calendar + for my $row (@prehtml) { + push(@html,$caltr);$actualRowsInWeek++; + for my $d ($row) { + for my $i (0..6) { + if (defined($d->[$i])) { + my ($w, $art, $artstart) = @{$d->[$i]}; + my $tdtext = calendarTD($w, $art, $artstart, $artstart); + my $bgcolor = "transparent"; + if ( $art->[G_CATEGORY] ne "" ) { + $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; + } + my $tip = articleTip($art); + my $click = ""; + if ($jsedit ne "") { + $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; + } + if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { + $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; + } + my $attr = " onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word;background-color: $bgcolor' $click "; + push(@html, "$tdtext
    \n"); + } else { + push(@html,"\n\n"); + } + } + push(@html, "
    $prevnextbar
    "); + return @html; + } + +# ---- Show one day, calendar like ------------------------------------------------------- + + if ($KWARGS{view} =~ /day/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtfrom->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + my $prevday=($dtfrom-86400)->strftime('%Y-%m-%d'); + my $nextday=($dtfrom+86400)->strftime('%Y-%m-%d'); + my $prevnextbar = "$prevday"; + $prevnextbar .= "$nextday"; + push(@html, "
    $prevnextbar
    "); + push(@html,""); + push(@html,''); + + # now 1 row per article + for my $art (@{$articles}) { + push(@html,''); + + my $tdtext = ""; + $tdtext .= articleTimes($art,$art->[G_STARTDATE]); + $tdtext .= $art->[G_SUBJECT]." "; + $tdtext .= articleWho($art)." "; + my $bgcolor = "transparent"; # td 'no-category' color just in case + if ( $art->[G_CATEGORY] ne "" ) { + $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; + } + + # TODO: mouseover + my $tip = articleTip($art); + my $click = ""; + if ($jsedit ne "") { + $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; + } + if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { + $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; + } + my $attr = " onMouseOver='showtip(event,\"$art->[G_CATEGORY]\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='background-color: $bgcolor' $click "; + push(@html, ""); + } + push(@html,'
    '.l2u($dtfrom->strftime("$__{'gzt_fmt_long_date'}")).'
    $tdtext
    '); + + return @html; + } + + # ---- Show by date -------------------------------------------------------- + + if ($KWARGS{view} =~ /datelist/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + for ( my $d=$dtfrom, my $cnt=0; $d<=$dtto; $d+=86400, $cnt++) { # for each day starting on $d + my $ymd = $d->strftime('%Y-%m-%d'); + my $dayhtml = ""; + my @ixs = ixApplicable($articles,$d); # all articles indexes in result set, this day + for my $ix (@ixs) { # for each article + my $li = ""; + + # find wether article starts or ends on currently processed day + if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] || $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { + if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] && $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { + $li .= '
  • '.articleTimes(@{$articles}[$ix],$ymd)." "; + } else { + if ($ymd eq @{$articles}[$ix]->[G_STARTDATE]) { + my $until = @{$articles}[$ix]->[G_ENDDATE] eq '' ? "$__{'from now on'}" : "$__{until} @{$articles}[$ix]->[G_ENDDATE]"; + $li .= '
  • '."$until "; + } elsif ($ymd eq @{$articles}[$ix]->[G_ENDDATE]) { + $li .= '
  • '."$__{since} @{$articles}[$ix]->[G_STARTDATE] "; + } + } + } else { + +# not starting nor ending this day => report depending on SHOW_BYDATE_ONGOING variable + if ($ongoing !~ /NO/i) { + $li .= '
  • '; + $li .= "$__{'on going'} " if ($ongoing =~ /TEXT/i); + $li .= "$__{'since'} @{$articles}[$ix]->[G_STARTDATE] $__{until} @{$articles}[$ix]->[G_ENDDATE] " if ($ongoing =~ /DATE/i); + } else { next; } + } + my $rqcat = @{$articles}[$ix]->[G_CATEGORY]; + $li .= "$GAZETTECAT{$rqcat}{Name} "; + $li .= "@{$articles}[$ix]->[G_PLACE] "; + $li .= "- @{$articles}[$ix]->[G_SUBJECT] "; + $li .= "- ".articleWho(@{$articles}[$ix])." " ; + if ($jsedit ne "") { + $li .= (grep { /@{$articles}[$ix]->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; + } + $li .= "
    • "; + $dayhtml .= $li; + } + if ($dayhtml ne "") { # found things to display for this day + push(@html, "

    ".l2u($d->strftime("$__{gzt_fmt_date}"))."

    "."
      $dayhtml
    "); + } + + } + return @html; + } + + # ---- Show by category ------------------------------------------------ + + if ($KWARGS{view} =~ /categorylist/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'category,startdate,starttime'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + my $currentCat = ""; + for my $art (@{$articles}) { # for each article (ordered by category) + if ($art->[G_CATEGORY] ne $currentCat) { + push(@html,"") if ($currentCat ne ""); + $currentCat = $art->[G_CATEGORY]; + push(@html, "

    $GAZETTECAT{$currentCat}{Name}

      "); + } + my $htmlDate = ""; + if ($art->[G_STARTDATE] eq $art->[G_ENDDATE]) { + if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= $art->[G_STARTDATE]; } + elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME])" } + elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] (⇒ $art->[G_ENDTIME])"} + else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME] ⇒ $art->[G_ENDTIME])" } + } else { + if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE]" } + elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) " } + elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE] ($art->[G_ENDTIME])"} + else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) - $art->[G_ENDDATE] ($art->[G_ENDTIME])" } + } + + #articleWho() returns : [user1, user2] + others + my $allNames = articleWho($art); + my ($htmlNames,$htmlOthers) = split(/ \+ /,$allNames); + + my $htmlLi = ""; + if ($GAZETTECAT{$currentCat}{Format} eq "ndol") { + $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "ndlo") { + $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_PLACE] - $art->[G_SUBJECT]"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "ldon") { + $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "dlon") { + $htmlLi .= "$htmlDate - $art->[G_PLACE] - $art->[G_SUBJECT] - $htmlNames"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "andol") { + $htmlLi .= "$htmlOthers".($htmlNames ne "" ? ($htmlOthers ne "" ? ", ":"")."$htmlNames":"")." - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "adon") { + $htmlLi .= "$htmlOthers - [$htmlDate] - $art->[G_SUBJECT] - [$htmlNames]"; + } else { + $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; + } + my $editicon = ""; + if ($jsedit ne "") { + $editicon = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; + } + push(@html, "
    • $htmlLi $editicon
      • \n"); + } + push(@html, "
    ") if (@html); + return @html; + } + +# ---- Show raw selection for admins only------------------------------------------------ + + if ($KWARGS{view} =~ /dump/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { + my $articles; + if ($KWARGS{categories} =~ /^$|all/i) { # for dump, 'all' really means 'any' (known or unknown) categories + $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), order=> 'startdate,starttime,category'); + } else { + $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + } + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + push(@html,""); + for my $art (@{$articles}) { # each article + push(@html, "\n"); + } + push(@html, "
    IDSTARTDATESTARTTIMEENDDATEENDTIMECATEGORYUIDOTHERSPLACESUBJECTUpdatedUpdID
    ".join('', map { "$art->[$_]" } (0..11))."
    "); + return @html; + } + +# ---- Show statistics for admins only------------------------------------------------ + + if ($KWARGS{view} =~ /stats/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { + my ($dbh, $sql, $sth, $art); + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + push(@html,"

    Figures below apply to full Gazette (ie. selection criteria do NOT apply)

    "); + + $sql = "select count(*) from $dbtable"; + $sth = $dbh->prepare($sql); + $sth->execute(); + my $rsCountRows = $sth->fetchall_arrayref(); + push(@html,""); + for $art (@{$rsCountRows}) { + push(@html, "\n"); + } + push(@html, "
    Total number of articles
    $art->[0]
    "); + push(@html, "
    "); + + $sql = "select category, count(*) from $dbtable where category in (select distinct(category)) group by category order by category"; + $sth = $dbh->prepare($sql); + $sth->execute(); + my $rsCountCategories = $sth->fetchall_arrayref(); + push(@html,""); + for $art (@{$rsCountCategories}) { + my $catdef = "undefined"; + $catdef = "defined" if (exists($GAZETTECAT{$art->[0]})); + push(@html, "\n"); + } + push(@html, "
    Categoryin CATEGORIES_FILENumber of articles
    $art->[0]$catdef$art->[1]
    "); + + $dbh->disconnect; + return @html; + } + +# ---- Show as iCal --------------------------------------------------------------------- + + if ($KWARGS{view} =~ /ical/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + push(@html,"BEGIN:VCALENDAR\n"); + push(@html,"PRODID:-//webobs.ipgp.fr/gazette//EN\n"); + push(@html,"VERSION:2.0\n"); + for my $art (@{$articles}) { # each article + + # if "startdate starttime" can't parse : ignore article + # if "enddate endtime" can't parse : behave like no enddate specified + my $ds = eval { Time::Piece->strptime($art->[G_STARTDATE]." ".$art->[G_STARTTIME],'%Y-%m-%d %H:%M') } or next; + my $de = eval { Time::Piece->strptime($art->[G_ENDDATE]." ".$art->[G_ENDTIME],'%Y-%m-%d %H:%M') } or $art->[G_ENDDATE] = ""; + push(@html, "BEGIN:VEVENT\n"); + push(@html, "SUMMARY:$art->[G_SUBJECT]\n"); + push(@html, "DTSTART:".$ds->datetime."\n"); + if ($art->[G_ENDDATE] eq '') { + push(@html, "RRULE:FREQ=DAILY\n"); + } else { + push(@html, "DTEND:".$de->datetime."\n"); + } + push(@html, "LOCATION:$art->[G_PLACE]\n"); + push(@html, "CATEGORIES:$art->[G_CATEGORY]\n"); + my $id = $art->[G_UID]; $id =~ s/\+.*//; # take first id only + push(@html, "UID:$USERS{$USERIDS{$id}}{EMAIL}\n"); + push(@html, "END:VEVENT\n"); + } + push(@html, "END:VCALENDAR"); + + my $icsfn = "Gazette_".$WebObs::Users::CLIENT."_".$dtfrom->strftime('%Y-%m-%d')."_".$dtto->strftime('%Y-%m-%d').".ics"; + my $icsrc = ""; + if (open(WRT,">$WEBOBS{PATH_TMP_APACHE}/$icsfn")) { + print WRT @html; + close(WRT); + $icsrc = "$__{'saved as'} $icsfn"; + } else { $icsrc = "$__{'not saved'}" } + + #unshift(@html, "

    $icsrc

    "); + unshift(@html, "Download
    \n"); + + s/\n/
    / for @html; + return @html; + } } # ------------------------------------------------------------------------------------------- @@ -547,24 +565,24 @@ Example: =cut sub getRaw { - my %KWARGS = @_; - return 0 if ( !exists($KWARGS{from}) || !exists($KWARGS{to}) ); - my ($rs, $dbh, $sql, $sth); - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT,LASTUPD,LASTUPDUID "; - $sql .= "FROM $dbtable " ; - $sql .= "WHERE STARTDATE <= '".$KWARGS{to}."' AND (ENDDATE = '' OR ENDDATE >= '".$KWARGS{from}."') "; - $sql .= "AND CATEGORY IN (".$KWARGS{categories}.")" if (exists($KWARGS{categories}) && $KWARGS{categories} ne ''); - $sql .= " ORDER BY $KWARGS{order}" if exists($KWARGS{order}); - $sth = $dbh->prepare($sql); - $sth->execute(); - $rs = $sth->fetchall_arrayref(); - $dbh->disconnect; - return $rs; + my %KWARGS = @_; + return 0 if ( !exists($KWARGS{from}) || !exists($KWARGS{to}) ); + my ($rs, $dbh, $sql, $sth); + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT,LASTUPD,LASTUPDUID "; + $sql .= "FROM $dbtable " ; + $sql .= "WHERE STARTDATE <= '".$KWARGS{to}."' AND (ENDDATE = '' OR ENDDATE >= '".$KWARGS{from}."') "; + $sql .= "AND CATEGORY IN (".$KWARGS{categories}.")" if (exists($KWARGS{categories}) && $KWARGS{categories} ne ''); + $sql .= " ORDER BY $KWARGS{order}" if exists($KWARGS{order}); + $sth = $dbh->prepare($sql); + $sth->execute(); + $rs = $sth->fetchall_arrayref(); + $dbh->disconnect; + return $rs; } # ------------------------------------------------------------------------------------------- @@ -579,18 +597,18 @@ as a string suitable for an SQL insert 'values' clause. =cut sub setArticle { - return 0 if (@_ != 1); - my ($dbh, $sql, $rv); - - my $values = "$_[0],datetime('now'),'$USERS{$CLIENT}{UID}'"; - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; - $sql = "INSERT OR REPLACE INTO $dbtable VALUES( $values )"; - $rv = $dbh->do($sql); - $rv = 0 if ($rv == 0E0); - $rv = sprintf("%d row%s %s",$rv,($rv<=1)?"":"s",$DBI::errstr); - - $dbh->disconnect; - return $rv; + return 0 if (@_ != 1); + my ($dbh, $sql, $rv); + + my $values = "$_[0],datetime('now'),'$USERS{$CLIENT}{UID}'"; + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; + $sql = "INSERT OR REPLACE INTO $dbtable VALUES( $values )"; + $rv = $dbh->do($sql); + $rv = 0 if ($rv == 0E0); + $rv = sprintf("%d row%s %s",$rv,($rv<=1)?"":"s",$DBI::errstr); + + $dbh->disconnect; + return $rv; } # ------------------------------------------------------------------------------------------- @@ -612,28 +630,28 @@ Also refer to vedit.pl for Event management considerations. =cut sub setEventArticle { - return 0 if (@_ != 5); - my ($object, $evname, $titre, $oper,$eve) = @_; - (my $evp = $evname) =~ s/\.txt//; - my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); - my ($ed2,$et2) = split(/_/,$eve); - $et = ($et eq "NA") ? "" : $et; - $et =~ s/-/:/; - $titre = "(v$ev) $titre" if (defined($ev)); - $titre =~ s/'/''/g; - my $values = sprintf("%s,'%s','%s','%s','%s','%s','%s','%s','%s','%s'", - "null", - $ed, - $et, - $ed2, - $et2, - "Event", - $oper, - '', - $object, - $titre); - my $row = setArticle($values); - return $row; + return 0 if (@_ != 5); + my ($object, $evname, $titre, $oper,$eve) = @_; + (my $evp = $evname) =~ s/\.txt//; + my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); + my ($ed2,$et2) = split(/_/,$eve); + $et = ($et eq "NA") ? "" : $et; + $et =~ s/-/:/; + $titre = "(v$ev) $titre" if (defined($ev)); + $titre =~ s/'/''/g; + my $values = sprintf("%s,'%s','%s','%s','%s','%s','%s','%s','%s','%s'", + "null", + $ed, + $et, + $ed2, + $et2, + "Event", + $oper, + '', + $object, + $titre); + my $row = setArticle($values); + return $row; } # ------------------------------------------------------------------------------------------- @@ -647,17 +665,17 @@ Delete an article in DB. Required argument is article's ID =cut sub delArticle { - return 0 if (@_ != 1); - my ($dbh, $sql, $rv); + return 0 if (@_ != 1); + my ($dbh, $sql, $rv); - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; - $sql = "DELETE FROM $dbtable WHERE ID= $_[0]"; - $rv = $dbh->do($sql); - $rv = 0 if ($rv == 0E0); - $rv = sprintf("(%d row%s) %s",$rv,($rv<=1)?"":"s",$DBI::errstr); + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; + $sql = "DELETE FROM $dbtable WHERE ID= $_[0]"; + $rv = $dbh->do($sql); + $rv = 0 if ($rv == 0E0); + $rv = sprintf("(%d row%s) %s",$rv,($rv<=1)?"":"s",$DBI::errstr); - $dbh->disconnect; - return $rv; + $dbh->disconnect; + return $rv; } # ------------------------------------------------------------------------------------------- @@ -680,32 +698,32 @@ Returns 0 or number of rows deleted. =cut sub delEventArticle { - return 0 if (@_ != 2); - my ($object,$evname) = @_; - (my $evp = $evname) =~ s/\.txt//; - my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); - $et = "" if ($et eq "NA"); - $et =~ s/-/:/; - - my $where .= "STARTDATE = '$ed' "; - $where .= "AND STARTTIME = '$et' "; - $where .= "AND CATEGORY = 'Event' "; - $where .= "AND PLACE = '$object' "; - $where .= "AND SUBJECT LIKE '(v$ev)%'" if (defined($ev)); - - my ($rs, $dbh, $sql, $sth); - my $rv = 0; - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - $sql = "DELETE FROM $dbtable WHERE $where" ; - $rv = $dbh->do($sql); - $rv = 0 if ($rv == 0E0); - - $dbh->disconnect; - return $rv; + return 0 if (@_ != 2); + my ($object,$evname) = @_; + (my $evp = $evname) =~ s/\.txt//; + my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); + $et = "" if ($et eq "NA"); + $et =~ s/-/:/; + + my $where .= "STARTDATE = '$ed' "; + $where .= "AND STARTTIME = '$et' "; + $where .= "AND CATEGORY = 'Event' "; + $where .= "AND PLACE = '$object' "; + $where .= "AND SUBJECT LIKE '(v$ev)%'" if (defined($ev)); + + my ($rs, $dbh, $sql, $sth); + my $rv = 0; + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + $sql = "DELETE FROM $dbtable WHERE $where" ; + $rv = $dbh->do($sql); + $rv = 0 if ($rv == 0E0); + + $dbh->disconnect; + return $rv; } # ------------------------------------------------------------------------------------------- @@ -719,28 +737,28 @@ get one article as a JSON object. Required argument is article's ID. =cut sub getArticle { - return 0 if (@_ != 1); - my $id = $_[0]; - my ($rs, $dbh, $sql, $sth); - my $row = ""; - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT "; - $sql .= "FROM $dbtable WHERE ID=$_[0]" ; - $sth = $dbh->prepare($sql); - $sth->execute(); - while ($rs = $sth->fetchrow_hashref()) { - while ((my $key, my $value) = each(%$rs)){ - $value =~ s/\Q"\E/"/g; - $row .= "\"$key\": \"$value\","; - } - } - $row =~ s/,$//; - $dbh->disconnect; - return "{ $row }"; + return 0 if (@_ != 1); + my $id = $_[0]; + my ($rs, $dbh, $sql, $sth); + my $row = ""; + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT "; + $sql .= "FROM $dbtable WHERE ID=$_[0]" ; + $sth = $dbh->prepare($sql); + $sth->execute(); + while ($rs = $sth->fetchrow_hashref()) { + while ((my $key, my $value) = each(%$rs)){ + $value =~ s/\Q"\E/"/g; + $row .= "\"$key\": \"$value\","; + } + } + $row =~ s/,$//; + $dbh->disconnect; + return "{ $row }"; } # ------------------------------------------------------------------------------------------- @@ -756,22 +774,22 @@ intended to only report times on start and end day of a range (suitable for week =cut sub articleTimes { - return undef if (@_ != 2) ; - my $ptr = $_[0]; my $ymd = $_[1]; - my $ret = ""; - if ($ptr->[G_STARTDATE] eq $ptr->[G_ENDDATE]) { - if (($ptr->[G_STARTTIME] ne "") || ($ptr->[G_STARTTIME] ne "")) { - $ret = "$ptr->[G_STARTTIME]⇒$ptr->[G_ENDTIME] "; - } - } else { - if ($ymd eq $ptr->[G_STARTDATE] && $ptr->[G_STARTTIME] ne "") { - $ret = "$ptr->[G_STARTTIME]⇒ "; - } - if ($ymd eq $ptr->[G_ENDDATE] && $ptr->[G_ENDTIME] ne "") { - $ret = "⇒$ptr->[G_ENDTIME] "; - } - } - return $ret; + return undef if (@_ != 2) ; + my $ptr = $_[0]; my $ymd = $_[1]; + my $ret = ""; + if ($ptr->[G_STARTDATE] eq $ptr->[G_ENDDATE]) { + if (($ptr->[G_STARTTIME] ne "") || ($ptr->[G_STARTTIME] ne "")) { + $ret = "$ptr->[G_STARTTIME]⇒$ptr->[G_ENDTIME] "; + } + } else { + if ($ymd eq $ptr->[G_STARTDATE] && $ptr->[G_STARTTIME] ne "") { + $ret = "$ptr->[G_STARTTIME]⇒ "; + } + if ($ymd eq $ptr->[G_ENDDATE] && $ptr->[G_ENDTIME] ne "") { + $ret = "⇒$ptr->[G_ENDTIME] "; + } + } + return $ret; } # ------------------------------------------------------------------------------------------- @@ -787,17 +805,18 @@ eg. [user1, user2] + others =cut sub articleWho { - return undef if (@_ != 1); - my $art = $_[0]; my $listFullNames = ""; - if ($art->[G_UID] ne "") { - $listFullNames = "[".join(', ', map { WebObs::Users::userName($_)} split(/\+/,$art->[G_UID]))."]"; - } - if ($art->[G_OTHERS] ne "") { - #$listFullNames .= " + $art->[G_OTHERS]"; - (my $o = $art->[G_OTHERS]) =~ s/ \+ / , /g; # "+" to commas, because "+" used to split later - $listFullNames .= " + ".($o); - } - return $listFullNames; + return undef if (@_ != 1); + my $art = $_[0]; my $listFullNames = ""; + if ($art->[G_UID] ne "") { + $listFullNames = "[".join(', ', map { WebObs::Users::userName($_)} split(/\+/,$art->[G_UID]))."]"; + } + if ($art->[G_OTHERS] ne "") { + + #$listFullNames .= " + $art->[G_OTHERS]"; + (my $o = $art->[G_OTHERS]) =~ s/ \+ / , /g; # "+" to commas, because "+" used to split later + $listFullNames .= " + ".($o); + } + return $listFullNames; } # ------------------------------------------------------------------------------------------- @@ -812,27 +831,27 @@ for article 'art' in week 'w' =cut sub calendarTD { - return undef if (@_ != 4) ; my ($w, $art, $artstart, $artend) = @_; - my $tdtext = my $t1 = my $r1 = ""; - if ($artstart == $artend) { - $tdtext .= ("$art->[G_STARTTIME]$art->[G_ENDTIME]" ne "") ? "$art->[G_STARTTIME]⇒$art->[G_ENDTIME] " : ""; - } else { - $tdtext .= ($artstart >= $w && $artstart <= $w+6*86400 && "$art->[G_STARTTIME]" ne "") ? "
    $art->[G_STARTTIME]⇒
    " : ""; - } - $t1 = substr($art->[G_SUBJECT],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; - if (length($art->[G_SUBJECT])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } - $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; - $t1 = substr($art->[G_UID],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; - if (length($art->[G_UID])>$tdtrunc) { $r1 = rindex($t1,"+"); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } - $t1 =~ s/\Q'\E/'/g; $tdtext .= (length($t1)>0) ? "[$t1] " : " "; - $t1 = substr($art->[G_OTHERS],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; - if (length($art->[G_OTHERS])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } - $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; - - if ($artstart != $artend) { - $tdtext .= ($artend >= $w && $artend <= $w+6*86400 && "$art->[G_ENDTIME]" ne "") ? "
    ⇒ $art->[G_ENDTIME]
    " : ""; - } - return $tdtext; + return undef if (@_ != 4) ; my ($w, $art, $artstart, $artend) = @_; + my $tdtext = my $t1 = my $r1 = ""; + if ($artstart == $artend) { + $tdtext .= ("$art->[G_STARTTIME]$art->[G_ENDTIME]" ne "") ? "$art->[G_STARTTIME]⇒$art->[G_ENDTIME] " : ""; + } else { + $tdtext .= ($artstart >= $w && $artstart <= $w+6*86400 && "$art->[G_STARTTIME]" ne "") ? "
    $art->[G_STARTTIME]⇒
    " : ""; + } + $t1 = substr($art->[G_SUBJECT],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; + if (length($art->[G_SUBJECT])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } + $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; + $t1 = substr($art->[G_UID],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; + if (length($art->[G_UID])>$tdtrunc) { $r1 = rindex($t1,"+"); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } + $t1 =~ s/\Q'\E/'/g; $tdtext .= (length($t1)>0) ? "[$t1] " : " "; + $t1 = substr($art->[G_OTHERS],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; + if (length($art->[G_OTHERS])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } + $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; + + if ($artstart != $artend) { + $tdtext .= ($artend >= $w && $artend <= $w+6*86400 && "$art->[G_ENDTIME]" ne "") ? "
    ⇒ $art->[G_ENDTIME]
    " : ""; + } + return $tdtext; } # ------------------------------------------------------------------------------------------- @@ -846,16 +865,16 @@ articleTip(article) internal helper to return the tip (popup) contents for artic =cut sub articleTip { - return undef if (@_ != 1); - my $art = $_[0]; my $text = ""; my $qq = ""; - $text .= "$__{'Who'}: $art->[G_UID]
    "; - ($qq = $art->[G_SUBJECT]) =~ s/\Q"\E/″/g; $text .= "$__{'Subject'}: $qq
    "; - $text .= "$__{'Date'}: $art->[G_STARTDATE] $art->[G_STARTTIME] ⇒ $art->[G_ENDDATE] $art->[G_ENDTIME]
    "; - ($qq = $art->[G_PLACE]) =~ s/\Q"\E/″/g; $text .= "$__{'Place'}: $qq
    "; - $text =~ s/\Q'\E/'/g; - return $text; + return undef if (@_ != 1); + my $art = $_[0]; my $text = ""; my $qq = ""; + $text .= "$__{'Who'}: $art->[G_UID]
    "; + ($qq = $art->[G_SUBJECT]) =~ s/\Q"\E/″/g; $text .= "$__{'Subject'}: $qq
    "; + $text .= "$__{'Date'}: $art->[G_STARTDATE] $art->[G_STARTTIME] ⇒ $art->[G_ENDDATE] $art->[G_ENDTIME]
    "; + ($qq = $art->[G_PLACE]) =~ s/\Q"\E/″/g; $text .= "$__{'Place'}: $qq
    "; + $text =~ s/\Q'\E/'/g; + return $text; } - + # ------------------------------------------------------------------------------------------- =pod @@ -877,11 +896,11 @@ The list of 'applicable' indexes of 'rs' is returned as an array. =cut sub ixApplicable { - return undef if (@_ < 2) ; - my ($rs, $dtfrom) = @_ ; - my $dtto = (@_ == 3) ? $_[2] : $dtfrom; - my $f = $dtfrom->strftime('%Y-%m-%d'); my $t = $dtto->strftime('%Y-%m-%d'); - return grep { @{$rs}[$_]->[G_STARTDATE] le $t && (@{$rs}[$_]->[G_ENDDATE] ge $f || @{$rs}[$_]->[G_ENDDATE] eq '') } (0..@{$rs}-1); + return undef if (@_ < 2) ; + my ($rs, $dtfrom) = @_ ; + my $dtto = (@_ == 3) ? $_[2] : $dtfrom; + my $f = $dtfrom->strftime('%Y-%m-%d'); my $t = $dtto->strftime('%Y-%m-%d'); + return grep { @{$rs}[$_]->[G_STARTDATE] le $t && (@{$rs}[$_]->[G_ENDDATE] ge $f || @{$rs}[$_]->[G_ENDDATE] eq '') } (0..@{$rs}-1); } 1; diff --git a/CODE/perl/lib/Grids.pm b/CODE/perl/lib/Grids.pm index fd0a2ffc..6027ca2f 100644 --- a/CODE/perl/lib/Grids.pm +++ b/CODE/perl/lib/Grids.pm @@ -42,29 +42,29 @@ $VERSION = "1.00"; %DOMAINS = readDomain(); if (-e $WEBOBS{FILE_OWNERS}) { - %OWNRS = readCfg($WEBOBS{FILE_OWNERS}); + %OWNRS = readCfg($WEBOBS{FILE_OWNERS}); } #FB-was: if (-e $WEBOBS{FILE_DISCIPLINES}) { %DISCP = readCfg($WEBOBS{FILE_DISCIPLINES}); } if (-e $WEBOBS{CONF_NODES}) { - %NODES = readCfg($WEBOBS{CONF_NODES}); + %NODES = readCfg($WEBOBS{CONF_NODES}); } if (-e $WEBOBS{CONF_GRIDS}) { - %GRIDS = readCfg($WEBOBS{CONF_GRIDS}); + %GRIDS = readCfg($WEBOBS{CONF_GRIDS}); } # %node2node: hash key = 'parentnode|feature', hash value = 'childnode' or 'childnode1|childnode2|...' if (-e $NODES{FILE_NODES2NODES}) { - my @file_node2node = readCfgFile("$NODES{FILE_NODES2NODES}"); - for (@file_node2node) { - if ($_ =~ /.+\|.+\|.+/) { - my ($parent_node,$feature,$children_node) = split(/\|/,$_); - my $key_link = $parent_node."|".$feature; - $node2node{$key_link} .= (exists($node2node{$key_link}) ? "|":"").$children_node; - } - } + my @file_node2node = readCfgFile("$NODES{FILE_NODES2NODES}"); + for (@file_node2node) { + if ($_ =~ /.+\|.+\|.+/) { + my ($parent_node,$feature,$children_node) = split(/\|/,$_); + my $key_link = $parent_node."|".$feature; + $node2node{$key_link} .= (exists($node2node{$key_link}) ? "|":"").$children_node; + } + } } =pod @@ -82,15 +82,15 @@ Reads all 'domains' configurations into a HoH. =cut sub readDomain { - my %ret; - my @dom = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select CODE,OOA,NAME from $WEBOBS{SQL_TABLE_DOMAINS} order by OOA"); - chomp(@dom); - for (@dom) { - my @tmp = split(/\|/,$_); - $ret{$tmp[0]}{OOA} = $tmp[1]; - $ret{$tmp[0]}{NAME} = $tmp[2]; - } - return %ret; + my %ret; + my @dom = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select CODE,OOA,NAME from $WEBOBS{SQL_TABLE_DOMAINS} order by OOA"); + chomp(@dom); + for (@dom) { + my @tmp = split(/\|/,$_); + $ret{$tmp[0]}{OOA} = $tmp[1]; + $ret{$tmp[0]}{NAME} = $tmp[2]; + } + return %ret; } =pod @@ -113,29 +113,32 @@ Internally uses WebObs::listProcNames. =cut sub readProc { - my %ret; - for my $f (listProcNames($_[0])) { - my %tmp = readCfg("$WEBOBS{PATH_PROCS}/$f/$f.conf",@_[1..$#_]); - # --- get list of associated NODES - opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); - my @lSn = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); - foreach (@lSn) {s/^PROC\.($f)\.//g}; - @lSn = sort {$a cmp $b} @lSn ; - $tmp{'NODESLIST'} = \@lSn; - closedir(DIR); - # --- get list of associated FORMS - opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); - my @lSf = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2FORMS}."/".$_} readdir(DIR); - foreach (@lSf) {s/^PROC\.($f)\.//g}; - $tmp{'FORM'} = $lSf[0]; #NOTE: keeps only the first FORM - closedir(DIR); - # --- get DOMAIN - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'PROC' and NAME = '$f'"); - chomp(@qx); - $tmp{'DOMAIN'} = join('|',@qx); - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listProcNames($_[0])) { + my %tmp = readCfg("$WEBOBS{PATH_PROCS}/$f/$f.conf",@_[1..$#_]); + + # --- get list of associated NODES + opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); + my @lSn = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); + foreach (@lSn) {s/^PROC\.($f)\.//g}; + @lSn = sort {$a cmp $b} @lSn ; + $tmp{'NODESLIST'} = \@lSn; + closedir(DIR); + + # --- get list of associated FORMS + opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); + my @lSf = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2FORMS}."/".$_} readdir(DIR); + foreach (@lSf) {s/^PROC\.($f)\.//g}; + $tmp{'FORM'} = $lSf[0]; #NOTE: keeps only the first FORM + closedir(DIR); + + # --- get DOMAIN + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'PROC' and NAME = '$f'"); + chomp(@qx); + $tmp{'DOMAIN'} = join('|',@qx); + $ret{$f}=\%tmp; + } + return %ret; } =head2 readSefran @@ -153,25 +156,27 @@ Internally uses WebObs::listSefranNames. =cut sub readSefran { - my %ret; - for my $f (listSefranNames($_[0])) { - my %tmp = readCfg("$WEBOBS{PATH_SEFRANS}/$f/$f.conf"); - $tmp{NAME} ||= $tmp{TITRE}; - # --- get channels list - my @ch = readCfgFile(exists($tmp{CHANNEL_CONF}) ? "$tmp{CHANNEL_CONF}":"$WEBOBS{PATH_SEFRANS}/$f/channels.conf"); - my @st; - for (@ch) { - my ($ali,$cod) = split(/\s+/,$_); - push(@st,$ali); - } - $tmp{'CHANNELLIST'} = join('|',@st); - # --- get DOMAIN - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'SEFRAN' and NAME = '$f'"); - chomp(@qx); - $tmp{'DOMAIN'} = join('|',@qx); - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listSefranNames($_[0])) { + my %tmp = readCfg("$WEBOBS{PATH_SEFRANS}/$f/$f.conf"); + $tmp{NAME} ||= $tmp{TITRE}; + + # --- get channels list + my @ch = readCfgFile(exists($tmp{CHANNEL_CONF}) ? "$tmp{CHANNEL_CONF}":"$WEBOBS{PATH_SEFRANS}/$f/channels.conf"); + my @st; + for (@ch) { + my ($ali,$cod) = split(/\s+/,$_); + push(@st,$ali); + } + $tmp{'CHANNELLIST'} = join('|',@st); + + # --- get DOMAIN + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'SEFRAN' and NAME = '$f'"); + chomp(@qx); + $tmp{'DOMAIN'} = join('|',@qx); + $ret{$f}=\%tmp; + } + return %ret; } =pod @@ -189,21 +194,21 @@ Internally uses WebObs::listViewNames. =cut sub readView { - my %ret; - for my $f (listViewNames($_[0])) { - my %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$f/$f.conf"); - opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); - my @l = grep {/^VIEW\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); - foreach (@l) {s/^VIEW\.($f)\.//g}; - @l = sort {$a cmp $b} @l ; - $tmp{'NODESLIST'} = \@l; - closedir(DIR); - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'VIEW' and NAME = '$f'"); - chomp(@qx); - $tmp{'DOMAIN'} = $qx[0]; - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listViewNames($_[0])) { + my %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$f/$f.conf"); + opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); + my @l = grep {/^VIEW\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); + foreach (@l) {s/^VIEW\.($f)\.//g}; + @l = sort {$a cmp $b} @l ; + $tmp{'NODESLIST'} = \@l; + closedir(DIR); + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'VIEW' and NAME = '$f'"); + chomp(@qx); + $tmp{'DOMAIN'} = $qx[0]; + $ret{$f}=\%tmp; + } + return %ret; } =pod @@ -217,23 +222,23 @@ Adds DOMAIN code from grids2domains db =cut sub readGrid { - my %ret; - my %tmp; - my $f = $_[0]; - my ($gt,$gn) = split(/\./,$f); - my $z = "PATH_${gt}S"; - %tmp = readCfg("$WEBOBS{$z}/$gn/$gn.conf"); - opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); - my @l = grep {/^$f\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); - foreach (@l) {s/^$f\.//g}; - @l = sort {$a cmp $b} @l ; - $tmp{'NODESLIST'} = \@l; - closedir(DIR); - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = '$gt' and NAME = '$gn'"); - chomp(@qx); - $tmp{'DOMAIN'} = $qx[0]; - $ret{$f}=\%tmp; - return %ret; + my %ret; + my %tmp; + my $f = $_[0]; + my ($gt,$gn) = split(/\./,$f); + my $z = "PATH_${gt}S"; + %tmp = readCfg("$WEBOBS{$z}/$gn/$gn.conf"); + opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); + my @l = grep {/^$f\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); + foreach (@l) {s/^$f\.//g}; + @l = sort {$a cmp $b} @l ; + $tmp{'NODESLIST'} = \@l; + closedir(DIR); + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = '$gt' and NAME = '$gn'"); + chomp(@qx); + $tmp{'DOMAIN'} = $qx[0]; + $ret{$f}=\%tmp; + return %ret; } @@ -249,29 +254,33 @@ Internally uses WebObs::listNodeNames. =cut sub readNode { - my %ret; - for my $f (listNodeNames($_[0])) { - my %tmp = readCfg("$NODES{PATH_NODES}/$f/$f.cnf","escape",@_[1..$#_]); - #FB-legacy: if TYPE not defined and old type.txt exists, loads it - if (!$tmp{TYPE}) { - my $typ = "$NODES{PATH_NODES}/$f/type.txt"; - if ((-e $typ) && (-s $typ != 0)) { - $tmp{TYPE} = trim(join("",readFile($typ))); - } - } - $tmp{PROJECT} = 1 if (-s "$NODES{PATH_NODES}/$f/$NODES{SPATH_INTERVENTIONS}/${f}_Projet.txt"); - #substitutes possible decimal comma to point for numerics - $tmp{LAT_WGS84} =~ s/,/./g; - $tmp{LON_WGS84} =~ s/,/./g; - #FB-legacy: removes escape characters in feature's list - $tmp{FILES_FEATURES} =~ s/\\,/,/g; - $tmp{FILES_FEATURES} =~ s/\\\|/,/g; - # removes trailing blanks in each features - $tmp{FILES_FEATURES} = join(",",map {trim($_)} split(/[,\|]/,$tmp{FILES_FEATURES})); - - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listNodeNames($_[0])) { + my %tmp = readCfg("$NODES{PATH_NODES}/$f/$f.cnf","escape",@_[1..$#_]); + + #FB-legacy: if TYPE not defined and old type.txt exists, loads it + if (!$tmp{TYPE}) { + my $typ = "$NODES{PATH_NODES}/$f/type.txt"; + if ((-e $typ) && (-s $typ != 0)) { + $tmp{TYPE} = trim(join("",readFile($typ))); + } + } + $tmp{PROJECT} = 1 if (-s "$NODES{PATH_NODES}/$f/$NODES{SPATH_INTERVENTIONS}/${f}_Projet.txt"); + + #substitutes possible decimal comma to point for numerics + $tmp{LAT_WGS84} =~ s/,/./g; + $tmp{LON_WGS84} =~ s/,/./g; + + #FB-legacy: removes escape characters in feature's list + $tmp{FILES_FEATURES} =~ s/\\,/,/g; + $tmp{FILES_FEATURES} =~ s/\\\|/,/g; + + # removes trailing blanks in each features + $tmp{FILES_FEATURES} = join(",",map {trim($_)} split(/[,\|]/,$tmp{FILES_FEATURES})); + + $ret{$f}=\%tmp; + } + return %ret; } =pod @@ -288,16 +297,17 @@ it will be used as a regexp to select view names. =cut sub listViewNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $WEBOBS{PATH_VIEWS}) or die "can't opendir $WEBOBS{PATH_VIEWS}: $!"; - my @list = grep {/($filter)/ && -d $WEBOBS{PATH_VIEWS}."/".$_} readdir(DIR); - closedir(DIR); - my @finallist; - for (@list) { - push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authviews')); - } - return @finallist; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $WEBOBS{PATH_VIEWS}) or die "can't opendir $WEBOBS{PATH_VIEWS}: $!"; + my @list = grep {/($filter)/ && -d $WEBOBS{PATH_VIEWS}."/".$_} readdir(DIR); + closedir(DIR); + my @finallist; + for (@list) { + push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authviews')); + } + return @finallist; } =pod @@ -314,16 +324,17 @@ it will be used as a regexp to select proc names. =cut sub listProcNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $WEBOBS{PATH_PROCS}) or die "can't opendir $WEBOBS{PATH_PROCS}: $!"; - my @list = grep {/($filter)/ && -d $WEBOBS{PATH_PROCS}."/".$_} readdir(DIR); - closedir(DIR); - my @finallist; - for (@list) { - push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authprocs')); - } - return @finallist; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $WEBOBS{PATH_PROCS}) or die "can't opendir $WEBOBS{PATH_PROCS}: $!"; + my @list = grep {/($filter)/ && -d $WEBOBS{PATH_PROCS}."/".$_} readdir(DIR); + closedir(DIR); + my @finallist; + for (@list) { + push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authprocs')); + } + return @finallist; } =pod @@ -340,19 +351,20 @@ it will be used as a regexp to select proc names. =cut sub listSefranNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $WEBOBS{PATH_SEFRANS}) or die "can't opendir $WEBOBS{PATH_SEFRANS}: $!"; - my @list = grep {/($filter)/ && -d $WEBOBS{PATH_SEFRANS}."/".$_} readdir(DIR); - closedir(DIR); - my @finallist; - for (@list) { - my $mc = qx(grep -E "^MC3_NAME\\|" $WEBOBS{PATH_SEFRANS}/$_/$_.conf); - chomp($mc); - $mc =~ s/^MC3_NAME\|//g; - push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$mc,type=>'authprocs')); - } - return @finallist; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $WEBOBS{PATH_SEFRANS}) or die "can't opendir $WEBOBS{PATH_SEFRANS}: $!"; + my @list = grep {/($filter)/ && -d $WEBOBS{PATH_SEFRANS}."/".$_} readdir(DIR); + closedir(DIR); + my @finallist; + for (@list) { + my $mc = qx(grep -E "^MC3_NAME\\|" $WEBOBS{PATH_SEFRANS}/$_/$_.conf); + chomp($mc); + $mc =~ s/^MC3_NAME\|//g; + push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$mc,type=>'authprocs')); + } + return @finallist; } =pod @@ -369,12 +381,13 @@ it will be used as a regexp to select node names. =cut sub listNodeNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $NODES{PATH_NODES}) or die "can't opendir $NODES{PATH_NODES}: $!"; - my @list = grep {/($filter)/ && -d $NODES{PATH_NODES}."/".$_} readdir(DIR); - closedir(DIR); - return @list; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $NODES{PATH_NODES}) or die "can't opendir $NODES{PATH_NODES}: $!"; + my @list = grep {/($filter)/ && -d $NODES{PATH_NODES}."/".$_} readdir(DIR); + closedir(DIR); + return @list; } =pod @@ -400,19 +413,20 @@ type, if not specified, will default to ALL grid types (ie. VIEW and PROC). =cut sub listNodeGrids { - my %KWARGS = @_; - my $filterT = $KWARGS{type} && $KWARGS{type} =~ /^VIEW$|^PROC$/ ? $KWARGS{type} : ''; - #my $filterS = $KWARGS{node} ? $KWARGS{node} : ''; - my $filterS = $KWARGS{node} ? $KWARGS{node} : undef; - - my @s = listNodeNames($filterS); - my $g = "$WEBOBS{PATH_GRIDS2NODES}/"; - my %rs; - foreach (@s) { - my @l = grep(s{$g/}{}g, <$g/$filterT*$_>); - $rs{$_}=[grep(s{\.[^.]*$}{}, @l)]; - } - return %rs; + my %KWARGS = @_; + my $filterT = $KWARGS{type} && $KWARGS{type} =~ /^VIEW$|^PROC$/ ? $KWARGS{type} : ''; + + #my $filterS = $KWARGS{node} ? $KWARGS{node} : ''; + my $filterS = $KWARGS{node} ? $KWARGS{node} : undef; + + my @s = listNodeNames($filterS); + my $g = "$WEBOBS{PATH_GRIDS2NODES}/"; + my %rs; + foreach (@s) { + my @l = grep(s{$g/}{}g, <$g/$filterT*$_>); + $rs{$_}=[grep(s{\.[^.]*$}{}, @l)]; + } + return %rs; } =pod @@ -429,22 +443,22 @@ returns a hash of grid names: =cut sub listNameGrids { - my %rs; - my $n; - my %tmp; - my @V = listViewNames; - foreach (@V) { - $n = "VIEW.$_"; - %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$_/$_.conf"); - $rs{$n} = $tmp{'NAME'}; - } - my @P = listProcNames; - foreach (@P) { - $n = "PROC.$_"; - %tmp = readCfg("$WEBOBS{PATH_PROCS}/$_/$_.conf"); - $rs{$n} = $tmp{'NAME'}; - } - return %rs; + my %rs; + my $n; + my %tmp; + my @V = listViewNames; + foreach (@V) { + $n = "VIEW.$_"; + %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$_/$_.conf"); + $rs{$n} = $tmp{'NAME'}; + } + my @P = listProcNames; + foreach (@P) { + $n = "PROC.$_"; + %tmp = readCfg("$WEBOBS{PATH_PROCS}/$_/$_.conf"); + $rs{$n} = $tmp{'NAME'}; + } + return %rs; } =pod @@ -488,46 +502,48 @@ is then considered 'active' if one of isodateStart and isodateEnd (or both) fall =cut sub listGridNodes { - use Time::Piece; - my %KWARGS = @_; - my $grid = $KWARGS{grid} ? $KWARGS{grid} : undef; - my $valid = $KWARGS{valid} ? $KWARGS{valid} : undef; - my $acton = $KWARGS{active} ? $KWARGS{active} : undef; - my $today = my $deb = my $fin = ''; - if (defined($acton)) { - $today = strftime( '%Y-%m-%d', localtime ); - ($deb,$fin) = split(/:/,$acton); - if (!$fin) {$fin = $deb} - $deb =~ s/today/$today/; - $fin =~ s/today/$today/; - eval { $deb = Time::Piece->strptime($deb,"%Y-%m-%d") }; if ($@) { $deb = Time::Piece->strptime("","%Y-%m-%d") } - # FIX: 2038 for Perl 32-bits dates; WAS: eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("9999","%Y-%m-%d") } - eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("2038","%Y-%m-%d") } - } - my %vlist; - if (defined($grid)) { - $grid = ($grid =~ /\./) ? $grid : "*.$grid"; - my @list = qx (ls -L $WEBOBS{PATH_GRIDS2NODES}/$grid.*/*.cnf 2>/dev/null); - chomp(@list); - for my $n (@list) { - my $tINS = my $tEND = ''; - my %tmp = readCfg("$n"); - next if ( defined($valid) && $valid ne $tmp{VALID} ) ; - if ( defined($acton) ) { - # Time::Piece->strptime(, "%Y-%m-%d") accepts either %Y, %Y-%m or %Y-%m-%d (fills with '01' as necessary) - eval { $tINS = Time::Piece->strptime($tmp{INSTALL_DATE}, "%Y-%m-%d") } ; if ($@) { $tINS = Time::Piece->strptime("","%Y-%m-%d") } - # FIX: 2038 for Perl 32-bits dates; WAS: eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("9999","%Y-%m-%d") } - eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("2038","%Y-%m-%d") } - next if ( ($deb < $tINS) && ($fin < $tINS) ); - next if ( ($deb > $tEND) && ($fin > $tEND) ); - } - $vlist{ basename($n,'.cnf') } = { ALIAS => $tmp{ALIAS} , NAME => $tmp{NAME}, FID => $tmp{FID} }; - } - } - return %vlist; + use Time::Piece; + my %KWARGS = @_; + my $grid = $KWARGS{grid} ? $KWARGS{grid} : undef; + my $valid = $KWARGS{valid} ? $KWARGS{valid} : undef; + my $acton = $KWARGS{active} ? $KWARGS{active} : undef; + my $today = my $deb = my $fin = ''; + if (defined($acton)) { + $today = strftime( '%Y-%m-%d', localtime ); + ($deb,$fin) = split(/:/,$acton); + if (!$fin) {$fin = $deb} + $deb =~ s/today/$today/; + $fin =~ s/today/$today/; + eval { $deb = Time::Piece->strptime($deb,"%Y-%m-%d") }; if ($@) { $deb = Time::Piece->strptime("","%Y-%m-%d") } + +# FIX: 2038 for Perl 32-bits dates; WAS: eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("9999","%Y-%m-%d") } + eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("2038","%Y-%m-%d") } + } + my %vlist; + if (defined($grid)) { + $grid = ($grid =~ /\./) ? $grid : "*.$grid"; + my @list = qx (ls -L $WEBOBS{PATH_GRIDS2NODES}/$grid.*/*.cnf 2>/dev/null); + chomp(@list); + for my $n (@list) { + my $tINS = my $tEND = ''; + my %tmp = readCfg("$n"); + next if ( defined($valid) && $valid ne $tmp{VALID} ) ; + if ( defined($acton) ) { + +# Time::Piece->strptime(, "%Y-%m-%d") accepts either %Y, %Y-%m or %Y-%m-%d (fills with '01' as necessary) + eval { $tINS = Time::Piece->strptime($tmp{INSTALL_DATE}, "%Y-%m-%d") } ; if ($@) { $tINS = Time::Piece->strptime("","%Y-%m-%d") } + +# FIX: 2038 for Perl 32-bits dates; WAS: eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("9999","%Y-%m-%d") } + eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("2038","%Y-%m-%d") } + next if ( ($deb < $tINS) && ($fin < $tINS) ); + next if ( ($deb > $tEND) && ($fin > $tEND) ); + } + $vlist{ basename($n,'.cnf') } = { ALIAS => $tmp{ALIAS} , NAME => $tmp{NAME}, FID => $tmp{FID} }; + } + } + return %vlist; } - =pod =head2 normNode @@ -550,16 +566,16 @@ normNode may be used as a nodename validity (ie. well-formed AND existing) check =cut sub normNode { - my %KWARGS = @_; - my $node = $KWARGS{node} ? $KWARGS{node} : ''; - my $ret = ""; - if ($node) { - $node =~ s/\./*./g; - my @l = qx(ls -dr $WEBOBS{PATH_GRIDS2NODES}/$node 2>/dev/null); - chomp(@l); - if (scalar(@l) > 0) {$ret = basename($l[0])} - } - return $ret; + my %KWARGS = @_; + my $node = $KWARGS{node} ? $KWARGS{node} : ''; + my $ret = ""; + if ($node) { + $node =~ s/\./*./g; + my @l = qx(ls -dr $WEBOBS{PATH_GRIDS2NODES}/$node 2>/dev/null); + chomp(@l); + if (scalar(@l) > 0) {$ret = basename($l[0])} + } + return $ret; } =pod @@ -589,49 +605,49 @@ and type.txt file-reads ... sub getNodeString { - my %KWARGS = @_; - my $node = $KWARGS{node} ? $KWARGS{node} : ''; - my $style = $KWARGS{style} && $KWARGS{style} =~ /^alias|^short|^html/ ? $KWARGS{style} : 'html'; - my $link = $KWARGS{link} && $KWARGS{link} =~ /^node|^features/ ? $KWARGS{link} : ''; - - my $text = ""; - my $sub = ""; - if ($node ne "" && -f "$NODES{PATH_NODES}/$node/$node.cnf") { - my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); - if (isok($N{VALID})) { - my $nnode = normNode(node=>"..$node"); - no warnings "uninitialized"; - if ($style eq 'alias') { $text = $N{ALIAS} } - if ($style eq 'short') { $text = "$N{ALIAS}: $N{NAME}" } - if ($style eq 'html') { $text = "$N{ALIAS}: $N{NAME}".($N{TYPE} ne "" && $N{TYPE} ne "-" ? " ($N{TYPE})":"") } - if ($link eq 'node') { $text = "$text"; } - if ($link eq 'features') { - $text = "$text "; - if ($N{FILES_FEATURES} ne "") { - $text = " ".$text."\n" - ."
    "; - for my $feature (split(/,/,$N{FILES_FEATURES})) { - my $f = "$NODES{PATH_NODES}/$node/$NODES{SPATH_FEATURES}/$feature.txt"; - my $htm; - if (exists $node2node{"$node|$feature"}) { - for (split(/\|/,$node2node{"$node|$feature"})) { - $htm .= getNodeString(node=>$_, link=>'node')."
    " if ($_ ne ""); - } - } - if (-f $f) { - my @feat = readFile($f); - $htm .= WebObs::Wiki::wiki2html(join("",@feat)); - $htm =~ s/

    /
    /ig; - } - $sub .= "" if ($htm ne ""); - } - $text .= $sub."
    $feature".$htm."
    "; - } - } - use warnings; - } - } - return $text; + my %KWARGS = @_; + my $node = $KWARGS{node} ? $KWARGS{node} : ''; + my $style = $KWARGS{style} && $KWARGS{style} =~ /^alias|^short|^html/ ? $KWARGS{style} : 'html'; + my $link = $KWARGS{link} && $KWARGS{link} =~ /^node|^features/ ? $KWARGS{link} : ''; + + my $text = ""; + my $sub = ""; + if ($node ne "" && -f "$NODES{PATH_NODES}/$node/$node.cnf") { + my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); + if (isok($N{VALID})) { + my $nnode = normNode(node=>"..$node"); + no warnings "uninitialized"; + if ($style eq 'alias') { $text = $N{ALIAS} } + if ($style eq 'short') { $text = "$N{ALIAS}: $N{NAME}" } + if ($style eq 'html') { $text = "$N{ALIAS}: $N{NAME}".($N{TYPE} ne "" && $N{TYPE} ne "-" ? " ($N{TYPE})":"") } + if ($link eq 'node') { $text = "$text"; } + if ($link eq 'features') { + $text = "$text "; + if ($N{FILES_FEATURES} ne "") { + $text = " ".$text."\n" + ."
    "; + for my $feature (split(/,/,$N{FILES_FEATURES})) { + my $f = "$NODES{PATH_NODES}/$node/$NODES{SPATH_FEATURES}/$feature.txt"; + my $htm; + if (exists $node2node{"$node|$feature"}) { + for (split(/\|/,$node2node{"$node|$feature"})) { + $htm .= getNodeString(node=>$_, link=>'node')."
    " if ($_ ne ""); + } + } + if (-f $f) { + my @feat = readFile($f); + $htm .= WebObs::Wiki::wiki2html(join("",@feat)); + $htm =~ s/

    /
    /ig; + } + $sub .= "" if ($htm ne ""); + } + $text .= $sub."
    $feature".$htm."
    "; + } + } + use warnings; + } + } + return $text; } =pod @@ -648,32 +664,32 @@ to which $eventFileName belongs. Returns "" if no such list. sub parentEvents ($) { - my $eventFile = shift; - my $parent = ""; - my @subParent = split(/\//,$eventFile); - if ($#subParent > 0) { - $parent = join("/",@subParent[0..($#subParent-1)]); - } else { - return ""; - } - - my $station = substr($eventFile,0,7); - my $txt = ""; - my @x = split(/\//,$parent); - for (my $i=$#x;$i>=0;$i--) { - my $f = "$NODES{PATH_NODES}/$station/$NODES{SPATH_INTERVENTIONS}/".join("/",@x[0..$i]).".txt"; - my ($s,$d,$h) = split(/_/,$x[$i]); - $h =~ s/-/:/; - my $t = "???"; - if (-e $f) { - my @xx = readFile($f); - chomp(@xx); - my $o; - ($o,$t) = split(/\|/,$xx[0]); - } - $txt .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; - } - return $txt; + my $eventFile = shift; + my $parent = ""; + my @subParent = split(/\//,$eventFile); + if ($#subParent > 0) { + $parent = join("/",@subParent[0..($#subParent-1)]); + } else { + return ""; + } + + my $station = substr($eventFile,0,7); + my $txt = ""; + my @x = split(/\//,$parent); + for (my $i=$#x;$i>=0;$i--) { + my $f = "$NODES{PATH_NODES}/$station/$NODES{SPATH_INTERVENTIONS}/".join("/",@x[0..$i]).".txt"; + my ($s,$d,$h) = split(/_/,$x[$i]); + $h =~ s/-/:/; + my $t = "???"; + if (-e $f) { + my @xx = readFile($f); + chomp(@xx); + my $o; + ($o,$t) = split(/\|/,$xx[0]); + } + $txt .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; + } + return $txt; } =pod @@ -696,35 +712,35 @@ It appends and possibly overwrites codes from local configuration file CONF/netw =cut sub codesFDSN { - my %codes; - my @FDSN = readFile("$WEBOBS{ROOT_CODE}/etc/fdsncodes.csv",'^[^#].*'); - chomp(@FDSN); - - # process CSV file, result from IRIS web-service - # Example: - # AA,'Anchorage Strong Motion Network', - for (@FDSN) { - my ($cle,$val) = split(/,/,$_); - $val =~ s/^'//; - $val =~ s/'$//; - $codes{trim($cle)} = $val; - } - - # overwrites with optional local configuration file - my @NET = readFile("$NODES{FILE_NETWORKS}",'^[^#].*'); - chomp(@NET); - for (@NET) { - my ($cle,$val) = split(/,/,$_); - $val =~ s/^'//; - $val =~ s/'$//; - if (defined $codes{trim($cle)}) { - $codes{trim($cle)} = "$val !! overwritten FDSN \"$codes{trim($cle)}\" !!"; - } else { - $codes{trim($cle)} = $val; - } - } - - return %codes; + my %codes; + my @FDSN = readFile("$WEBOBS{ROOT_CODE}/etc/fdsncodes.csv",'^[^#].*'); + chomp(@FDSN); + + # process CSV file, result from IRIS web-service + # Example: + # AA,'Anchorage Strong Motion Network', + for (@FDSN) { + my ($cle,$val) = split(/,/,$_); + $val =~ s/^'//; + $val =~ s/'$//; + $codes{trim($cle)} = $val; + } + + # overwrites with optional local configuration file + my @NET = readFile("$NODES{FILE_NETWORKS}",'^[^#].*'); + chomp(@NET); + for (@NET) { + my ($cle,$val) = split(/,/,$_); + $val =~ s/^'//; + $val =~ s/'$//; + if (defined $codes{trim($cle)}) { + $codes{trim($cle)} = "$val !! overwritten FDSN \"$codes{trim($cle)}\" !!"; + } else { + $codes{trim($cle)} = $val; + } + } + + return %codes; } =pod @@ -733,19 +749,19 @@ Reads calibration file of a node (fullid) and return an array =cut sub readCLB { - my $node = shift; - my %data; - my ($GRIDType, $GRIDName, $NODEName) = split(/\./, $node); - - my $file = "$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"; # standard CLB file name - my $legclb = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; - $file = $legclb if ( ! -e $file && -e $legclb); # for backwards compatibility - (my $autoclb = $file) =~ s/\.clb/_auto.clb/; # auto-generated CLB - $file = $autoclb if ( -e $autoclb && ! -s $file ); - if ( -s $file ) { - %data = readCfg($file); - } - return %data; + my $node = shift; + my %data; + my ($GRIDType, $GRIDName, $NODEName) = split(/\./, $node); + + my $file = "$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"; # standard CLB file name + my $legclb = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; + $file = $legclb if ( ! -e $file && -e $legclb); # for backwards compatibility + (my $autoclb = $file) =~ s/\.clb/_auto.clb/; # auto-generated CLB + $file = $autoclb if ( -e $autoclb && ! -s $file ); + if ( -s $file ) { + %data = readCfg($file); + } + return %data; } 1; diff --git a/CODE/perl/lib/Mapping.pm b/CODE/perl/lib/Mapping.pm index e76e3400..2c33063d 100644 --- a/CODE/perl/lib/Mapping.pm +++ b/CODE/perl/lib/Mapping.pm @@ -76,18 +76,18 @@ Returns %UTM address if loaded successfully, 0 otherwise. =cut sub setUTMLOCAL { - if ($_[0] && -e "$_[0]") { - %UTM = (); - %UTM = readCfg($_[0]); - } - else { - if ((exists $WEBOBS{UTM_LOCAL}) && -e $WEBOBS{UTM_LOCAL}) { - %UTM = (); - %UTM = readCfg($WEBOBS{UTM_LOCAL}) ; - } - } - if (scalar(keys(%UTM))) { return \%UTM } - else { return 0 } + if ($_[0] && -e "$_[0]") { + %UTM = (); + %UTM = readCfg($_[0]); + } + else { + if ((exists $WEBOBS{UTM_LOCAL}) && -e $WEBOBS{UTM_LOCAL}) { + %UTM = (); + %UTM = readCfg($WEBOBS{UTM_LOCAL}) ; + } + } + if (scalar(keys(%UTM))) { return \%UTM } + else { return 0 } } =pod @@ -105,13 +105,13 @@ Calcul de la latitude isométrique sub ign0001 { - my $p = shift; - my $e = shift; + my $p = shift; + my $e = shift; - # Jeux d'essai - #$e = 0.08199188998; $p = 0.872664626; - my $l = log(tan(pi/4 + $p/2)*(((1.0 - $e*sin($p))/(1.0 + $e*sin($p)))**($e/2))); - return $l; + # Jeux d'essai + #$e = 0.08199188998; $p = 0.872664626; + my $l = log(tan(pi/4 + $p/2)*(((1.0 - $e*sin($p))/(1.0 + $e*sin($p)))**($e/2))); + return $l; } =pod @@ -138,22 +138,21 @@ sub ign0001 { =cut sub ign0009 { - my $l = shift; - my $p = shift; - my $he = shift; - my $a = shift; - my $e = shift; + my $l = shift; + my $p = shift; + my $he = shift; + my $a = shift; + my $e = shift; - my $N = ign0021($p,$a,$e); + my $N = ign0021($p,$a,$e); - my $x = ($N + $he)*cos($p)*cos($l); - my $y = ($N + $he)*cos($p)*sin($l); - my $z = ($N*(1 - $e*$e) + $he)*sin($p); + my $x = ($N + $he)*cos($p)*cos($l); + my $y = ($N + $he)*cos($p)*sin($l); + my $z = ($N*(1 - $e*$e) + $he)*sin($p); - return ($x,$y,$z); + return ($x,$y,$z); } - =pod =head2 ign0012 @@ -175,46 +174,44 @@ sub ign0009 { =cut sub ign0012 { - my $x = shift; - my $y = shift; - my $z = shift; - my $a = shift; - my $e = shift; - - - # Jeu d'essai - #$a = 6378249.2; $e = 0.08248325679; $x = 6376064.695; $y = 111294.623; $z = 128984.725; - - my $EPS = 1e-11; # EPS = tolérance de convergence, en rad - my $IMAX = 10; # Imax = nombre maximum d'itérations - - my $R = sqrt($x*$x + $y*$y); - my $l = 2*atan($y/($x + $R)); - my $p; - my $h; - my $p0 = atan($z/sqrt($x*$x + $y*$y*(1 - ($a*$e*$e)/sqrt($x*$x + $y*$y + $z*$z)))); - my $p1; - my $i = 0; - my $fin = 0; - while ($i < $IMAX && !$fin) { - $i++; - $p1 = atan(($z/$R)/(1 - ($a*$e*$e*cos($p0))/($R*sqrt(1 - $e*$e*sin($p0)**2)))); - my $res = abs($p1-$p0); - if ($res < $EPS) { - $fin = 1; - } - $p0 = $p1; - } - if ($fin) { - $p = $p1; - $h = $R/cos($p) - $a/sqrt(1 - $e*$e*sin($p)**2); - } - - return ($l,$p,$h); + my $x = shift; + my $y = shift; + my $z = shift; + my $a = shift; + my $e = shift; + +# Jeu d'essai +#$a = 6378249.2; $e = 0.08248325679; $x = 6376064.695; $y = 111294.623; $z = 128984.725; + + my $EPS = 1e-11; # EPS = tolérance de convergence, en rad + my $IMAX = 10; # Imax = nombre maximum d'itérations + + my $R = sqrt($x*$x + $y*$y); + my $l = 2*atan($y/($x + $R)); + my $p; + my $h; + my $p0 = atan($z/sqrt($x*$x + $y*$y*(1 - ($a*$e*$e)/sqrt($x*$x + $y*$y + $z*$z)))); + my $p1; + my $i = 0; + my $fin = 0; + while ($i < $IMAX && !$fin) { + $i++; + $p1 = atan(($z/$R)/(1 - ($a*$e*$e*cos($p0))/($R*sqrt(1 - $e*$e*sin($p0)**2)))); + my $res = abs($p1-$p0); + if ($res < $EPS) { + $fin = 1; + } + $p0 = $p1; + } + if ($fin) { + $p = $p1; + $h = $R/cos($p) - $a/sqrt(1 - $e*$e*sin($p)**2); + } + + return ($l,$p,$h); } - =pod =head2 ign0013b @@ -240,27 +237,27 @@ sub ign0012 { =cut sub ign0013b { - my $tx = shift; - my $ty = shift; - my $tz = shift; - my $d = shift; - my $rx = shift; - my $ry = shift; - my $rz = shift; - my $ux = shift; - my $uy = shift; - my $uz = shift; - - my @v; - - # jeux d'essai - #$u = [4154005.81,-80587.328,4823289.532]; $tx = -69.4; $ty = 18; $tz = 452.2; $d = -3.21e-6; $rx = 0; $ry = 0; $rz = 0.00000499358; - - $v[0] = ($tx - $ux)*($d - 1) + ($tz - $uz)*$ry - ($ty - $uy)*$rz; - $v[1] = ($ty - $uy)*($d - 1) + ($tx - $ux)*$rz - ($tz - $uz)*$rx; - $v[2] = ($tz - $uz)*($d - 1) + ($ty - $uy)*$rx - ($tx - $ux)*$ry; - - return @v; + my $tx = shift; + my $ty = shift; + my $tz = shift; + my $d = shift; + my $rx = shift; + my $ry = shift; + my $rz = shift; + my $ux = shift; + my $uy = shift; + my $uz = shift; + + my @v; + +# jeux d'essai +#$u = [4154005.81,-80587.328,4823289.532]; $tx = -69.4; $ty = 18; $tz = 452.2; $d = -3.21e-6; $rx = 0; $ry = 0; $rz = 0.00000499358; + + $v[0] = ($tx - $ux)*($d - 1) + ($tz - $uz)*$ry - ($ty - $uy)*$rz; + $v[1] = ($ty - $uy)*($d - 1) + ($tx - $ux)*$rz - ($tz - $uz)*$rx; + $v[2] = ($tz - $uz)*($d - 1) + ($ty - $uy)*$rx - ($tx - $ux)*$ry; + + return @v; } =pod @@ -284,16 +281,15 @@ sub ign0013b { =cut sub ign0021 { - my $p = shift; - my $a = shift; - my $e = shift; + my $p = shift; + my $a = shift; + my $e = shift; - my $n = $a/sqrt(1 - $e*$e*sin($p)**2); + my $n = $a/sqrt(1 - $e*$e*sin($p)**2); - return $n; + return $n; } - =pod =head2 ign0025 @@ -311,20 +307,20 @@ sub ign0021 { =cut sub ign0025 { - my $e = shift; - # Jeux d'essai - #$e = 0.08199188998; - - my @c; - $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; - $c[1] = -105.0/4096*$e**8 - 45.0/1024*$e**6 - 3.0/32*$e**4 - 3.0/8*$e**2; - $c[2] = 525.0/16384*$e**8 + 45.0/1024*$e**6 + 15.0/256*$e**4; - $c[3] = -175.0/12288*$e**8 - 35.0/3072*$e**6; - $c[4] = 315.0/131072*$e**8; - - return @c; -} + my $e = shift; + + # Jeux d'essai + #$e = 0.08199188998; + my @c; + $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; + $c[1] = -105.0/4096*$e**8 - 45.0/1024*$e**6 - 3.0/32*$e**4 - 3.0/8*$e**2; + $c[2] = 525.0/16384*$e**8 + 45.0/1024*$e**6 + 15.0/256*$e**4; + $c[3] = -175.0/12288*$e**8 - 35.0/3072*$e**6; + $c[4] = 315.0/131072*$e**8; + + return @c; +} =pod @@ -344,15 +340,14 @@ sub ign0025 { =cut sub ign0026 { - my $p = shift; - my @c = shift; + my $p = shift; + my @c = shift; - my $b = $c[0]*$p + $c[1]*sin(2*$p) + $c[2]*sin(4*$p) + $c[3]*sin(6*$p) + $c[4]*sin(8*$p); + my $b = $c[0]*$p + $c[1]*sin(2*$p) + $c[2]*sin(4*$p) + $c[3]*sin(6*$p) + $c[4]*sin(8*$p); - return $b; + return $b; } - =pod =head2 ign0028 @@ -370,21 +365,21 @@ sub ign0026 { =cut sub ign0028 { - my $e = shift; - # Jeux d'essai - #$e = 0.08199188998; + my $e = shift; - my @c; - $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; - $c[1] = -901.0/184320*$e**8 - 9.0/1024*$e**6 - 1.0/96*$e**4 + 1.0/8*$e**2; - $c[2] = -311.0/737280*$e**8 + 17.0/5120*$e**6 + 13.0/768*$e**4; - $c[3] = 899.0/430080*$e**8 + 61.0/15360*$e**6; - $c[4] = 49561.0/41287680*$e**8; + # Jeux d'essai + #$e = 0.08199188998; - return @c; + my @c; + $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; + $c[1] = -901.0/184320*$e**8 - 9.0/1024*$e**6 - 1.0/96*$e**4 + 1.0/8*$e**2; + $c[2] = -311.0/737280*$e**8 + 17.0/5120*$e**6 + 13.0/768*$e**4; + $c[3] = 899.0/430080*$e**8 + 61.0/15360*$e**6; + $c[4] = 49561.0/41287680*$e**8; -} + return @c; +} =pod @@ -411,34 +406,33 @@ sub ign0028 { =cut sub ign0030 { - my $lc = shift; - my $n = shift; - my $xs = shift; - my $ys = shift; - my $e = shift; - my $l = shift; - my $p = shift; + my $lc = shift; + my $n = shift; + my $xs = shift; + my $ys = shift; + my $e = shift; + my $l = shift; + my $p = shift; - # Jeux d'essai - #$lc = -0.05235987756; $n = 6375697.8456; $xs = 500000; $ys = 0; $e = 0.08248340004; $l = -0.0959931089; $p = 0.6065019151; +# Jeux d'essai +#$lc = -0.05235987756; $n = 6375697.8456; $xs = 500000; $ys = 0; $e = 0.08248340004; $l = -0.0959931089; $p = 0.6065019151; - my @c = ign0028($e); - my $L = ign0001($p,$e); - my $P = asin(sin($l - $lc)/cosh($L)); - my $LS = ign0001($P,0); - $L = atan(sinh($L)/cos($l - $lc)); + my @c = ign0028($e); + my $L = ign0001($p,$e); + my $P = asin(sin($l - $lc)/cosh($L)); + my $LS = ign0001($P,0); + $L = atan(sinh($L)/cos($l - $lc)); - my $z = Math::Complex->new($L,$LS); - my $Z = $n*$c[0]*$z + $n*($c[1]*sin(2*$z) + $c[2]*sin(4*$z) + $c[3]*sin(6*$z) + $c[4]*sin(8*$z)); + my $z = Math::Complex->new($L,$LS); + my $Z = $n*$c[0]*$z + $n*($c[1]*sin(2*$z) + $c[2]*sin(4*$z) + $c[3]*sin(6*$z) + $c[4]*sin(8*$z)); - my $x = $Z->Im() + $xs; - my $y = $Z->Re() + $ys; + my $x = $Z->Im() + $xs; + my $y = $Z->Re() + $ys; - return ($x,$y); + return ($x,$y); } - =pod =head2 ign0052 @@ -465,28 +459,27 @@ sub ign0030 { =cut sub ign0052 { - my $a = shift; - my $e = shift; - my $k0 = shift; - my $l0 = shift; - my $p0 = shift; - my $x0 = shift; - my $y0 = shift; - - # Jeux d'essai - #$a = 6377563.3963; $e = 0.08167337382; $k0 = 0.9996012; $l0 = -0.03490658504; $p0 = 0.85521133347; $x0 = 400000; $y0 = -100000; - - my $lc = $l0; - my $n = $k0*$a; - my $xs = $x0; - my @C = ign0025($e); - my $B = ign0026($p0,@C); - my $ys = $y0 - $n*$B; - - return ($lc,$n,$xs,$ys); + my $a = shift; + my $e = shift; + my $k0 = shift; + my $l0 = shift; + my $p0 = shift; + my $x0 = shift; + my $y0 = shift; + +# Jeux d'essai +#$a = 6377563.3963; $e = 0.08167337382; $k0 = 0.9996012; $l0 = -0.03490658504; $p0 = 0.85521133347; $x0 = 400000; $y0 = -100000; + + my $lc = $l0; + my $n = $k0*$a; + my $xs = $x0; + my @C = ign0025($e); + my $B = ign0026($p0,@C); + my $ys = $y0 - $n*$B; + + return ($lc,$n,$xs,$ys); } - =pod =head2 geo2utm @@ -508,32 +501,30 @@ sub ign0052 { =cut sub geo2utm { - my $p1 = shift; - my $l1 = shift; - my $D0 = 180/pi; - my ($F0,$K0,$P0,$L0,$X0,$Y0) = utmwgs($p1,$l1); - - # Définition des constantes - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + my $p1 = shift; + my $l1 = shift; + my $D0 = 180/pi; + my ($F0,$K0,$P0,$L0,$X0,$Y0) = utmwgs($p1,$l1); - # Conversion des données - $P0 /= $D0; - my $B1 = $A1*(1 - $F1); - my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); + # Définition des constantes + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement - $p1 = $p1/$D0; # Phi = Latitude (rad) - $l1 = $l1/$D0; # Lambda = Longitude (rad) + # Conversion des données + $P0 /= $D0; + my $B1 = $A1*(1 - $F1); + my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); - # Transformation Géographiques => UTM20 (WGS84) - my ($LC,$N,$XS,$YS) = ign0052($A1,$E1,$K0,$L0,$P0,$X0,$Y0); - my ($e,$n) = ign0030($LC,$N,$XS,$YS,$E1,$l1,$p1); + $p1 = $p1/$D0; # Phi = Latitude (rad) + $l1 = $l1/$D0; # Lambda = Longitude (rad) + # Transformation Géographiques => UTM20 (WGS84) + my ($LC,$N,$XS,$YS) = ign0052($A1,$E1,$K0,$L0,$P0,$X0,$Y0); + my ($e,$n) = ign0030($LC,$N,$XS,$YS,$E1,$l1,$p1); - return ($e,$n,$F0); + return ($e,$n,$F0); } - =pod =head2 geo2utml @@ -555,49 +546,49 @@ sub geo2utm { =cut sub geo2utml { - my $p1 = shift; - my $l1 = shift; - my $h1 = shift; - - # Définition des constantes - my $D0 = 180/pi; - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement - my $A2 = $UTM{ELLIPSOID_LOCAL_SEMIMAJOR_AXIS}; # HAYFORD 1909 demi grand axe - my $F2 = 1/$UTM{ELLIPSOID_LOCAL_INVERSE_FLATTENING}; # HAYFORD 1909 aplatissement - my ($F0,$K0,$P0,$L0,$X0,$Y0) = utm($p1,$l1); - - my $TX = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_X}; # HAYFORD 1909 => WGS84 : Translation X (m) - my $TY = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Y}; # HAYFORD 1909 => WGS84 : Translation Y (m) - my $TZ = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Z}; # HAYFORD 1909 => WGS84 : Translation Z (m) - my $D = $UTM{GEODETIC_LOCAL2WGS84_SCALE_FACTOR}; # HAYFORD 1909 => WGS84 : Facteur d'échelle (ppm) - my $RX = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_X}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation X (") - my $RY = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Y}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Y (") - my $RZ = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Z}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Z (") - - # Conversion des données - my $B1 = $A1*(1 - $F1); - my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); - my $B2 = $A2*(1 - $F2); - my $E2 = sqrt(($A2*$A2 - $B2*$B2)/($A2*$A2)); - - $p1 = $p1/$D0; # Phi = Latitude (rad) - $l1 = $l1/$D0; # Lambda = Longitude (rad) - - # Transformation Géographiques => Cartésiennes WGS84 - my ($x1,$y1,$z1) = ign0009($l1,$p1,$h1,$A1,$E1); - - # Transformation par similitude 3D à 7 paramètres WGS84 => HAYFORD 1909 - my ($x2,$y2,$z2) = ign0013b($TX,$TY,$TZ,$D,$RX,$RY,$RZ,$x1,$y1,$z1); - - # Transformation Cartésiennes => Géographiques (HAYFORD 1909) - my ($l2,$p2,$h2) = ign0012($x2,$y2,$z2,$A2,$E2); - - # Transformation Géographiques => UTM20 (HAYFORD 1909) - my ($LC,$N,$XS,$YS) = ign0052($A2,$E2,$K0,$L0,$P0,$X0,$Y0); - my ($e2,$n2) = ign0030($LC,$N,$XS,$YS,$E2,$l2,$p2); - - return ($e2,$n2,$F0); + my $p1 = shift; + my $l1 = shift; + my $h1 = shift; + + # Définition des constantes + my $D0 = 180/pi; + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + my $A2 = $UTM{ELLIPSOID_LOCAL_SEMIMAJOR_AXIS}; # HAYFORD 1909 demi grand axe + my $F2 = 1/$UTM{ELLIPSOID_LOCAL_INVERSE_FLATTENING}; # HAYFORD 1909 aplatissement + my ($F0,$K0,$P0,$L0,$X0,$Y0) = utm($p1,$l1); + + my $TX = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_X}; # HAYFORD 1909 => WGS84 : Translation X (m) + my $TY = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Y}; # HAYFORD 1909 => WGS84 : Translation Y (m) + my $TZ = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Z}; # HAYFORD 1909 => WGS84 : Translation Z (m) + my $D = $UTM{GEODETIC_LOCAL2WGS84_SCALE_FACTOR}; # HAYFORD 1909 => WGS84 : Facteur d'échelle (ppm) + my $RX = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_X}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation X (") + my $RY = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Y}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Y (") + my $RZ = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Z}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Z (") + + # Conversion des données + my $B1 = $A1*(1 - $F1); + my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); + my $B2 = $A2*(1 - $F2); + my $E2 = sqrt(($A2*$A2 - $B2*$B2)/($A2*$A2)); + + $p1 = $p1/$D0; # Phi = Latitude (rad) + $l1 = $l1/$D0; # Lambda = Longitude (rad) + + # Transformation Géographiques => Cartésiennes WGS84 + my ($x1,$y1,$z1) = ign0009($l1,$p1,$h1,$A1,$E1); + + # Transformation par similitude 3D à 7 paramètres WGS84 => HAYFORD 1909 + my ($x2,$y2,$z2) = ign0013b($TX,$TY,$TZ,$D,$RX,$RY,$RZ,$x1,$y1,$z1); + + # Transformation Cartésiennes => Géographiques (HAYFORD 1909) + my ($l2,$p2,$h2) = ign0012($x2,$y2,$z2,$A2,$E2); + + # Transformation Géographiques => UTM20 (HAYFORD 1909) + my ($LC,$N,$XS,$YS) = ign0052($A2,$E2,$K0,$L0,$P0,$X0,$Y0); + my ($e2,$n2) = ign0030($LC,$N,$XS,$YS,$E2,$l2,$p2); + + return ($e2,$n2,$F0); } =pod @@ -609,25 +600,26 @@ Returns UTM WGS84 parameters (zone, false easting and northing) from latitude an =cut sub utmwgs { - my $p1 = shift; - my $l1 = shift; - - my $D0 = 180/pi; - my $F0 = $UTM{UTM_ZONE}; # utm zone - my $K0 = $UTM{UTM_SCALE_FACTOR}; # scale factor (0.9996) - if ($F0 le 0) { - #$F0 = int(($l1 + 183)/6); - $F0 = int(($l1 + 183)/6 + .5); - } - my $L0 = (6*$F0 - 183)/$D0; # longitude origin (rad) - my $P0 = 0; # latitude origin (rad) / UTM20 = 0 - my $X0 = 500000; # false easting - my $Y0 = 0; # false northing - if ($p1 lt 0) { - $Y0 = 10000000; - } - - return ($F0,$K0,$P0,$L0,$X0,$Y0); + my $p1 = shift; + my $l1 = shift; + + my $D0 = 180/pi; + my $F0 = $UTM{UTM_ZONE}; # utm zone + my $K0 = $UTM{UTM_SCALE_FACTOR}; # scale factor (0.9996) + if ($F0 le 0) { + + #$F0 = int(($l1 + 183)/6); + $F0 = int(($l1 + 183)/6 + .5); + } + my $L0 = (6*$F0 - 183)/$D0; # longitude origin (rad) + my $P0 = 0; # latitude origin (rad) / UTM20 = 0 + my $X0 = 500000; # false easting + my $Y0 = 0; # false northing + if ($p1 lt 0) { + $Y0 = 10000000; + } + + return ($F0,$K0,$P0,$L0,$X0,$Y0); } =pod @@ -639,25 +631,25 @@ returns UTM parameters (zone, false easting and northing) from latitude and long =cut sub utm { - my $p1 = shift; - my $l1 = shift; - - my $D0 = 180/pi; - #my $F0 = int(($l1 + 183)/6); # UTM zone - my $F0 = int(($l1 + 183)/6 + .5); # UTM zone - my $K0 = $UTM{UTM_LOCAL_SCALE_FACTOR}; # scale factor - my $L0 = $UTM{UTM_LOCAL_MERIDIAN_ORIGIN}/$D0; # longitude origin (rad) - my $P0 = 0; # latitude origin (rad) / UTM20 = 0 - my $X0 = $UTM{UTM_LOCAL_FALSE_EASTING}; # false easting - my $Y0 = 0; # false northing - if ($p1 lt 0) { - $Y0 = 10000000; - } - - return ($F0,$K0,$P0,$L0,$X0,$Y0); + my $p1 = shift; + my $l1 = shift; + + my $D0 = 180/pi; + + #my $F0 = int(($l1 + 183)/6); # UTM zone + my $F0 = int(($l1 + 183)/6 + .5); # UTM zone + my $K0 = $UTM{UTM_LOCAL_SCALE_FACTOR}; # scale factor + my $L0 = $UTM{UTM_LOCAL_MERIDIAN_ORIGIN}/$D0; # longitude origin (rad) + my $P0 = 0; # latitude origin (rad) / UTM20 = 0 + my $X0 = $UTM{UTM_LOCAL_FALSE_EASTING}; # false easting + my $Y0 = 0; # false northing + if ($p1 lt 0) { + $Y0 = 10000000; + } + + return ($F0,$K0,$P0,$L0,$X0,$Y0); } - =pod =head2 geo2cart @@ -668,27 +660,25 @@ sub utm { =cut sub geo2cart { - my $p1 = shift; - my $l1 = shift; - my $h1 = shift; - my $D0 = 180/pi; + my $p1 = shift; + my $l1 = shift; + my $h1 = shift; + my $D0 = 180/pi; - # Définition des constantes - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + # Définition des constantes + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement - # Conversion des données - my $B1 = $A1*(1 - $F1); - my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); + # Conversion des données + my $B1 = $A1*(1 - $F1); + my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); - # Transformation Géographiques (WGS84) => géocentriques - my ($x,$y,$z) = ign0009($l1/$D0,$p1/$D0,$h1,$A1,$E1); + # Transformation Géographiques (WGS84) => géocentriques + my ($x,$y,$z) = ign0009($l1/$D0,$p1/$D0,$h1,$A1,$E1); - - return ($x,$y,$z); + return ($x,$y,$z); } - =pod =head2 greatcircle @@ -702,22 +692,22 @@ sub geo2cart { =cut sub greatcircle { - my $k = pi/180; + my $k = pi/180; - my $lat1 = shift; - my $lon1 = shift; - my $lat2 = shift; - my $lon2 = shift; + my $lat1 = shift; + my $lon1 = shift; + my $lat2 = shift; + my $lon2 = shift; - my $dlat = ($lat2 - $lat1)*$k; - my $dlon = ($lon2 - $lon1)*$k; + my $dlat = ($lat2 - $lat1)*$k; + my $dlon = ($lon2 - $lon1)*$k; - my $rearth = 6371; # volumetric Earth radius (in km) + my $rearth = 6371; # volumetric Earth radius (in km) - my $dist = $rearth*2*asin(sqrt(sin($dlat/2)**2 + cos($lat1*$k)*cos($lat2*$k)*sin($dlon/2)**2)); - my $bear = atan2(sin($dlon)*cos($lat2*$k),cos($lat1*$k)*sin($lat2*$k) - sin($lat1*$k)*cos($lat2*$k)*cos($dlon))/$k; + my $dist = $rearth*2*asin(sqrt(sin($dlat/2)**2 + cos($lat1*$k)*cos($lat2*$k)*sin($dlon/2)**2)); + my $bear = atan2(sin($dlon)*cos($lat2*$k),cos($lat1*$k)*sin($lat2*$k) - sin($lat1*$k)*cos($lat2*$k)*cos($dlon))/$k; - return $dist, $bear; + return $dist, $bear; } =pod @@ -728,15 +718,15 @@ sub greatcircle { # degrees from North, clockwise =cut + sub compass { - my @nesw = ('N','NNE','NE','ENE','E','ESE','SE','SSE','S','SSW','SW','WSW','W','WNW','NW','NNW'); - my $az = shift; - $az = ($az*16/360)%16; - return $nesw[$az]; + my @nesw = ('N','NNE','NE','ENE','E','ESE','SE','SSE','S','SSW','SW','WSW','W','WNW','NW','NNW'); + my $az = shift; + $az = ($az*16/360)%16; + return $nesw[$az]; } - =pod =head2 KMLfeed @@ -748,18 +738,18 @@ sub compass { sub KMLfeed { - my $url = shift; - my ($lat, $lon, $alt, $date); + my $url = shift; + my ($lat, $lon, $alt, $date); - if ($url =~ /^http/) { - my @kml = qx(curl -s "$url" | $WEBOBS{XML2_PRGM}); - my $root = '/q:quakeml/eventParameters/event'; - my $pos = findvalue("$root/Point/coordinates=",\@kml); - ($lon,$lat,$alt) = split(/,/,$pos); - $date = findvalue("$root/TimeStamp/when=",\@kml); - } + if ($url =~ /^http/) { + my @kml = qx(curl -s "$url" | $WEBOBS{XML2_PRGM}); + my $root = '/q:quakeml/eventParameters/event'; + my $pos = findvalue("$root/Point/coordinates=",\@kml); + ($lon,$lat,$alt) = split(/,/,$pos); + $date = findvalue("$root/TimeStamp/when=",\@kml); + } - return $lat, $lon, $alt, $date; + return $lat, $lon, $alt, $date; } 1; diff --git a/CODE/perl/lib/QML.pm b/CODE/perl/lib/QML.pm index a27055a1..824de999 100644 --- a/CODE/perl/lib/QML.pm +++ b/CODE/perl/lib/QML.pm @@ -15,82 +15,83 @@ use WebObs::XML2; #-------------------------------------------------------------------------------------------------------------------------------------- # qmlvalues: returns origin and magmitude preferred values from XML2 arrayd sub qmlorigin { - my $file = $_[0]; - my %qml; + my $file = $_[0]; + my %qml; - if (-e $file) { - my @xml2 = qx($WEBOBS{XML2_PRGM} < $file); + if (-e $file) { + my @xml2 = qx($WEBOBS{XML2_PRGM} < $file); - my $root = '/seiscomp/EventParameters'; - my $evt_origID = findvalue("$root/event/preferredOriginID=",\@xml2); - my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); - my $evt_magID = findvalue("$root/event/preferredMagnitudeID=",\@xml2); - my @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@origin); - $qml{time} = findvalue('/time/value=',\@origin); - $qml{rms} = findvalue('/quality/standardError=',\@origin); - $qml{latitude} = findvalue('/latitude/value=',\@origin); - $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); - $qml{longitude} = findvalue('/longitude/value=',\@origin); - $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); - $qml{depth} = findvalue('/depth/value=',\@origin); - $qml{depthError} = findvalue('/depth/uncertainty=',\@origin); - $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); - $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); - $qml{mode} = findvalue('/evaluationMode=',\@origin); - $qml{status} = findvalue('/evaluationStatus=',\@origin); - $qml{method} = findvalue('/methodID=',\@origin); - $qml{model} = findvalue('/earthModelID=',\@origin); - $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); - $qml{magnitude} = findvalue('/magnitude/value=',\@magnitude); - $qml{magtype} = findvalue('/type=',\@magnitude); - $qml{type} = findvalue("$root/event/type=",\@xml2); - } + my $root = '/seiscomp/EventParameters'; + my $evt_origID = findvalue("$root/event/preferredOriginID=",\@xml2); + my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); + my $evt_magID = findvalue("$root/event/preferredMagnitudeID=",\@xml2); + my @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@origin); + $qml{time} = findvalue('/time/value=',\@origin); + $qml{rms} = findvalue('/quality/standardError=',\@origin); + $qml{latitude} = findvalue('/latitude/value=',\@origin); + $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); + $qml{longitude} = findvalue('/longitude/value=',\@origin); + $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); + $qml{depth} = findvalue('/depth/value=',\@origin); + $qml{depthError} = findvalue('/depth/uncertainty=',\@origin); + $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); + $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); + $qml{mode} = findvalue('/evaluationMode=',\@origin); + $qml{status} = findvalue('/evaluationStatus=',\@origin); + $qml{method} = findvalue('/methodID=',\@origin); + $qml{model} = findvalue('/earthModelID=',\@origin); + $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); + $qml{magnitude} = findvalue('/magnitude/value=',\@magnitude); + $qml{magtype} = findvalue('/type=',\@magnitude); + $qml{type} = findvalue("$root/event/type=",\@xml2); + } - return %qml; + return %qml; } #-------------------------------------------------------------------------------------------------------------------------------------- # qmlvalues: returns origin and magnitude preferred values from XML2 arrayd sub qmlfdsn { - my $url = $_[0]; - my %qml; - my @x; + my $url = $_[0]; + my %qml; + my @x; - my @xml2 = qx(curl -s -S --globoff "$url" | $WEBOBS{XML2_PRGM}); + my @xml2 = qx(curl -s -S --globoff "$url" | $WEBOBS{XML2_PRGM}); - my $root = '/q:quakeml/eventParameters/event'; - my $evt_origID = findvalue("$root/preferredOriginID=",\@xml2); - my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); - my $evt_magID = findvalue("$root/preferredMagnitudeID=",\@xml2); - my @magnitude = findnode("$root/magnitude","/\@publicID=$evt_magID",\@xml2); - $qml{time} = findvalue('/time/value=',\@origin); - $qml{rms} = findvalue('/quality/standardError=',\@origin); - $qml{latitude} = findvalue('/latitude/value=',\@origin); - $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); - $qml{longitude} = findvalue('/longitude/value=',\@origin); - $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); - $qml{depth} = findvalue('/depth/value=',\@origin)/1000; - $qml{depthError} = findvalue('/depth/uncertainty=',\@origin)/1000; - $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); - $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); - $qml{mode} = findvalue('/evaluationMode=',\@origin); - $qml{status} = findvalue('/evaluationStatus=',\@origin); + my $root = '/q:quakeml/eventParameters/event'; + my $evt_origID = findvalue("$root/preferredOriginID=",\@xml2); + my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); + my $evt_magID = findvalue("$root/preferredMagnitudeID=",\@xml2); + my @magnitude = findnode("$root/magnitude","/\@publicID=$evt_magID",\@xml2); + $qml{time} = findvalue('/time/value=',\@origin); + $qml{rms} = findvalue('/quality/standardError=',\@origin); + $qml{latitude} = findvalue('/latitude/value=',\@origin); + $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); + $qml{longitude} = findvalue('/longitude/value=',\@origin); + $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); + $qml{depth} = findvalue('/depth/value=',\@origin)/1000; + $qml{depthError} = findvalue('/depth/uncertainty=',\@origin)/1000; + $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); + $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); + $qml{mode} = findvalue('/evaluationMode=',\@origin); + $qml{status} = findvalue('/evaluationStatus=',\@origin); - # for methodID and earthModelID takes only the last string to remove prefix - #$qml{method} = findvalue('/methodID=',\@origin); - @x = split(/\//,findvalue('/methodID=',\@origin)); - $qml{method} = $x[-1]; - #$qml{model} = findvalue('/earthModelID=',\@origin); - @x = split(/\//,findvalue('/earthModelID=',\@origin)); - $qml{model} = $x[-1]; + # for methodID and earthModelID takes only the last string to remove prefix + #$qml{method} = findvalue('/methodID=',\@origin); + @x = split(/\//,findvalue('/methodID=',\@origin)); + $qml{method} = $x[-1]; - $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); - $qml{magnitude} = findvalue('/mag/value=',\@magnitude); - $qml{magtype} = findvalue('/type=',\@magnitude); - $qml{type} = findvalue("$root/type=",\@xml2); - $qml{comment} = findvalue("$root/description/text=",\@xml2); + #$qml{model} = findvalue('/earthModelID=',\@origin); + @x = split(/\//,findvalue('/earthModelID=',\@origin)); + $qml{model} = $x[-1]; - return %qml; + $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); + $qml{magnitude} = findvalue('/mag/value=',\@magnitude); + $qml{magtype} = findvalue('/type=',\@magnitude); + $qml{type} = findvalue("$root/type=",\@xml2); + $qml{comment} = findvalue("$root/description/text=",\@xml2); + + return %qml; } 1; diff --git a/CODE/perl/lib/Scheduler.pm b/CODE/perl/lib/Scheduler.pm index 5d1cae63..e324a9c1 100644 --- a/CODE/perl/lib/Scheduler.pm +++ b/CODE/perl/lib/Scheduler.pm @@ -44,71 +44,72 @@ $VERSION = "1.00"; # Read the scheduler configuration my %SCHEDULER_CONF = readCfg($WEBOBS{'CONF_SCHEDULER'}); - sub scheduler_client { - # Submit a command to the scheduler process listening on UDP. - # - # @parameters: - # $opts (hash reference) - # A reference to a hash defining the following options (missing options - # use sensible defaults): - # 'host' : hostname where the scheduler is listening - # (default: 'localhost') - # 'port' : UDP port used by the scheduler (default: $SCHEDULER_CONF{'PORT'}) - # 'max_length' : maximum number of characters read while reading the - # scheduler response (default: $SCHEDULER_CONF{'SOCKET_MAXLEN'}) - # 'timeout' : timeout to use while contacting the scheduler - # (default: 5) - # $cmd (string) - # The command to be submitted to the scheduler. - # - my $cmd = shift; - my $opts = shift || {}; - my ($response, $error); - local $| = 1; # autoflush - - if (not $cmd) { - return ("", "empty command: nothing to send\n"); - } - - my %opts = ( - # Default values first - 'host' => $SCHEDULER_CONF{'LISTEN_ADDR'} || 'localhost', - 'port' => $SCHEDULER_CONF{'PORT'}, - 'max_length' => $SCHEDULER_CONF{'SOCKET_MAXLEN'}, - 'timeout' => 5, - # Override with values from argument - %$opts, - ); - - my $socket = IO::Socket::INET->new( - 'PeerAddr' => $opts{'host'}, - 'PeerPort' => $opts{'port'}, - 'Proto' => 'udp', - ); - if (not $socket) { - return ("", "unable to create socket: $!"); - } - - eval { - local $SIG{'ALRM'} = sub { die 'Timed Out'; }; - alarm $opts{'timeout'}; - if ($socket->send($cmd)) { - if (not $socket->recv($response, $opts{'max_length'})) { - $error = "failed to read answer: $!"; - } - } else { - $error = "failed to send request: $!"; - } - }; - alarm 0; - if ($@ && $@ =~ /Timed Out/ ) { - $error = "connection timeout after $opts{'timeout'}s"; - } - $socket->close(); - return ($response, $error); -} +# Submit a command to the scheduler process listening on UDP. +# +# @parameters: +# $opts (hash reference) +# A reference to a hash defining the following options (missing options +# use sensible defaults): +# 'host' : hostname where the scheduler is listening +# (default: 'localhost') +# 'port' : UDP port used by the scheduler (default: $SCHEDULER_CONF{'PORT'}) +# 'max_length' : maximum number of characters read while reading the +# scheduler response (default: $SCHEDULER_CONF{'SOCKET_MAXLEN'}) +# 'timeout' : timeout to use while contacting the scheduler +# (default: 5) +# $cmd (string) +# The command to be submitted to the scheduler. +# + my $cmd = shift; + my $opts = shift || {}; + my ($response, $error); + local $| = 1; # autoflush + + if (not $cmd) { + return ("", "empty command: nothing to send\n"); + } + + my %opts = ( + + # Default values first + 'host' => $SCHEDULER_CONF{'LISTEN_ADDR'} || 'localhost', + 'port' => $SCHEDULER_CONF{'PORT'}, + 'max_length' => $SCHEDULER_CONF{'SOCKET_MAXLEN'}, + 'timeout' => 5, + + # Override with values from argument + %$opts, + ); + + my $socket = IO::Socket::INET->new( + 'PeerAddr' => $opts{'host'}, + 'PeerPort' => $opts{'port'}, + 'Proto' => 'udp', + ); + if (not $socket) { + return ("", "unable to create socket: $!"); + } + + eval { + local $SIG{'ALRM'} = sub { die 'Timed Out'; }; + alarm $opts{'timeout'}; + if ($socket->send($cmd)) { + if (not $socket->recv($response, $opts{'max_length'})) { + $error = "failed to read answer: $!"; + } + } else { + $error = "failed to send request: $!"; + } + }; + alarm 0; + if ($@ && $@ =~ /Timed Out/ ) { + $error = "connection timeout after $opts{'timeout'}s"; + } + $socket->close(); + return ($response, $error); +} 1; diff --git a/CODE/perl/lib/Search.pm b/CODE/perl/lib/Search.pm index cd3d36bb..d592c2f6 100644 --- a/CODE/perl/lib/Search.pm +++ b/CODE/perl/lib/Search.pm @@ -22,131 +22,136 @@ use CGI::Carp qw(fatalsToBrowser set_message); set_message(\&webobs_cgi_msg); sub searchform { - my $searchW = my $entireW = my $majmin = my $extend = my $year1 = my $month1 = my $day1 = my $year2 = my $month2 = my $day2 = ""; - my $netinfo = my $stainfo = my $evtinfo = my $clbinfo = "OK"; - my $anneeActuelle = qx(date +\%Y); chomp($anneeActuelle); - my @listeAnnees = reverse($WEBOBS{BIG_BANG}..$anneeActuelle); - my $SF = ""; - $SF = "
    \n"; - $SF .= ""; - $SF .= ""; - $SF .= ""; - $SF .= "\n"; - $SF .= ""; - - $SF .= "
    "; - $SF .= "$__{'Search in selected grids below'}\n"; - $SF .= "\n"; - $SF .= "$__{'Word/Expression'}: \n"; - $SF .= ""; - $SF .= ""; - $SF .= ""; - - $SF .= "
    "; - $SF .= "$__{'Node info'}\n"; - $SF .= "CLB\n"; - $SF .= "$__{'Node events'}\n"; - $SF .= "
    "; - $SF .= ""; - $SF .= "\n\n\n
    "; - $SF .= ""; - $SF .= "\n\n    		"; - $SF .= "$__{'Entire word'}\n"; - $SF .= "$__{'Upper/lower case'}\n"; - $SF .= "$__{'Display Entire text'}
    \n"; - $SF .= "
    "; - return $SF; + my $searchW = my $entireW = my $majmin = my $extend = my $year1 = my $month1 = my $day1 = my $year2 = my $month2 = my $day2 = ""; + my $netinfo = my $stainfo = my $evtinfo = my $clbinfo = "OK"; + my $anneeActuelle = qx(date +\%Y); chomp($anneeActuelle); + my @listeAnnees = reverse($WEBOBS{BIG_BANG}..$anneeActuelle); + my $SF = ""; + $SF = "
    \n"; + $SF .= ""; + $SF .= ""; + $SF .= ""; + $SF .= "\n"; + $SF .= ""; + + $SF .= "
    "; + $SF .= "$__{'Search in selected grids below'}\n"; + $SF .= "\n"; + $SF .= "$__{'Word/Expression'}: \n"; + $SF .= ""; + $SF .= ""; + $SF .= ""; + + $SF .= "
    "; + $SF .= "$__{'Node info'}\n"; + $SF .= "CLB\n"; + $SF .= "$__{'Node events'}\n"; + $SF .= "
    "; + $SF .= ""; + $SF .= "\n\n\n
    "; + $SF .= ""; + $SF .= "\n\n    		"; + $SF .= "$__{'Entire word'}\n"; + $SF .= "$__{'Upper/lower case'}\n"; + $SF .= "$__{'Display Entire text'}
    \n"; + $SF .= "
    "; + return $SF; } sub searchpopup { - my ($tody,$todm,$todd) = split(/-/,qx(date +'%F')); chomp($todd); - my @validYears = reverse($WEBOBS{BIG_BANG}..$tody); - my $SP = ""; - $SP .= "
    "; - $SP .= "
    "; - my $sfstyle = "style=\"border: none; background: transparent; float: none; font: inherit; margin: 0; width: auto\""; - $SP .= "

    Search {".""."} for:

    "; - $SP .= ""; - $SP .= " \n"; - $SP .= "

    "; - - $SP .= "
    "; - $SP .= ""; - $SP .= "\n\n"; - $SP .= "

    "; - - $SP .= ""; - $SP .= "\n\n"; - $SP .= "

    "; - - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= "

    "; - - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= "

    "; - $SP .= "
    "; - - $SP .= "

    "; - $SP .= ""; - $SP .= ""; - $SP .= "

    "; - $SP .= "
    "; - return $SP; + my ($tody,$todm,$todd) = split(/-/,qx(date +'%F')); chomp($todd); + my @validYears = reverse($WEBOBS{BIG_BANG}..$tody); + my $SP = ""; + $SP .= "
    "; + $SP .= "
    "; + my $sfstyle = "style=\"border: none; background: transparent; float: none; font: inherit; margin: 0; width: auto\""; + $SP .= "

    Search {".""."} for:

    "; + $SP .= ""; + $SP .= " \n"; + $SP .= "

    "; + + $SP .= "
    "; + $SP .= ""; + $SP .= "\n\n"; + $SP .= "

    "; + + $SP .= ""; + $SP .= "\n\n"; + $SP .= "

    "; + + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= "

    "; + + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= "

    "; + $SP .= "
    "; + + $SP .= "

    "; + $SP .= ""; + $SP .= ""; + $SP .= "

    "; + $SP .= "
    "; + return $SP; } - 1; __END__ diff --git a/CODE/perl/lib/Suds.pm b/CODE/perl/lib/Suds.pm index 0ad7d5bc..a973fdd3 100644 --- a/CODE/perl/lib/Suds.pm +++ b/CODE/perl/lib/Suds.pm @@ -25,11 +25,11 @@ require WebObs::Config; sub demain { - my $annee = shift; - my $mois = shift; - my $jour = shift; - ($annee,$mois,$jour) = split(/-/,qx(date -d "$annee-$mois-$jour 1 day" +\%Y-\%m-\%d|tr -d '\n')); - return ($annee,$mois,$jour); + my $annee = shift; + my $mois = shift; + my $jour = shift; + ($annee,$mois,$jour) = split(/-/,qx(date -d "$annee-$mois-$jour 1 day" +\%Y-\%m-\%d|tr -d '\n')); + return ($annee,$mois,$jour); } =pod @@ -40,14 +40,14 @@ sub demain sub minute_suivante { - my $annee = shift; - my $mois = shift; - my $jour = shift; - my $heure = shift; - my $minute = shift; - my $seconde = shift; - ($annee,$mois,$jour,$heure,$minute,$seconde) = split(/-/,qx(date -d "$annee-$mois-$jour $heure:$minute:$seconde 1 minute" +\%Y-\%m-\%d-\%H-\%M-\%S|tr -d '\n')); - return ($annee,$mois,$jour,$heure,$minute,$seconde); + my $annee = shift; + my $mois = shift; + my $jour = shift; + my $heure = shift; + my $minute = shift; + my $seconde = shift; + ($annee,$mois,$jour,$heure,$minute,$seconde) = split(/-/,qx(date -d "$annee-$mois-$jour $heure:$minute:$seconde 1 minute" +\%Y-\%m-\%d-\%H-\%M-\%S|tr -d '\n')); + return ($annee,$mois,$jour,$heure,$minute,$seconde); } =pod @@ -58,14 +58,17 @@ sub minute_suivante sub dateFichierSuds { - my $suds = shift; - if (length(basename($suds)) == 12) { - #IASPEI - } elsif (length(basename($suds)) == 19) { - #SUDS2 - } elsif (length(basename($suds)) == 21) { - #SUDS2 avec suffixe - } + my $suds = shift; + if (length(basename($suds)) == 12) { + + #IASPEI + } elsif (length(basename($suds)) == 19) { + + #SUDS2 + } elsif (length(basename($suds)) == 21) { + + #SUDS2 avec suffixe + } } =pod @@ -76,31 +79,33 @@ sub dateFichierSuds sub fichiersSudsSuivants { - my $suds = shift; - my $nb_suds = shift; - my @liste_suds; - if (length(basename($suds)) == 12) { - # IASPEI - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; - my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x3 a2 a2 a2 a2 x a3",$suds); - my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); - my $chemin_date="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4$mois$jour/"; - my $chemin_lendemain="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4lendemain$moislendemain$jourlendemain"; - ( -d $chemin_lendemain ) or $chemin_lendemain=""; - $nb_suds--; - push(@liste_suds,split(/\n/, qx(find $chemin_date $chemin_lendemain -type f -print|sort|fgrep -A$nb_suds $suds))); - } elsif (length(basename($suds)) == 19) { - # SUDS2 - my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; - push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); - for(my $i = 1; $i < $nb_suds; $i++) { - my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds); - ($annee4, $mois, $jour, $heure, $minute, $seconde) = minute_suivante($annee4, $mois, $jour, $heure, $minute, $seconde); - $suds = "/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois${jour}_$heure$minute$seconde.$extension"; - push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); - } - } - return @liste_suds; + my $suds = shift; + my $nb_suds = shift; + my @liste_suds; + if (length(basename($suds)) == 12) { + + # IASPEI + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; + my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x3 a2 a2 a2 a2 x a3",$suds); + my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); + my $chemin_date="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4$mois$jour/"; + my $chemin_lendemain="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4lendemain$moislendemain$jourlendemain"; + ( -d $chemin_lendemain ) or $chemin_lendemain=""; + $nb_suds--; + push(@liste_suds,split(/\n/, qx(find $chemin_date $chemin_lendemain -type f -print|sort|fgrep -A$nb_suds $suds))); + } elsif (length(basename($suds)) == 19) { + + # SUDS2 + my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; + push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); + for(my $i = 1; $i < $nb_suds; $i++) { + my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds); + ($annee4, $mois, $jour, $heure, $minute, $seconde) = minute_suivante($annee4, $mois, $jour, $heure, $minute, $seconde); + $suds = "/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois${jour}_$heure$minute$seconde.$extension"; + push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); + } + } + return @liste_suds; } =pod @@ -111,14 +116,14 @@ sub fichiersSudsSuivants sub fusion_suds { - my $suds = shift; - my $nb_suds = shift; - my @liste_suds = fichiersSudsSuivants($suds,$nb_suds); - my $dest_dir = qx(mktemp -d -p /tmp fusion_suds.XXXXXXXXXX); - chomp($dest_dir); - my $dest = $dest_dir."/".basename($suds); - print qx($WebObs::WEBOBS{RACINE_TOOLS_SHELLS}/sudsjoin_multiple $dest @liste_suds); - return ($dest_dir,$dest); + my $suds = shift; + my $nb_suds = shift; + my @liste_suds = fichiersSudsSuivants($suds,$nb_suds); + my $dest_dir = qx(mktemp -d -p /tmp fusion_suds.XXXXXXXXXX); + chomp($dest_dir); + my $dest = $dest_dir."/".basename($suds); + print qx($WebObs::WEBOBS{RACINE_TOOLS_SHELLS}/sudsjoin_multiple $dest @liste_suds); + return ($dest_dir,$dest); } =pod @@ -152,131 +157,131 @@ renvoi le nom du fichier SUDS a partir du nom de l'image Sefran2 sub imagesSudsMC { - my $suds_debut = shift; - my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES} - 2; - - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; - ($annee4, $mois, $jour, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut); - - my $annee2 = substr($annee4,2,2); - my $racineImage = $annee2.$mois.$jour.$heure.$minute.$seconde; - my $image = $racineImage.".png"; - my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); - my $repDate = $annee4.$mois.$jour; - my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; - - my $pathSrcImg="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; - my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; - ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; - - my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN_RACINE}/"); - my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; - return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); + my $suds_debut = shift; + my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES} - 2; + + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; + ($annee4, $mois, $jour, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut); + + my $annee2 = substr($annee4,2,2); + my $racineImage = $annee2.$mois.$jour.$heure.$minute.$seconde; + my $image = $racineImage.".png"; + my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); + my $repDate = $annee4.$mois.$jour; + my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; + + my $pathSrcImg="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; + my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; + ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; + + my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN_RACINE}/"); + my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; + return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); } sub fichierSudsImage { - my $imageSuds = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; - my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; - my $var = "PATH_SOURCE_SISMO_".$reseau; - return "$WebObs::WEBOBS{$var}/$annee4$mois$jour/$jour$heure$minute$seconde.$reseau"; + my $imageSuds = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; + my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; + my $var = "PATH_SOURCE_SISMO_".$reseau; + return "$WebObs::WEBOBS{$var}/$annee4$mois$jour/$jour$heure$minute$seconde.$reseau"; } sub fichiersSuds { - my @imagesSuds = @_; - my @fichiersSuds; - for (@imagesSuds) { - push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSudsImage($_)); - } - return @fichiersSuds; + my @imagesSuds = @_; + my @fichiersSuds; + for (@imagesSuds) { + push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSudsImage($_)); + } + return @fichiersSuds; } sub infosSuds { - my $imageSuds = shift; - my $id_fichier = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; - my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; - return "Date (début) : $annee4/$mois/$jour
    Heure (début) : $heure:$minute:$seconde
    Réseau : $reseau
    Fichier n° : $id_fichier"; + my $imageSuds = shift; + my $id_fichier = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; + my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; + return "Date (début) : $annee4/$mois/$jour
    Heure (début) : $heure:$minute:$seconde
    Réseau : $reseau
    Fichier n° : $id_fichier"; } sub imageVoiesSefran { - my $suds_debut = shift; - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; - my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; - ($annee4GU, $moisGU, $jourGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut; - my $repDate = $annee4GU.$moisGU.$jourGU; - return "$repDate/$WebObs::WEBOBS{SEFRAN_VOIES_IMAGE}"; + my $suds_debut = shift; + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; + my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; + ($annee4GU, $moisGU, $jourGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut; + my $repDate = $annee4GU.$moisGU.$jourGU; + return "$repDate/$WebObs::WEBOBS{SEFRAN_VOIES_IMAGE}"; } sub imagesSuds2MC { - my $suds_debut = shift; - my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES_SEFRAN2} - 2; - my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; - - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; - ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds_debut); - - my $annee2 = substr($annee4,2,2); - my $racineImage = $annee4.$mois.$jour.$heure.$minute.$seconde; - my $image = $racineImage.".png"; - my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); - my $repDate = $annee4.$mois.$jour; - my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; - - my $pathSrcImg="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; - my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; - ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; - - my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN2_RACINE}/"); - my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; - return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); + my $suds_debut = shift; + my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES_SEFRAN2} - 2; + my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; + + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; + ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds_debut); + + my $annee2 = substr($annee4,2,2); + my $racineImage = $annee4.$mois.$jour.$heure.$minute.$seconde; + my $image = $racineImage.".png"; + my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); + my $repDate = $annee4.$mois.$jour; + my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; + + my $pathSrcImg="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; + my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; + ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; + + my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN2_RACINE}/"); + my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; + return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); } sub fichierSuds2Image { - my $imageSuds = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; - return "$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois$jour\_$heure$minute$seconde.$reseau"; + my $imageSuds = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; + return "$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois$jour\_$heure$minute$seconde.$reseau"; } sub fichiersSuds2 { - my @imagesSuds = @_; - my @fichiersSuds; - for (@imagesSuds) { - push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSuds2Image($_)); - } - return @fichiersSuds; + my @imagesSuds = @_; + my @fichiersSuds; + for (@imagesSuds) { + push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSuds2Image($_)); + } + return @fichiersSuds; } sub infosSuds2 { - my $imageSuds = shift; - my $id_fichier = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; - return "Date (début) : $annee4-$mois-$jour
    Heure (début) : $heure:$minute:$seconde
    Réseau : $reseau
    Fichier n° : $id_fichier"; + my $imageSuds = shift; + my $id_fichier = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; + return "Date (début) : $annee4-$mois-$jour
    Heure (début) : $heure:$minute:$seconde
    Réseau : $reseau
    Fichier n° : $id_fichier"; } sub imageVoiesSefran2 { - my $suds_debut = shift; - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_MIX})+11; - my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; - ($annee4GU, $moisGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 x a3",$suds_debut; - my $repDate = $annee4GU.$moisGU.$jourGU; - return "$repDate/$WebObs::WEBOBS{SEFRAN2_VOIES_IMAGE}"; + my $suds_debut = shift; + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_MIX})+11; + my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; + ($annee4GU, $moisGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 x a3",$suds_debut; + my $repDate = $annee4GU.$moisGU.$jourGU; + return "$repDate/$WebObs::WEBOBS{SEFRAN2_VOIES_IMAGE}"; } 1; diff --git a/CODE/perl/lib/Users.pm b/CODE/perl/lib/Users.pm index d9bd0b46..282f3e38 100644 --- a/CODE/perl/lib/Users.pm +++ b/CODE/perl/lib/Users.pm @@ -95,9 +95,9 @@ $VERSION = "1.00"; refreshUsers(); if ((!defined($ENV{"REMOTE_USER"})) or ($ENV{"REMOTE_USER"} eq "") or (!defined($USERS{$ENV{"REMOTE_USER"}}))) { - $CLIENT = "guest"; + $CLIENT = "guest"; } else { - $CLIENT = $ENV{"REMOTE_USER"}; + $CLIENT = $ENV{"REMOTE_USER"}; } our @validtbls = ($WEBOBS{SQL_TABLE_AUTHVIEWS}, $WEBOBS{SQL_TABLE_AUTHPROCS}, $WEBOBS{SQL_TABLE_AUTHFORMS}, $WEBOBS{SQL_TABLE_AUTHMISC}, $WEBOBS{SQL_TABLE_AUTHWIKIS}); @@ -113,9 +113,9 @@ Reloads %USERS and %USERIDS. Needed by WebObs daemons (such as PostBoard) to han =cut sub refreshUsers { - undef %USERS if (%USERS); undef %USERIDS if (%USERIDS); - %USERS = %{allUsers()}; - $USERIDS{$USERS{$_}{UID}}=$_ foreach (keys(%USERS)) ; + undef %USERS if (%USERS); undef %USERIDS if (%USERIDS); + %USERS = %{allUsers()}; + $USERIDS{$USERS{$_}{UID}}=$_ foreach (keys(%USERS)) ; } =head2 allUsers @@ -133,25 +133,25 @@ Attributes names dynamically match the corresponding SQL table column names. =cut sub allUsers { - my ($rs, $dbh, $sql, $sth); + my ($rs, $dbh, $sql, $sth); - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tablename = $WEBOBS{SQL_TABLE_USERS}; - $USERS_LFN = "DB $dbname (".(stat($dbname))[9].") TABLE $tablename"; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tablename = $WEBOBS{SQL_TABLE_USERS}; + $USERS_LFN = "DB $dbname (".(stat($dbname))[9].") TABLE $tablename"; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; - $sql = "SELECT * FROM $tablename" ; - $sth = $dbh->prepare($sql); - $sth->execute(); - $rs = $sth->fetchall_hashref('LOGIN'); + $sql = "SELECT * FROM $tablename" ; + $sth = $dbh->prepare($sql); + $sth->execute(); + $rs = $sth->fetchall_hashref('LOGIN'); - $dbh->disconnect; - return $rs; + $dbh->disconnect; + return $rs; } =pod @@ -167,29 +167,29 @@ Returns a reference to the list (or 0). =cut sub listRNames { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type})); - my (@rs, $dbh, $sql, $sth, $tmp); - - #if ($KWARGS{type} ~~ @validtbls) { - if (grep /^$KWARGS{type}$/i , @validtbls) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT distinct(resource) FROM $KWARGS{type}" ; - $sth = $dbh->prepare($sql); - $sth->execute(); - $tmp = $sth->fetchall_arrayref(); - foreach (@$tmp) {push @rs, @$_} - - $dbh->disconnect; - return \@rs; - } else { return 0 } + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type})); + my (@rs, $dbh, $sql, $sth, $tmp); + + #if ($KWARGS{type} ~~ @validtbls) { + if (grep /^$KWARGS{type}$/i , @validtbls) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT distinct(resource) FROM $KWARGS{type}" ; + $sth = $dbh->prepare($sql); + $sth->execute(); + $tmp = $sth->fetchall_arrayref(); + foreach (@$tmp) {push @rs, @$_} + + $dbh->disconnect; + return \@rs; + } else { return 0 } } =pod @@ -201,18 +201,17 @@ Given user(s) UID(s) (ie. initials) returns user(s) full-name(s) =cut sub userName { - my @name; - for (@_) { - if ( defined($USERIDS{$_}) ) { - push(@name,$USERS{$USERIDS{$_}}{FULLNAME}); - } else { - push(@name,$_); - } - } - return @name; + my @name; + for (@_) { + if ( defined($USERIDS{$_}) ) { + push(@name,$USERS{$USERIDS{$_}}{FULLNAME}); + } else { + push(@name,$_); + } + } + return @name; } - =pod =head2 userListGroup @@ -225,29 +224,29 @@ all known user's groups: =cut sub userListGroup { - my (@groups, $dbh, $sql, $sth); - - if (defined($_[0])) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT GID"; - $sql .= " FROM $tblgroups"; - $sql .= " WHERE UID = '$USERS{$_[0]}{UID}'" ; - - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - foreach (@$tmp) {push @groups, @$_} - $dbh->disconnect; - } - return @groups; + my (@groups, $dbh, $sql, $sth); + + if (defined($_[0])) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT GID"; + $sql .= " FROM $tblgroups"; + $sql .= " WHERE UID = '$USERS{$_[0]}{UID}'" ; + + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + foreach (@$tmp) {push @groups, @$_} + $dbh->disconnect; + } + return @groups; } =pod @@ -263,32 +262,32 @@ all known user's authorizations: =cut sub userListAuth { - my (%rs, $dbh, $sql, $sth); - - if (defined($_[0])) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - for my $tblauth (@validtbls) { - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT $tblauth.RESOURCE, $tblauth.AUTH"; - $sql .= " FROM $tblusers,$tblauth"; - $sql .= " WHERE $tblusers.UID = '$USERS{$_[0]}{UID}' AND $tblusers.UID = $tblauth.UID" ; - $sql .= " ORDER BY 1,2"; - - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - $rs{$tblauth} = $tmp; - } - $dbh->disconnect; - } - return %rs; + my (%rs, $dbh, $sql, $sth); + + if (defined($_[0])) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + for my $tblauth (@validtbls) { + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT $tblauth.RESOURCE, $tblauth.AUTH"; + $sql .= " FROM $tblusers,$tblauth"; + $sql .= " WHERE $tblusers.UID = '$USERS{$_[0]}{UID}' AND $tblusers.UID = $tblauth.UID" ; + $sql .= " ORDER BY 1,2"; + + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + $rs{$tblauth} = $tmp; + } + $dbh->disconnect; + } + return %rs; } =pod @@ -308,42 +307,42 @@ to resource-'type' named 'name'. =cut sub userHasAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user}) || !exists($KWARGS{auth}) ); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user}) || !exists($KWARGS{auth}) ); - my ($rs, $dbh, $sql, $sth, $count); - my $rc = 0; + my ($rs, $dbh, $sql, $sth, $count); + my $rc = 0; - #if ($KWARGS{type} ~~ @validtbls) { - if (grep /^$KWARGS{type}$/i , @validtbls) { - $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + #if ($KWARGS{type} ~~ @validtbls) { + if (grep /^$KWARGS{type}$/i , @validtbls) { + $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; my $today = strftime("%Y-%m-%d",localtime(int(time()))); - my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); - if ($validuser eq 'Y') { - my @inl="'*'"; - while ($KWARGS{name} !~ m|^.?/$|) { push(@inl,"\'$KWARGS{name}\'"); $KWARGS{name}=dirname($KWARGS{name})."/"; }; - my $sql = "SELECT COUNT(*) FROM $KWARGS{type}"; - $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; - $sql .= " AND $KWARGS{type}.RESOURCE in (".join(", ",@inl).") AND $KWARGS{type}.AUTH >= $KWARGS{auth}"; - - $count = $dbh->selectrow_array($sql); - if ($count > 0) { $rc = 1 } - } - - $dbh->disconnect; - - } - return $rc; + my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); + if ($validuser eq 'Y') { + my @inl="'*'"; + while ($KWARGS{name} !~ m|^.?/$|) { push(@inl,"\'$KWARGS{name}\'"); $KWARGS{name}=dirname($KWARGS{name})."/"; }; + my $sql = "SELECT COUNT(*) FROM $KWARGS{type}"; + $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; + $sql .= " AND $KWARGS{type}.RESOURCE in (".join(", ",@inl).") AND $KWARGS{type}.AUTH >= $KWARGS{auth}"; + + $count = $dbh->selectrow_array($sql); + if ($count > 0) { $rc = 1 } + } + + $dbh->disconnect; + + } + return $rc; } =pod @@ -357,39 +356,39 @@ returns maximum authorization granted to user on resource type / resource name i =cut sub userMaxAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user})); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user})); - my ($rs, $dbh, $sql, $sth); - my $rc = 0; + my ($rs, $dbh, $sql, $sth); + my $rc = 0; - #if ($KWARGS{type} ~~ @validtbls) { - if (grep /^$KWARGS{type}$/i , @validtbls) { - $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + #if ($KWARGS{type} ~~ @validtbls) { + if (grep /^$KWARGS{type}$/i , @validtbls) { + $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; my $today = strftime("%Y-%m-%d",localtime(int(time()))); - my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); - if ($validuser eq 'Y') { - my $sql = "SELECT MAX(AUTH) FROM $KWARGS{type}"; - $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; - $sql .= " AND ($KWARGS{type}.RESOURCE IN $KWARGS{name} OR $KWARGS{type}.RESOURCE ='*')"; + my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); + if ($validuser eq 'Y') { + my $sql = "SELECT MAX(AUTH) FROM $KWARGS{type}"; + $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; + $sql .= " AND ($KWARGS{type}.RESOURCE IN $KWARGS{name} OR $KWARGS{type}.RESOURCE ='*')"; - $rc = $dbh->selectrow_array($sql); - } + $rc = $dbh->selectrow_array($sql); + } - $dbh->disconnect; + $dbh->disconnect; - } - return $rc; + } + return $rc; } =pod @@ -403,29 +402,29 @@ returns true (1) if given 'user' login has a validity status 'Y' =cut sub userIsValid { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{user})); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{user})); - my $dbh; - my $rc = 0; + my $dbh; + my $rc = 0; - $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; my $today = strftime("%Y-%m-%d",localtime(int(time()))); - my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); - if ($validuser eq 'Y') { $rc = 1 } + my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); + if ($validuser eq 'Y') { $rc = 1 } - $dbh->disconnect; + $dbh->disconnect; - return $rc; + return $rc; } =pod @@ -437,36 +436,36 @@ wrappers for userHasAuth with user=$CLIENT. =cut sub clientHasRead { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>READAUTH); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>READAUTH); } sub clientHasEdit { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>EDITAUTH); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>EDITAUTH); } sub clientHasAdm { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>ADMAUTH); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>ADMAUTH); } sub clientMaxAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userMaxAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userMaxAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}); } sub clientIsValid { - return userIsValid(user=>$CLIENT); + return userIsValid(user=>$CLIENT); } sub clientIsWO { - return 0 if ($USERS{$CLIENT}{UID} ne '!'); - return 1; + return 0 if ($USERS{$CLIENT}{UID} ne '!'); + return 1; } =pod @@ -480,30 +479,31 @@ Given a group ID 'GID' (starts with a '+'), returns an array of all associated u =cut sub groupListUser { - my (@users, $dbh, $sql, $sth); - - if (defined($_[0])) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT UID"; - $sql .= " FROM $tblgroups"; - $sql .= " WHERE GID = '$_[0]'" ; - - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - foreach (@$tmp) {push @users, @$_} - $dbh->disconnect; - } - return @users; + my (@users, $dbh, $sql, $sth); + + if (defined($_[0])) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT UID"; + $sql .= " FROM $tblgroups"; + $sql .= " WHERE GID = '$_[0]'" ; + + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + foreach (@$tmp) {push @users, @$_} + $dbh->disconnect; + } + return @users; } + =pod =head2 resListAuth @@ -518,31 +518,31 @@ returns an Hash of arrays of all UID or GID's for each authorization levels =cut sub resListAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - - my (%rs, $dbh, $sql, $sth); - - my $dbname = $WEBOBS{SQL_DB_USERS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - foreach my $authlevel (READAUTH,EDITAUTH,ADMAUTH) { - $sql = "SELECT UID FROM $KWARGS{type} WHERE AUTH = $authlevel AND (RESOURCE = '$KWARGS{name}' OR RESOURCE = '*')"; - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - my @users; - foreach (@$tmp) { push(@users, @$_) } - $rs{$authlevel} = \@users; - } - $dbh->disconnect; - - return %rs; + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + + my (%rs, $dbh, $sql, $sth); + + my $dbname = $WEBOBS{SQL_DB_USERS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + foreach my $authlevel (READAUTH,EDITAUTH,ADMAUTH) { + $sql = "SELECT UID FROM $KWARGS{type} WHERE AUTH = $authlevel AND (RESOURCE = '$KWARGS{name}' OR RESOURCE = '*')"; + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + my @users; + foreach (@$tmp) { push(@users, @$_) } + $rs{$authlevel} = \@users; + } + $dbh->disconnect; + + return %rs; } =pod @@ -557,34 +557,34 @@ error code otherwise). =cut sub htpasswd { - # Calls the htpasswd command with the provided command line - # options, login, and password. - # Arguments: (options, arg1, arg2, ..., password, output_ref) - # Returns the htpasswd exit code: 0 for success, > 0 otherwise. - my $htpw_opts = "-i".shift; # force -i to read the password from stdin - my $output_ref = pop; # reference where to store the output - my $pass = pop; # the password to pass via stdin (the last argument) - my @htpw_args = @_; # other arguments - - # Note: use a list for command arguments to avoid using a shell - my @cmd = ($WEBOBS{PRGM_HTPASSWD}, $htpw_opts, @htpw_args); - carp "info: executing command '".join(" ", @cmd)."'\n"; - - # Important: use IPC:Open3 to pass the password to stdin to the - # htpasswd command to avoid it being visible by other users. - my ($child_in, $child_out, $child_err); - my $pid = open3($child_in, $child_out, $child_err, @cmd); - print $child_in $pass; - close $child_in; # end the subprocess - - # Read all the output to $$output_ref - $$output_ref = do { local $/; <$child_out>; }; - - # Wait for the child to avoid zombies - waitpid($pid, 0); - return $? >> 8; -} + # Calls the htpasswd command with the provided command line + # options, login, and password. + # Arguments: (options, arg1, arg2, ..., password, output_ref) + # Returns the htpasswd exit code: 0 for success, > 0 otherwise. + my $htpw_opts = "-i".shift; # force -i to read the password from stdin + my $output_ref = pop; # reference where to store the output + my $pass = pop; # the password to pass via stdin (the last argument) + my @htpw_args = @_; # other arguments + + # Note: use a list for command arguments to avoid using a shell + my @cmd = ($WEBOBS{PRGM_HTPASSWD}, $htpw_opts, @htpw_args); + carp "info: executing command '".join(" ", @cmd)."'\n"; + + # Important: use IPC:Open3 to pass the password to stdin to the + # htpasswd command to avoid it being visible by other users. + my ($child_in, $child_out, $child_err); + my $pid = open3($child_in, $child_out, $child_err, @cmd); + print $child_in $pass; + close $child_in; # end the subprocess + + # Read all the output to $$output_ref + $$output_ref = do { local $/; <$child_out>; }; + + # Wait for the child to avoid zombies + waitpid($pid, 0); + return $? >> 8; +} =head2 htpasswd_update @@ -595,26 +595,29 @@ error code otherwise. =cut sub _get_htpasswd_encryption_opt { - # Auxiliary function that returns the htpasswd option to use according to - # the encryption format chosen in the configuration. - if (lc($WEBOBS{'HTPASSWD_ENCRYPTION'}) eq "bcrypt") { - return "B"; - } - # $WEBOBS{'HTPASSWD_ENCRYPTION'} is "md5" or anything - return "m"; + + # Auxiliary function that returns the htpasswd option to use according to + # the encryption format chosen in the configuration. + if (lc($WEBOBS{'HTPASSWD_ENCRYPTION'}) eq "bcrypt") { + return "B"; + } + + # $WEBOBS{'HTPASSWD_ENCRYPTION'} is "md5" or anything + return "m"; } sub htpasswd_update { - # Adds or update a login/password in the htpasswd file. - # Returns 0 if success, non-zero otherwise. - my $login = shift; # the login to create - my $pass = shift; # the new password to set - my $htpw_opt = _get_htpasswd_encryption_opt(); # options for htpasswd - my $output; # a reference for the output - # Call htpasswd with the selected option - return htpasswd($htpw_opt, $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); -} + # Adds or update a login/password in the htpasswd file. + # Returns 0 if success, non-zero otherwise. + my $login = shift; # the login to create + my $pass = shift; # the new password to set + my $htpw_opt = _get_htpasswd_encryption_opt(); # options for htpasswd + my $output; # a reference for the output + + # Call htpasswd with the selected option + return htpasswd($htpw_opt, $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); +} =head2 htpasswd_verify @@ -623,16 +626,16 @@ Verifies the password of a user in the $WEBOBS{'HTTP_PASSWORD_FILE'} file. =cut sub htpasswd_verify { + # Calls the htpasswd command to verify the login/password. - # Returns 0 if success, non-zero otherwise. - my $login = shift; - my $pass = shift; + # Returns 0 if success, non-zero otherwise. + my $login = shift; + my $pass = shift; - my $output; # a reference for the output - return htpasswd("v", $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); + my $output; # a reference for the output + return htpasswd("v", $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); } - =head2 htpasswd_display Displays the line that should be added to the $WEBOBS{'HTTP_PASSWORD_FILE'} @@ -641,22 +644,23 @@ file. =cut sub htpasswd_display { - # Calls the htpasswd command to display the line that should be added to - # the htpasswd file. Returns the output of the command. - my $login = shift; - my $pass = shift; - - my $htpw_opts = "n"._get_htpasswd_encryption_opt(); - my $output; # a reference for the output - my $rc = htpasswd($htpw_opts, $login, $pass, \$output); - my @lines = split(/\n/, $output); - if ($rc != 0 or not @lines) { - return "[error while executing $WEBOBS{'HTTP_PASSWORD_FILE'}]"; - } - # Returns the fist line of the output - return $lines[0]; -} + # Calls the htpasswd command to display the line that should be added to + # the htpasswd file. Returns the output of the command. + my $login = shift; + my $pass = shift; + + my $htpw_opts = "n"._get_htpasswd_encryption_opt(); + my $output; # a reference for the output + my $rc = htpasswd($htpw_opts, $login, $pass, \$output); + my @lines = split(/\n/, $output); + if ($rc != 0 or not @lines) { + return "[error while executing $WEBOBS{'HTTP_PASSWORD_FILE'}]"; + } + + # Returns the fist line of the output + return $lines[0]; +} 1; diff --git a/CODE/perl/lib/Utils.pm b/CODE/perl/lib/Utils.pm index 832392e8..8d2453b5 100644 --- a/CODE/perl/lib/Utils.pm +++ b/CODE/perl/lib/Utils.pm @@ -22,11 +22,12 @@ our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(u2l l2u htmlspecialchars getImageInfo makeThumbnail trim ltrim - rtrim tri_date_avec_id datediffdays isok romanx pga2msk attenuation num2roman txt2htm tex2utf - roundsd htm2frac qrcode url2target checkParam); + rtrim tri_date_avec_id datediffdays isok romanx pga2msk attenuation num2roman txt2htm tex2utf + roundsd htm2frac qrcode url2target checkParam); $VERSION = "1.00"; #-------------------------------------------------------------------------------------------------------------------------------------- + =pod =head2 u2l, l2u @@ -44,19 +45,18 @@ my $l2u = Locale::Recode->new (from => 'ISO-8859-15', to => 'UTF-8'); die $u2l->getError if $u2l->getError; die $l2u->getError if $l2u->getError; - # ------------------------------------------------------------------------------------------------- sub u2l ($) { - my $texte = shift; - $u2l->recode($texte) or die $u2l->getError; - return $texte; + my $texte = shift; + $u2l->recode($texte) or die $u2l->getError; + return $texte; } # ------------------------------------------------------------------------------------------------- sub l2u ($) { - my $texte = shift; - $l2u->recode($texte) or die $l2u->getError; - return $texte; + my $texte = shift; + $l2u->recode($texte) or die $l2u->getError; + return $texte; } binmode STDOUT, ':raw'; # Needed to make it work in UTF-8 locales in Perl-5.8. @@ -75,18 +75,18 @@ converts $textin B<" \< \>> to resp. html entities B<" < >> : sub htmlspecialchars { - my $txt = $_[0]; - my $re = $_[1]; - - $txt =~ s/"/"/g; - $txt =~ s/'/'/g; - $txt =~ s//>/g; -# print "
    ".$txt."
    "; - $txt =~ s/($re)/$1<\/b>/g if ($re ne ""); - return $txt; -} + my $txt = $_[0]; + my $re = $_[1]; + $txt =~ s/"/"/g; + $txt =~ s/'/'/g; + $txt =~ s//>/g; + + # print "
    ".$txt."
    "; + $txt =~ s/($re)/$1<\/b>/g if ($re ne ""); + return $txt; +} # ------------------------------------------------------------------------------------------------- @@ -102,22 +102,21 @@ converts any TeX characters in $textin into UTF-8 character: sub tex2utf { - my $text = $_[0]; - - $text =~ s/\\pm/±/g; - $text =~ s/\\approx/≈/g; - $text =~ s/\\pi/π/g; - $text =~ s/\\mu/µ/g; - $text =~ s/\\Omega/Ω/g; - $text =~ s/\\Sigma/∑/g; - $text =~ s/\\copyright/©/g; - $text =~ s/\\partial/∂/g; - $text =~ s/\\lt//g; - return $text; + my $text = $_[0]; + + $text =~ s/\\pm/±/g; + $text =~ s/\\approx/≈/g; + $text =~ s/\\pi/π/g; + $text =~ s/\\mu/µ/g; + $text =~ s/\\Omega/Ω/g; + $text =~ s/\\Sigma/∑/g; + $text =~ s/\\copyright/©/g; + $text =~ s/\\partial/∂/g; + $text =~ s/\\lt//g; + return $text; } - # ------------------------------------------------------------------------------------------------- =pod @@ -145,109 +144,111 @@ Example: sub makeThumbnail { - my $ret = ""; - my @needsel = (".pdf",".PDF"); - if (scalar(@_) == 4 ) { - my ($img, $path) = fileparse($_[0]); - my ($ext) = $img =~ /(\.[^.]+)$/; - my $thumb = $_[2]."/".$img.".".$_[3]; - #DL-was:if ($ext ~~ @needsel) { $img .= '[0]' } - if (grep /\Q$ext/i , @needsel) { $img .= '[0]' } - if ( !-e $thumb ) { - qx(/usr/bin/convert "$path$img" -thumbnail $_[1] -background white -alpha remove "$thumb" 2>/dev/null); - if ( $? == 0 ) { - $ret = $thumb; - } - } else { $ret = $thumb } - } - return $ret; + my $ret = ""; + my @needsel = (".pdf",".PDF"); + if (scalar(@_) == 4 ) { + my ($img, $path) = fileparse($_[0]); + my ($ext) = $img =~ /(\.[^.]+)$/; + my $thumb = $_[2]."/".$img.".".$_[3]; + + #DL-was:if ($ext ~~ @needsel) { $img .= '[0]' } + if (grep /\Q$ext/i , @needsel) { $img .= '[0]' } + if ( !-e $thumb ) { + qx(/usr/bin/convert "$path$img" -thumbnail $_[1] -background white -alpha remove "$thumb" 2>/dev/null); + if ( $? == 0 ) { + $ret = $thumb; + } + } else { $ret = $thumb } + } + return $ret; } - #-------------------------------------------------------------------------------------------------------------------------------------- sub getImageInfo { - my $ret = "", - my $img = $_[0]; - if (-e $img) { - $ret = qx(/usr/bin/identify -format "%[EXIF:DateTimeOriginal]|%G" "$img"); - chomp($ret); - } - return $ret; + my $ret = "", + my $img = $_[0]; + if (-e $img) { + $ret = qx(/usr/bin/identify -format "%[EXIF:DateTimeOriginal]|%G" "$img"); + chomp($ret); + } + return $ret; } #-------------------------------------------------------------------------------------------------------------------------------------- # Perl trim function to remove whitespace from the start and end of the string sub trim($) { - my $string = shift; - $string =~ s/^\s+//; - $string =~ s/\s+$//; - return $string; + my $string = shift; + $string =~ s/^\s+//; + $string =~ s/\s+$//; + return $string; } #-------------------------------------------------------------------------------------------------------------------------------------- # Left trim function to remove leading whitespace sub ltrim($) { - my $string = shift; - $string =~ s/^\s+//; - return $string; + my $string = shift; + $string =~ s/^\s+//; + return $string; } #-------------------------------------------------------------------------------------------------------------------------------------- # Right trim function to remove trailing whitespace sub rtrim($) { - my $string = shift; - $string =~ s/\s+$//; - return $string; + my $string = shift; + $string =~ s/\s+$//; + return $string; } - #-------------------------------------------------------------------------------------------------------------------------------------- # sort array of strings in the form "ID|yyyy-mm-dd|HH:MM|..." on date and time (second and third column) # (for use with mc3.pl) sub tri_date_avec_id ($$) { - my ($c,$d) = @_; - # removes first column (ID) - $c =~ s/^[\-0-9]+\|//; - $d =~ s/^[\-0-9]+\|//; - # replaces empty time by '00:00' so events without time appear first - $c =~ s/\|\|/00:00/; - $d =~ s/\|\|/00:00/; - return $d cmp $c; + my ($c,$d) = @_; + + # removes first column (ID) + $c =~ s/^[\-0-9]+\|//; + $d =~ s/^[\-0-9]+\|//; + + # replaces empty time by '00:00' so events without time appear first + $c =~ s/\|\|/00:00/; + $d =~ s/\|\|/00:00/; + return $d cmp $c; } #-------------------------------------------------------------------------------------------------------------------------------------- # sub datediffdays { - use DateTime::Duration; - - my ($y1,$m1,$d1,$h1,$n1,$s1) = split(/[- :]/,$_[0]); - my ($y2,$m2,$d2,$h2,$n2,$s2) = split(/[- :]/,$_[1]); - my $dt1 = DateTime->new( - year => $y1, + use DateTime::Duration; + + my ($y1,$m1,$d1,$h1,$n1,$s1) = split(/[- :]/,$_[0]); + my ($y2,$m2,$d2,$h2,$n2,$s2) = split(/[- :]/,$_[1]); + my $dt1 = DateTime->new( + year => $y1, month => $m1, day => $d1, hour => $h1, minute => $n1, second => $s1, time_zone => 'local', - ); - my $dt2 = DateTime->new( - year => $y2, + ); + my $dt2 = DateTime->new( + year => $y2, month => $m2, day => $d2, hour => $h2, minute => $n2, second => $s2, time_zone => 'local', - ) + DateTime::Duration->new(seconds => "1"); # add 1 second - - my $dur = $dt2->subtract_datetime_absolute($dt1); - #return "$dt1,$dt2"; - return sprintf("%1.0f", ($dur->in_units('seconds'))/86400); + ) + DateTime::Duration->new(seconds => "1"); # add 1 second + + my $dur = $dt2->subtract_datetime_absolute($dt1); + + #return "$dt1,$dt2"; + return sprintf("%1.0f", ($dur->in_units('seconds'))/86400); } #-------------------------------------------------------------------------------------------------------------------------------------- @@ -258,48 +259,49 @@ sub isok ($) return ($ok =~ /^(Y|YES|OK|ON|1|TRUE)/i ? 1:0); } - #-------------------------------------------------------------------------------------------------------------------------------------- sub romanx ($) -# Input: intensity MSK (numerical from 1 to 0 or 10) -# Output: intensity MSK (in roman numbers) -# Proc equivalent: matlab/romanx.m + + # Input: intensity MSK (numerical from 1 to 0 or 10) + # Output: intensity MSK (in roman numbers) + # Proc equivalent: matlab/romanx.m { - my @msk = ("X","I","II","III","IV","V","VI","VII","VIII","IX"); - my $string = shift; - return $msk[$string%10]; + my @msk = ("X","I","II","III","IV","V","VI","VII","VIII","IX"); + my $string = shift; + return $msk[$string%10]; } - #-------------------------------------------------------------------------------------------------------------------------------------- sub pga2msk ($) -# Input: ground acceleration (in mg) -# Output: intensity level MSK (in roman numbers) -# Proc equivalent matlab/pga2msk.m -# Author: F. Beauducel, IPGP, 2009-06-24 + + # Input: ground acceleration (in mg) + # Output: intensity level MSK (in roman numbers) + # Proc equivalent matlab/pga2msk.m + # Author: F. Beauducel, IPGP, 2009-06-24 { - my @msk = ('I','I-II','II','II-III','III','III-IV','IV','IV-V','V','V-VI','VI','VI-VII','VII','VII-VIII','VIII','VIII-IX','IX','IX-X','X','X-XI','XI','XI-XII','XII'); - my $pga = shift; - $pga = 2*(log($pga)*3/log(10) + 1.5) - 2; - if ($pga < 0) { $pga = 0; } - return $msk[$pga]; + my @msk = ('I','I-II','II','II-III','III','III-IV','IV','IV-V','V','V-VI','VI','VI-VII','VII','VII-VIII','VIII','VIII-IX','IX','IX-X','X','X-XI','XI','XI-XII','XII'); + my $pga = shift; + $pga = 2*(log($pga)*3/log(10) + 1.5) - 2; + if ($pga < 0) { $pga = 0; } + return $msk[$pga]; } - #-------------------------------------------------------------------------------------------------------------------------------------- sub attenuation ($$) -# Input: magnitude et distance hypocentrale (en km) -# Ouput: acceleration PGA (en g) -# Proc equivalent: matlab/attenuation.m -# Author: F. Beauducel, IPGP, 2009-06-24 + + # Input: magnitude et distance hypocentrale (en km) + # Ouput: acceleration PGA (en g) + # Proc equivalent: matlab/attenuation.m + # Author: F. Beauducel, IPGP, 2009-06-24 { - my ($mag,$hyp) = @_; - if ($hyp < 5) { $hyp = 5; } - my $pga = 1000*10**(0.620986*$mag - 0.00345256*$hyp - log($hyp)/log(10) - 3.374841); - return $pga; + my ($mag,$hyp) = @_; + if ($hyp < 5) { $hyp = 5; } + my $pga = 1000*10**(0.620986*$mag - 0.00345256*$hyp - log($hyp)/log(10) - 3.374841); + return $pga; } #-------------------------------------------------------------------------------------------------------------------------------------- + =pod =head2 num2roman $roman = num2roman($number); @@ -310,40 +312,40 @@ Proc equivalent: matlab/num2roman.m sub num2roman ($) { - my @r = (["I","X","C","M"],["V","L","D"," "," "]); - my $n = shift; - my $x; - - for my $i (reverse(0 .. floor(log10($n)))) { - my $ii = int($n/10**$i); - $x .= $r[0][$i] x $ii if ($ii < 4 || ($ii == 4 && $i == 3)); - $x .= $r[0][$i] if ($ii == 9 || ($ii == 4 && $i < 3)); - $x .= $r[1][$i].($r[0][$i] x ($ii - 5)) if ($ii >= 4 && $ii <= 8 && $i != 3); - $x .= $r[0][$i+1] if ($ii == 9); - $n -= $ii*10**$i; - } - return $x; + my @r = (["I","X","C","M"],["V","L","D"," "," "]); + my $n = shift; + my $x; + + for my $i (reverse(0 .. floor(log10($n)))) { + my $ii = int($n/10**$i); + $x .= $r[0][$i] x $ii if ($ii < 4 || ($ii == 4 && $i == 3)); + $x .= $r[0][$i] if ($ii == 9 || ($ii == 4 && $i < 3)); + $x .= $r[1][$i].($r[0][$i] x ($ii - 5)) if ($ii >= 4 && $ii <= 8 && $i != 3); + $x .= $r[0][$i+1] if ($ii == 9); + $n -= $ii*10**$i; + } + return $x; } #-------------------------------------------------------------------------------------------------------------------------------------- sub roundsd -# Round with significant digits -# Proc equivalent: matlab/roundsd.m -# Author: F. Beauducel, IPGP + + # Round with significant digits + # Proc equivalent: matlab/roundsd.m + # Author: F. Beauducel, IPGP { - my ($x, $n) = @_; - $n = 1 if ($n eq "" || $n < 1); - return 0 if ($x == 0); - my $e = floor(log(abs($x))/log(10) - $n + 1); - my $og = 10**abs($e); - if ($e > 0) { - return floor($x/$og + 0.5)*$og; - } else { - return floor($x*$og + 0.5)/$og; - } + my ($x, $n) = @_; + $n = 1 if ($n eq "" || $n < 1); + return 0 if ($x == 0); + my $e = floor(log(abs($x))/log(10) - $n + 1); + my $og = 10**abs($e); + if ($e > 0) { + return floor($x/$og + 0.5)*$og; + } else { + return floor($x*$og + 0.5)/$og; + } } - #-------------------------------------------------------------------------------------------------------------------------------------- sub qrcode ($) { @@ -351,23 +353,23 @@ sub qrcode ($) my $s = shift; return "" if ($s eq ""); my $url = "http://$ENV{HTTP_HOST}$ENV{REQUEST_URI}"; - my $qr = encode_base64(qx(qrencode -s $s -o - "$url")); + my $qr = encode_base64(qx(qrencode -s $s -o - "$url")); my $img = ($qr eq "" ? "":""); + ."'width=600,height=450,toolbar=no,menubar=no,status=no,location=no')\">"); return $img; } #-------------------------------------------------------------------------------------------------------------------------------------- sub url2target { - my $url = shift; - if ($url =~ /^\/(index*)?$/) { - return "_top"; - } elsif ($url =~ /^\//) { - return "bas"; - } else { - return "_blank"; - } + my $url = shift; + if ($url =~ /^\/(index*)?$/) { + return "_top"; + } elsif ($url =~ /^\//) { + return "bas"; + } else { + return "_blank"; + } } # ------------------------------------------------------------------------------------------------- @@ -375,16 +377,15 @@ sub url2target # Author: F. Beauducel, IPGP sub htm2frac { - my $s = shift; - if ($s =~ /[^< ]\//) { - my ($n, $d) = split(/[^< ]\//,$s); - return "
    $n
    $d
    "; - } else { - return $s; - } + my $s = shift; + if ($s =~ /[^< ]\//) { + my ($n, $d) = split(/[^< ]\//,$s); + return "
    $n
    $d
    "; + } else { + return $s; + } } - # ------------------------------------------------------------------------------------------------- =pod @@ -427,43 +428,43 @@ Use this instead: =cut sub checkParam ($$;$) { - # Parameters: - # - # $value (string or ARRAY ref, in a forced scalar context): - # The values to test. If an array ref, all elements of the array must - # match the pattern. Note: this cannot be a constant (e.g. 1, or "str") - # $pattern (regex pattern): - # The pattern to test the value against (should match the whole value - # from start to end of string). Should ALWAYS match the whole string - # (qr/^...$/), or it would completely defeat the security check. - # $param_name (string), optional: - # The error message to use with die of value does not match - # - # Exception: - # Dies with $error_msg if $value does not match pattern. - # Returns: - # $value - # - my $value = shift; - my $pattern = shift; - my $param_name = shift // ''; - my $error_msg; - my $want_array = ref($value) eq "ARRAY" ? 1 : 0; - my @values = $want_array ? @$value : ($value); - return unless defined $value; - - if ($param_name) { - $error_msg = "Error: bad value for parameter '$param_name', cannot continue."; - } else { - $error_msg = "Error: bad parameter value, cannot continue."; - } - - for my $v (@values) { - die $error_msg unless ($v =~ $pattern); - } - return $want_array ? @values : $value; -} + # Parameters: + # + # $value (string or ARRAY ref, in a forced scalar context): + # The values to test. If an array ref, all elements of the array must + # match the pattern. Note: this cannot be a constant (e.g. 1, or "str") + # $pattern (regex pattern): + # The pattern to test the value against (should match the whole value + # from start to end of string). Should ALWAYS match the whole string + # (qr/^...$/), or it would completely defeat the security check. + # $param_name (string), optional: + # The error message to use with die of value does not match + # + # Exception: + # Dies with $error_msg if $value does not match pattern. + # Returns: + # $value + # + my $value = shift; + my $pattern = shift; + my $param_name = shift // ''; + my $error_msg; + my $want_array = ref($value) eq "ARRAY" ? 1 : 0; + my @values = $want_array ? @$value : ($value); + return unless defined $value; + + if ($param_name) { + $error_msg = "Error: bad value for parameter '$param_name', cannot continue."; + } else { + $error_msg = "Error: bad parameter value, cannot continue."; + } + + for my $v (@values) { + die $error_msg unless ($v =~ $pattern); + } + return $want_array ? @values : $value; +} 1; diff --git a/CODE/perl/lib/VolcAuto.pm b/CODE/perl/lib/VolcAuto.pm index 6ac168b8..003f0810 100644 --- a/CODE/perl/lib/VolcAuto.pm +++ b/CODE/perl/lib/VolcAuto.pm @@ -25,14 +25,14 @@ use VolcAuto::MCEvent; use Exporter qw(import); our @EXPORT_OK = qw(debug_log err_log write_whole_file create_mc3_lock - remove_mc3_lock autovt2mc process_autovolc_csv); + remove_mc3_lock autovt2mc process_autovolc_csv); BEGIN { + # Suppress the default fatalsToBrowser from CGI::Carp $CGI::Carp::TO_BROWSER = 0; } - # ----------------------------------------------------------------------------- # Configuration and initialisation # @@ -46,7 +46,6 @@ my $AUTOVOLC_UID = 'VOLC'; # Event type to use in the MC for new automatic events my $AUTOVOLC_TYPE = 'VOLCAUTO'; - # Set DEBUG to 1 to see additional messages on stderr my $DEBUG = $ENV{'DEBUG'} // 1; @@ -59,7 +58,6 @@ $ENV{LANG} = $WEBOBS{LOCALE}; # Name of the script (for use in debug output) my $SCRIPT_NAME = basename($0); - # ----------------------------------------------------------------------------- # Subroutines # @@ -73,7 +71,6 @@ sub debug_log { say STDERR "[DEBUG] $msg" if ($DEBUG); } - # ----------------------------------------------------------------------------- # Log message to stderr if DEBUG is true # @@ -83,7 +80,6 @@ sub err_log { say STDERR "$SCRIPT_NAME: $msg"; } - # ----------------------------------------------------------------------------- # Read the whole content of a file # @@ -97,20 +93,19 @@ sub read_whole_file { my $file_name = shift; open(my $file, $file_name) - or die "Could not open '$file_name' for reading: $!"; + or die "Could not open '$file_name' for reading: $!"; my $file_content = do { local $/; # Enter slurp mode <$file>; # Read and return the whole file - }; + }; close($file) - or warn "Error while closing $file_name: $!"; + or warn "Error while closing $file_name: $!"; return $file_content; } - # ----------------------------------------------------------------------------- # Write/Overwrite the whole content of a file # @@ -126,15 +121,14 @@ sub write_whole_file { my $file_content = shift; open(my $file, ">", $file_name) - or die "Could not open '$file_name' for reading: $!"; + or die "Could not open '$file_name' for reading: $!"; print $file $file_content; close($file) - or warn "Error while closing $file_name: $!"; + or warn "Error while closing $file_name: $!"; } - # ----------------------------------------------------------------------------- # Create a non-blocking lock for the MC3 # (Using the WebObs™ way™, i.e. with race condition included.) @@ -153,6 +147,7 @@ sub create_mc3_lock { # Try to acquire the lock $try_count times before giving up. my $try_count = 3; + # Wait $wait seconds between tries my $wait = 2; @@ -162,8 +157,8 @@ sub create_mc3_lock { my $lock_owner = read_whole_file($lock_file); chomp $lock_owner; err_log(sprintf("MC is currently being locked by %s," - ." retrying in %d seconds...", - $lock_owner, (3 - $try_count) * $wait)); + ." retrying in %d seconds...", + $lock_owner, (3 - $try_count) * $wait)); sleep((3 - $try_count) * $wait); } @@ -175,7 +170,6 @@ sub create_mc3_lock { $lock_created = 1; } - # ----------------------------------------------------------------------------- # Remove the lock file for the MC3 # @@ -197,13 +191,12 @@ sub remove_mc3_lock { if (-e $lock_file) { unlink $lock_file - or warn "Error removing lock file '$lock_file': $!"; + or warn "Error removing lock file '$lock_file': $!"; } elsif ($warn_if_missing) { warn "Error removing lock file '$lock_file': file is missing!"; } } - # ----------------------------------------------------------------------------- # Return a VolcAuto::MCEvent object built from the data taken from a line of # the CVS file, using additional fixed values. @@ -224,7 +217,7 @@ sub autovt2mc { my $sefran_name = shift; my ($tmpl_id, $date, $time, $corr, $station, $mag) - = map { s/^\s+|\s+$//gr } split(/$INPUT_SEPARATOR/, $CSV_line); + = map { s/^\s+|\s+$//gr } split(/$INPUT_SEPARATOR/, $CSV_line); my $comment = sprintf('VT classe %d - %.2d%%', $tmpl_id, $corr * 100); if ($mag and $mag ne 'NaN') { @@ -232,22 +225,21 @@ sub autovt2mc { } return VolcAuto::MCEvent->new({ - 'mc3_name' => $mc3_name, - 'id' => $event_id, - 'date' => $date, - 'time' => $time, - 'type' => $AUTOVOLC_TYPE, - 'amplitude' => '', - 'duration' => 5, - 'unit' => 's', - 'sefran_name' => $sefran_name // undef, - 'station' => $station, - 'comment' => $comment, - 'operator' => $AUTOVOLC_UID, - }); + 'mc3_name' => $mc3_name, + 'id' => $event_id, + 'date' => $date, + 'time' => $time, + 'type' => $AUTOVOLC_TYPE, + 'amplitude' => '', + 'duration' => 5, + 'unit' => 's', + 'sefran_name' => $sefran_name // undef, + 'station' => $station, + 'comment' => $comment, + 'operator' => $AUTOVOLC_UID, + }); } - # ----------------------------------------------------------------------------- # Read CSV lines from STDIN and process them # @@ -266,6 +258,7 @@ sub process_autovolc_csv { my $mc_month; while (my $line = ) { + # Remove the trailing new line chomp $line; @@ -276,9 +269,11 @@ sub process_autovolc_csv { my $vt_event; $vt_event = autovt2mc($line, $mc3_name, 0, $sefran_name); try { + # Create the event with temporary id 0 $vt_event = autovt2mc($line, $mc3_name, 0, $sefran_name); } catch { + # The event is not well formed (some column is missing) debug_log("skipping malformed line '$line'"); $vt_event = undef; @@ -292,9 +287,9 @@ sub process_autovolc_csv { $mc->write_file() if ($mc); $mc = VolcAuto::MCFile->new($vt_event->{'datetime'}->year, - $vt_event->{'datetime'}->month, - $mc3_name, - $sefran_name); + $vt_event->{'datetime'}->month, + $mc3_name, + $sefran_name); } # Set proper id for the event diff --git a/CODE/perl/lib/Wiki.pm b/CODE/perl/lib/Wiki.pm index 5c737692..498e2247 100644 --- a/CODE/perl/lib/Wiki.pm +++ b/CODE/perl/lib/Wiki.pm @@ -81,7 +81,7 @@ use WebObs::Config qw(%WEBOBS readCfg); use WebObs::Grids; use WebObs::Users; if ($WEBOBS{WIKI_MMD} ne 'NO') { - require Text::MultiMarkdown; + require Text::MultiMarkdown; } our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); @@ -91,25 +91,25 @@ require Exporter; $VERSION = "1.00"; sub wiki2html { - (my $string = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; - (my $clean, my $meta) = stripMDmetadata($string); - if (length($meta) == 0) { wiki($clean) } else { markdown($string) }; + (my $string = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; + (my $clean, my $meta) = stripMDmetadata($string); + if (length($meta) == 0) { wiki($clean) } else { markdown($string) }; } sub stripMDmetadata { - if (defined($_[0]) && $_[0] ne "") { - (my $txt = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; - return ($txt,"") if (defined($WEBOBS{WIKI_MMD}) && $WEBOBS{WIKI_MMD} eq 'NO'); - return ($txt, "") if ($txt !~ /\n\s*\n/); # no blank line means no chance for metadata - (my $head, my $tail) = split /\n\s*\n/ , $txt, 2; # head up to 1st blank line - my @head = split /\n(.+):/,"\n$head"; # hashes metadata key:value pairs - shift @head; # ... - my %hash = @head; # ... - return ($txt,"") if (!keys %hash || !$hash{WebObs}); # no keys or no WebObs key = no metadata - return ($tail, "$head\n\n"); - } else { - return ('', ''); - } + if (defined($_[0]) && $_[0] ne "") { + (my $txt = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; + return ($txt,"") if (defined($WEBOBS{WIKI_MMD}) && $WEBOBS{WIKI_MMD} eq 'NO'); + return ($txt, "") if ($txt !~ /\n\s*\n/); # no blank line means no chance for metadata + (my $head, my $tail) = split /\n\s*\n/ , $txt, 2; # head up to 1st blank line + my @head = split /\n(.+):/,"\n$head"; # hashes metadata key:value pairs + shift @head; # ... + my %hash = @head; # ... + return ($txt,"") if (!keys %hash || !$hash{WebObs}); # no keys or no WebObs key = no metadata + return ($tail, "$head\n\n"); + } else { + return ('', ''); + } } =head2 WebObs Wiki language specifications: @@ -160,147 +160,148 @@ sub stripMDmetadata { sub wiki { - my $txt = $_[0]; - $txt.="\n"; + my $txt = $_[0]; + $txt.="\n"; - # --- include wiki files - $txt =~ s[\%\%(.*?)\%\%] { wfcheck($1); }egis; + # --- include wiki files + $txt =~ s[\%\%(.*?)\%\%] { wfcheck($1); }egis; - # --- remove ending ^M's - $txt =~ s/\cM\n/\n/g; + # --- remove ending ^M's + $txt =~ s/\cM\n/\n/g; - # --- \ ==>
    - $txt =~ s/\\\n/
    /g; + # --- \ ==>
    + $txt =~ s/\\\n/
    /g; - # --- ---- ==> horizontal line
    - $txt =~ s/----/
    /g; + # --- ---- ==> horizontal line
    + $txt =~ s/----/
    /g; - # --- || ==> - $txt =~ s/\|\|(.*)\|\|\n/<__row__>"; if ($clientAuth > 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."" - ."" - ."" - ."" - ."" - .($QryParm->{'sio2'} ne "" ? "":"") - .($QryParm->{'isotopes'} ne "" ? "":"") - ."" - ."\n" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .($QryParm->{'iode'} ne "" ? "":"") - .($QryParm->{'sio2'} ne "" ? "":"") - .($QryParm->{'isotopes'} ne "" ? "":"") - ."" - .""; + ."" + ."" + ."" + ."" + .($QryParm->{'sio2'} ne "" ? "":"") + .($QryParm->{'isotopes'} ne "" ? "":"") + ."" + ."\n" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .($QryParm->{'iode'} ne "" ? "":"") + .($QryParm->{'sio2'} ne "" ? "":"") + .($QryParm->{'isotopes'} ne "" ? "":"") + ."" + .""; $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - $i++; - if ($rap[$i] == 1) { - $entete = $entete.""; - } + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + $i++; + if ($rap[$i] == 1) { + $entete = $entete.""; + } } - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date;$heure;Code Site;$site;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;$d13C;$d18O;$dD;Cond25;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) - && ($id > 0 || $clientAuth == 4) - && ($date le $endDate) && ($date ge $startDate)) { - - my ($cLi_mmol,$cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cF_mmol,$cCl_mmol,$cBr_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol,$cI_mmol,$cSiO2_mmol); - $cLi_mmol=$cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cF_mmol=$cCl_mmol=$cBr_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=$cI_mmol=$cSiO2_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; - my $cond25 = ""; - my $nicb = ""; - my @rapv; - my $iv = 0; - my $rapport = ""; - - if ($cLi ne "") { $cLi_mmol = $cLi/$GMOL{Li}; }; - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cF ne "") { $cF_mmol = $cF/$GMOL{F}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cBr ne "") { $cBr_mmol = $cBr/$GMOL{Br}; }; - if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($cI ne "") { $cI_mmol = 0.001*$cI/$GMOL{I}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - if (($cond ne "") && ($tSource ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tSource - 25))); }; - $tzp = $cLi_mmol + $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; - if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cF_mmol + $cCl_mmol + $cBr_mmol + $cNO3_mmol + 2*$cSO4_mmol + $cHCO3_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - for (@rapports) { - my ($num,$den,$nrp) = split(/\|/,$_); - $iv++; - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - if ($rap[$iv] == 1) { - $rapport = $rapport.""; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { - $lien = "$aliasSite"; - } - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('id' => $id, 'return_url' => $return_url); - $modif = qq(); - $efface = qq(); - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte.""; - } - $texte = $texte.""; - $txt = "$date;$heure;$site;$aliasSite;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;"; - if ($QryParm->{'unite'} eq "mmol") { - for ("Li","Na","K","Mg","Ca","F","Cl","Br","NO3","SO4","HCO3","I","SiO2") { - if ($QryParm->{'iode'} ne "" || $_ ne "I") { - $texte .= ""; - } - } - $txt .= "$cLi_mmol;$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cF_mmol;$cCl_mmol;$cBr_mmol;$cNO3_mmol;$cSO4_mmol;$cHCO3_mmol;$cI_mmol;$cSiO2_mmol;"; - } else { - $texte .= "" - .($QryParm->{'iode'} ne ""?"":"") - .($QryParm->{'sio2'} ne ""?"":""); - $txt .= "$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;"; - } - if ($QryParm->{'isotopes'} ne "") { - $texte .= ""; - } - $texte .= ""; - if ($nicb and ($nicb < -20) || ($nicb > 20)) { - $texte .= "$rapport\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date;$heure;Code Site;$site;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;$d13C;$d18O;$dD;Cond25;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) + && ($id > 0 || $clientAuth == 4) + && ($date le $endDate) && ($date ge $startDate)) { + + my ($cLi_mmol,$cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cF_mmol,$cCl_mmol,$cBr_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol,$cI_mmol,$cSiO2_mmol); + $cLi_mmol=$cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cF_mmol=$cCl_mmol=$cBr_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=$cI_mmol=$cSiO2_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + my $cond25 = ""; + my $nicb = ""; + my @rapv; + my $iv = 0; + my $rapport = ""; + + if ($cLi ne "") { $cLi_mmol = $cLi/$GMOL{Li}; }; + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cF ne "") { $cF_mmol = $cF/$GMOL{F}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cBr ne "") { $cBr_mmol = $cBr/$GMOL{Br}; }; + if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($cI ne "") { $cI_mmol = 0.001*$cI/$GMOL{I}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + if (($cond ne "") && ($tSource ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tSource - 25))); }; + $tzp = $cLi_mmol + $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cF_mmol + $cCl_mmol + $cBr_mmol + $cNO3_mmol + 2*$cSO4_mmol + $cHCO3_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + for (@rapports) { + my ($num,$den,$nrp) = split(/\|/,$_); + $iv++; + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + if ($rap[$iv] == 1) { + $rapport = $rapport.""; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { + $lien = "$aliasSite"; + } + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('id' => $id, 'return_url' => $return_url); + $modif = qq(); + $efface = qq(); + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte.""; + } + $texte = $texte.""; + $txt = "$date;$heure;$site;$aliasSite;$type;$tAir;$tSource;$pH;$debit;$cond;$niveau;"; + if ($QryParm->{'unite'} eq "mmol") { + for ("Li","Na","K","Mg","Ca","F","Cl","Br","NO3","SO4","HCO3","I","SiO2") { + if ($QryParm->{'iode'} ne "" || $_ ne "I") { + $texte .= ""; + } + } + $txt .= "$cLi_mmol;$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cF_mmol;$cCl_mmol;$cBr_mmol;$cNO3_mmol;$cSO4_mmol;$cHCO3_mmol;$cI_mmol;$cSiO2_mmol;"; + } else { + $texte .= "" + .($QryParm->{'iode'} ne ""?"":"") + .($QryParm->{'sio2'} ne ""?"":""); + $txt .= "$cLi;$cNa;$cK;$cMg;$cCa;$cF;$cCl;$cBr;$cNO3;$cSO4;$cHCO3;$cI;$cSiO2;"; + } + if ($QryParm->{'isotopes'} ne "") { + $texte .= ""; + } + $texte .= ""; + if ($nicb and ($nicb < -20) || ($nicb > 20)) { + $texte .= "$rapport\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Number of records = $nbLignesRetenues / $nbData.

    \n", - "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}\">$fileCSV

    \n"); + "

    Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"
    $1\n/g; # all lines ||...||\n are temporary rows - $txt =~ s/\|\|//g; # then all || are - $txt =~ s/<__row__>(.*?)\n(?!<__row__>)/$1<\/TABLE>\n/sg; # now enclose successive rows in table tags - $txt =~ s/<__row__>//g; # take care of leftover temporary rows + # --- || ==>
    + $txt =~ s/\|\|(.*)\|\|\n/<__row__>"; if ($editOK) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."" - ."" - ."\n" - ."" + ."\n" + ."" } $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$d0,$d[0],$d[1],$d[2],$d[3],$d[4],$d[5],$d[6],$d[7],$d[8],$d[9],$d[10],$d[11],$d[12],$d[13],$d[14],$d[15],$d[16],$d[17],$d[18],$d[19],$rem,$val) = split(/\|/,$_); - # trie les données pour mettre les champs vides à la fin... - @d = sort { ($a eq "") <=> ($b eq "") } @d; - my $DM = ""; - my $DS = ""; - my $n = 0; - if ($i eq 0) { - push(@csv,u2l("$date;$heure;Code Site;$site;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;Dist. Moy (m);2*Sigma (m);\"$rem\";$val")); - } - elsif (($_ ne "") - && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { - - for $j(@nd) { - if ($d[$j] ne "") { - my $dd = 0; - if (($d[$j] - $d[0]) > 500) { $dd = -1; } - if (($d[$j] - $d[0]) < -500) { $dd = 1; } - $DM += $d0 + $d[$j]/1000 + $dd; # $DM = momentanément somme des x - $DS += ($d0 + $d[$j]/1000 + $dd)**2; # $DS = momentanément somme des x² - $n++; - } - } - if ($n > 0) { - $DM = $DM/$n; # $DM = moyenne - $DS = 2 * sqrt($DS/$n - $DM*$DM); # $DS = 2 * écart-type - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($editOK) { - $texte = $texte.""; - } - $texte = $texte."" - ."" - .""; - for (@nd) { - $texte = $texte.""; - } - $texte = $texte.""; - if (($DS > 0.1) || ($DS == 0)) { - $texte .= "\n"; - $txt = $txt."\"$rem\"\n"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$d0,$d[0],$d[1],$d[2],$d[3],$d[4],$d[5],$d[6],$d[7],$d[8],$d[9],$d[10],$d[11],$d[12],$d[13],$d[14],$d[15],$d[16],$d[17],$d[18],$d[19],$rem,$val) = split(/\|/,$_); + + # trie les données pour mettre les champs vides à la fin... + @d = sort { ($a eq "") <=> ($b eq "") } @d; + my $DM = ""; + my $DS = ""; + my $n = 0; + if ($i eq 0) { + push(@csv,u2l("$date;$heure;Code Site;$site;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;Dist. Moy (m);2*Sigma (m);\"$rem\";$val")); + } + elsif (($_ ne "") + && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { + + for $j(@nd) { + if ($d[$j] ne "") { + my $dd = 0; + if (($d[$j] - $d[0]) > 500) { $dd = -1; } + if (($d[$j] - $d[0]) < -500) { $dd = 1; } + $DM += $d0 + $d[$j]/1000 + $dd; # $DM = momentanément somme des x + $DS += ($d0 + $d[$j]/1000 + $dd)**2; # $DS = momentanément somme des x² + $n++; + } + } + if ($n > 0) { + $DM = $DM/$n; # $DM = moyenne + $DS = 2 * sqrt($DS/$n - $DM*$DM); # $DS = 2 * écart-type + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($editOK) { + $texte = $texte.""; + } + $texte = $texte."" + ."" + .""; + for (@nd) { + $texte = $texte.""; + } + $texte = $texte.""; + if (($DS > 0.1) || ($DS == 0)) { + $texte .= "\n"; + $txt = $txt."\"$rem\"\n"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

    \n", - "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

    \n"); + "

    Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

    \n"); if ($texte ne "") { - push(@html,"
    $1\n/g; # all lines ||...||\n are temporary rows + $txt =~ s/\|\|//g; # then all || are + $txt =~ s/<__row__>(.*?)\n(?!<__row__>)/$1<\/TABLE>\n/sg; # now enclose successive rows in table tags + $txt =~ s/<__row__>//g; # take care of leftover temporary rows - # --- - ==>
      - $txt =~ s/^-/\n-/; # to find start of list - $txt =~ s/([^\n]$)/$1\n/; # to find end of list - $txt =~ s/\n-((?:.|\n)+?)\n([^-]|$)/\n
      • $1<\/UL>$2/g; - $txt =~ s/\n-/
      • /g; + # --- - ==>
          + $txt =~ s/^-/\n-/; # to find start of list + $txt =~ s/([^\n]$)/$1\n/; # to find end of list + $txt =~ s/\n-((?:.|\n)+?)\n([^-]|$)/\n\n"; $l2 = 0; } - if ($l1==1) { print "
          • \n"; } - $l1 = 1; - if (substr($titre,0,1) eq "!") { print "*" } - print "
        • ".substr($titre,1)."\n"; - next; - } - if ($l2==0) { print "
            \n"; $l2 = 1;} - if ( substr($titre,0,1) eq "*" ){ print "*" ; $titre = substr($titre,1) } - if ($l2==1) { print " ";} - print "
          • $titre
            • \n"; + next if(/^[ ]*#/ || /^$/); + my ($titre,$lien)=split(/\|/,$_); + + # $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; + # my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; + if (substr($titre,0,1) eq "+" || substr($titre,0,1) eq "!") { + if ($l2==1) { print "
          \n"; $l2 = 0; } + if ($l1==1) { print "
          • \n"; } + $l1 = 1; + if (substr($titre,0,1) eq "!") { print "*" } + print "
        • ".substr($titre,1)."\n"; + next; + } + if ($l2==0) { print "
            \n"; $l2 = 1;} + if ( substr($titre,0,1) eq "*" ){ print "*" ; $titre = substr($titre,1) } + if ($l2==1) { print " ";} + print "
          • $titre
            • \n"; } if ($l2==1) { print "
          \n"; } if ($l1==1) { print "
          • \n"; } diff --git a/CODE/perl/notify.pl b/CODE/perl/notify.pl index 340040d3..d719d1d3 100755 --- a/CODE/perl/notify.pl +++ b/CODE/perl/notify.pl @@ -21,17 +21,16 @@ =head1 DESCRIPTION use warnings; use WebObs::Config; - my $rc = WebObs::Config::notify($ARGV[0]); if ( $rc == 0) { - printf ("Sent.\n"); - exit(0); + printf ("Sent.\n"); + exit(0); } else { - if ($rc == 98) { printf ("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); } - if ($rc == 96) { printf ("Couldn't open $WEBOBS{POSTBOARD_NPIPE}: $? $!\n"); } - if ($rc == 97) { printf ("Missing argument, nothing to notify.\n"); } - if ($rc == 99) { printf ("Invalid argument format, not a notify request\n"); } - exit($rc); + if ($rc == 98) { printf ("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); } + if ($rc == 96) { printf ("Couldn't open $WEBOBS{POSTBOARD_NPIPE}: $? $!\n"); } + if ($rc == 97) { printf ("Missing argument, nothing to notify.\n"); } + if ($rc == 99) { printf ("Invalid argument format, not a notify request\n"); } + exit($rc); } __END__ diff --git a/CODE/perl/postboard.pl b/CODE/perl/postboard.pl index e3131c13..6b168663 100755 --- a/CODE/perl/postboard.pl +++ b/CODE/perl/postboard.pl @@ -153,8 +153,9 @@ =head1 NOTES use WebObs::Users; BEGIN { - # Suppress the default fatalsToBrowser from CGI::Carp - $CGI::Carp::TO_BROWSER = 0; + + # Suppress the default fatalsToBrowser from CGI::Carp + $CGI::Carp::TO_BROWSER = 0; } # ---- parse options @@ -171,15 +172,15 @@ BEGIN # ---- initialize : pid file and logging # ---------------------------------------------------------------------------- if (!$WEBOBS{ROOT_LOGS}) { - printf(STDERR "Cannot start: ROOT_LOGS not found in WebObs configuration\n"); - exit(98); + printf(STDERR "Cannot start: ROOT_LOGS not found in WebObs configuration\n"); + exit(98); } # Open log file my $LOGNAME = "$WEBOBS{ROOT_LOGS}/$ME.log" ; if (! open(LOG, ">>", $LOGNAME)) { - print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); - exit(98); + print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); + exit(98); } select((select(LOG), $|=1)[0]); # turn off buffering logit("------------------------------------------------------------------------"); @@ -187,9 +188,9 @@ BEGIN # ---- is fifo name defined ? # ---------------------------------------------------------------------------- if (!defined($WEBOBS{POSTBOARD_NPIPE})) { - logit("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration"); - printf("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); - exit(98); + logit("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration"); + printf("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); + exit(98); } # ---- should we (re)-create fifo (when missing or -c(lean) requested) ? @@ -198,12 +199,12 @@ BEGIN my $FIFO = $WEBOBS{POSTBOARD_NPIPE}; unlink $FIFO if (-p $FIFO && $clean); if (! -p $FIFO) { - umask 0011; - if (! mkfifo($FIFO, 0777)) { - logit("Can't start: couldn't mkfifo $FIFO: $!"); - printf("Can't start: couldn't mkfifo $FIFO: $!\n"); - exit(98); - } + umask 0011; + if (! mkfifo($FIFO, 0777)) { + logit("Can't start: couldn't mkfifo $FIFO: $!"); + printf("Can't start: couldn't mkfifo $FIFO: $!\n"); + exit(98); + } } # ---- need to tell someone when I'm taken down ! @@ -220,288 +221,297 @@ BEGIN while (1) { - my $queued = ; # input looks like "timestamp | event-name | emitting-pid | message" - $queued =~ tr/\0/\n/; # x00 assumed instead of \n in pipe, translate back - chomp $queued; - #?? todo: check for queued enclosed in my defined-delimiters ==> my implementation of boundaries to - #?? validate non-interleaved msg from other writing-ends ??? - my @REQ = split(/\|/, $queued); - - # The message argument may be empty (in case of action without argument). - if (@REQ == 3) { - push(@REQ, ''); - } - - if (@REQ != 4) { - logit("ignoring invalid request [@REQ]"); - next; - } - - WebObs::Users::refreshUsers(); - - # shorten the message just for verbose mode display - my $shortreq3 = (length($REQ[3]) > 33) ? substr($REQ[3],0,15)."...".substr($REQ[3],-15) : $REQ[3]; - $shortreq3 =~ s/\n//g; - logit("got event [$REQ[1]] from $REQ[2] saying [$REQ[0] - $shortreq3]") if ($verbose); - my $sql = my $eventclause = ''; - my $validclause = " validity = 'Y' "; - - # ---- process emailing if we know how to do it and have mailid(s) for this event $REQ[1] - if (defined($WEBOBS{POSTBOARD_MAILER})) { - $WEBOBS{POSTBOARD_MAILER_OPTS} ||= ''; - $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT} ||= "notify"; - - my $allMails = fetch_emails($REQ[1]); - - if (not @$allMails) { - logit("no mailing for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); - } else { - - for my $row (@$allMails) { - - my @oneMAIL = @$row; - my @oneREQ = @REQ; # save original request (maybe overkill) - - # Parse the incoming request's message ($oneREQ[3]): look for special keywords - # Message syntax is: [any text][keyword=[value-allowing-embedded-blanks]...] - # no | allowed in message; no keyword in 'any text' of course - # $px will be set to 'any text' - # %sp will gather parsed keywords as $sp{'keyword='} = 'value' (trimmed) - my $re = join('|', ('rc', 'cmd', 'log', 'uid', 'org', 'file', 'subject', 'attach')); - my ($px, %sp) = map { s/^\s+|\s+$//gr } split(/((?:$re)=)\s*/, $oneREQ[3]); - - # Any event's message can override defaults found in table 'notifications' - # uid= - if ($sp{'uid='}) { - if ($USERIDS{$sp{'uid='}}) { - $oneMAIL[0] = $sp{'uid='}; - } else { - logit("warning: ignoring unknown recipient uid in $oneREQ[3]"); - } - } - # subject= - if (defined($sp{'subject='})) { - $oneMAIL[1] = $sp{'subject='}; - } - # attach= - if (defined($sp{'attach='})) { - $oneMAIL[2] = $sp{'attach='}; - } - - # Intercept the special 'submitrc.jid' event for special email formatting - if ($oneREQ[1] =~ s/^submitrc\.//) { - $oneREQ[3] = ""; # create a brand new $oneREQ[3] for normal mail processing below - if (defined($sp{'org='}) && $sp{'org='} =~ m/^R/) { - # it is an end-of-request (submit) : - $oneMAIL[1] = "request $oneREQ[1] has ended"; - $oneREQ[3] .= "request submitted by "; - $oneREQ[3] .= $sp{'uid='} ? "$sp{'uid='}\n" : "* unspecified uid *\n" ; - } else { - # it is an end-of-scheduled job : - $oneMAIL[1] = "scheduled job $oneREQ[1] has ended"; - # ignore this mail (ie. do NOT send) if an rc-condition is not met - next if (defined($sp{'rc='}) && !rccond($oneMAIL[4],$sp{'rc='})); - } - if (defined($sp{'cmd='})) { - $oneREQ[3] .= "Command = $sp{'cmd='}\n"; - } - if (defined($sp{'rc='})) { - $oneREQ[3] .= "Ended with rc=$sp{'rc='}\n"; - } - if (defined($sp{'log='})) { - $sp{'log='} =~ s/[\[\] ]//g; - $oneREQ[3] .= "Log = $WEBOBS{ROOT_URL}/cgi-bin/index.pl?page=/cgi-bin/schedulerLogs.pl?log=$sp{'log='}\n"; - } - if ($px ne '') { - $oneREQ[3] .= "\n$px\n"; - } - } else { - # event other than '^submitrc\.' - $oneREQ[3] = $px if ($px); - } - - # Continue with mail processing - my $allAddrs = fetch_email_addrs($oneMAIL[0]); - - if (not @$allAddrs) { - logit("error: recipient uid/gid '$oneMAIL[0]' " - ."not found in database, aborting mailing."); - } else { - my $addrlist = join(' ', map { $_->[0] } @$allAddrs); - if (not $addrlist) { - logit("warning: no email address defined for recipient" - ." uid/gid '$oneMAIL[0]', aborting mailing."); - } else { - my $options = $WEBOBS{POSTBOARD_MAILER_OPTS}; - if ($oneMAIL[1] and $oneMAIL[1] ne '-') { - $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $oneMAIL[1]\'"; - } else { - $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT}\'"; - } - if ($oneMAIL[2] and $oneMAIL[2] ne '-' and -e $oneMAIL[2]) { - $options .= " -a \'$oneMAIL[2]\'"; - } - if ($oneREQ[2] =~ m/^([^.@]+)(\.[^.@]+)*@(([^.@]+\.)+([^.@]+))$/) { - my $domain = $3; - my $fulln = ''; - for my $login (keys(%USERS)) { - if ($USERS{$login}{EMAIL} =~ m/^$oneREQ[2]/) { - $fulln = $USERS{$login}{FULLNAME}; - } - } - if ($fulln ne '') { - $options .= qq( -e 'set from="$fulln <$oneREQ[2]>"'); - } - } - my $tmp_email_body = sprintf ("$WEBOBS{PATH_TMP_APACHE}/WOPB.$$.%16.6f", time); - if (open(my $body_file, ">", $tmp_email_body)) { - print $body_file "$oneREQ[3]" ; - if ($sp{'file='} && -f "$sp{'file='}") { - print $body_file "\n", read_file($sp{'file='}); - } - close $body_file - or logit("warning: an error occurred while closing $tmp_email_body"); - logit("executing '$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body'") if ($verbose); - system("$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body"); - if ($?) { logit("error: mailing failed: $?") } - unlink($tmp_email_body); - } else { - logit("error: couldn't open temporary file for mailing: $?"); - } - } # end we have non-empty email address(es) for this mail - } # end we have recipient(s) for this mail - } # end for each mail - } # we have mailing(s) in table for this event - } # end we know how to mail from config setting - - # ---- process action(s) if we have any for this event - my $allActions = fetch_actions($REQ[1]); - - if (@$allActions) { - for my $action (@$allActions) { - my $cmd = sprintf("%s %s", $action->[0], $REQ[3]); - logit("executing action '$cmd'") if ($verbose); - system($cmd); - if ($?) { logit("action command [$cmd] failed: $?: $!") } - } - } else { - logit("no actions for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); - } + my $queued = ; # input looks like "timestamp | event-name | emitting-pid | message" + $queued =~ tr/\0/\n/; # x00 assumed instead of \n in pipe, translate back + chomp $queued; + +#?? todo: check for queued enclosed in my defined-delimiters ==> my implementation of boundaries to +#?? validate non-interleaved msg from other writing-ends ??? + my @REQ = split(/\|/, $queued); + + # The message argument may be empty (in case of action without argument). + if (@REQ == 3) { + push(@REQ, ''); + } + + if (@REQ != 4) { + logit("ignoring invalid request [@REQ]"); + next; + } + + WebObs::Users::refreshUsers(); + + # shorten the message just for verbose mode display + my $shortreq3 = (length($REQ[3]) > 33) ? substr($REQ[3],0,15)."...".substr($REQ[3],-15) : $REQ[3]; + $shortreq3 =~ s/\n//g; + logit("got event [$REQ[1]] from $REQ[2] saying [$REQ[0] - $shortreq3]") if ($verbose); + my $sql = my $eventclause = ''; + my $validclause = " validity = 'Y' "; + +# ---- process emailing if we know how to do it and have mailid(s) for this event $REQ[1] + if (defined($WEBOBS{POSTBOARD_MAILER})) { + $WEBOBS{POSTBOARD_MAILER_OPTS} ||= ''; + $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT} ||= "notify"; + + my $allMails = fetch_emails($REQ[1]); + + if (not @$allMails) { + logit("no mailing for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); + } else { + + for my $row (@$allMails) { + + my @oneMAIL = @$row; + my @oneREQ = @REQ; # save original request (maybe overkill) + +# Parse the incoming request's message ($oneREQ[3]): look for special keywords +# Message syntax is: [any text][keyword=[value-allowing-embedded-blanks]...] +# no | allowed in message; no keyword in 'any text' of course +# $px will be set to 'any text' +# %sp will gather parsed keywords as $sp{'keyword='} = 'value' (trimmed) + my $re = join('|', ('rc', 'cmd', 'log', 'uid', 'org', 'file', 'subject', 'attach')); + my ($px, %sp) = map { s/^\s+|\s+$//gr } split(/((?:$re)=)\s*/, $oneREQ[3]); + + # Any event's message can override defaults found in table 'notifications' + # uid= + if ($sp{'uid='}) { + if ($USERIDS{$sp{'uid='}}) { + $oneMAIL[0] = $sp{'uid='}; + } else { + logit("warning: ignoring unknown recipient uid in $oneREQ[3]"); + } + } + + # subject= + if (defined($sp{'subject='})) { + $oneMAIL[1] = $sp{'subject='}; + } + + # attach= + if (defined($sp{'attach='})) { + $oneMAIL[2] = $sp{'attach='}; + } + + # Intercept the special 'submitrc.jid' event for special email formatting + if ($oneREQ[1] =~ s/^submitrc\.//) { + $oneREQ[3] = ""; # create a brand new $oneREQ[3] for normal mail processing below + if (defined($sp{'org='}) && $sp{'org='} =~ m/^R/) { + + # it is an end-of-request (submit) : + $oneMAIL[1] = "request $oneREQ[1] has ended"; + $oneREQ[3] .= "request submitted by "; + $oneREQ[3] .= $sp{'uid='} ? "$sp{'uid='}\n" : "* unspecified uid *\n" ; + } else { + + # it is an end-of-scheduled job : + $oneMAIL[1] = "scheduled job $oneREQ[1] has ended"; + + # ignore this mail (ie. do NOT send) if an rc-condition is not met + next if (defined($sp{'rc='}) && !rccond($oneMAIL[4],$sp{'rc='})); + } + if (defined($sp{'cmd='})) { + $oneREQ[3] .= "Command = $sp{'cmd='}\n"; + } + if (defined($sp{'rc='})) { + $oneREQ[3] .= "Ended with rc=$sp{'rc='}\n"; + } + if (defined($sp{'log='})) { + $sp{'log='} =~ s/[\[\] ]//g; + $oneREQ[3] .= "Log = $WEBOBS{ROOT_URL}/cgi-bin/index.pl?page=/cgi-bin/schedulerLogs.pl?log=$sp{'log='}\n"; + } + if ($px ne '') { + $oneREQ[3] .= "\n$px\n"; + } + } else { + + # event other than '^submitrc\.' + $oneREQ[3] = $px if ($px); + } + + # Continue with mail processing + my $allAddrs = fetch_email_addrs($oneMAIL[0]); + + if (not @$allAddrs) { + logit("error: recipient uid/gid '$oneMAIL[0]' " + ."not found in database, aborting mailing."); + } else { + my $addrlist = join(' ', map { $_->[0] } @$allAddrs); + if (not $addrlist) { + logit("warning: no email address defined for recipient" + ." uid/gid '$oneMAIL[0]', aborting mailing."); + } else { + my $options = $WEBOBS{POSTBOARD_MAILER_OPTS}; + if ($oneMAIL[1] and $oneMAIL[1] ne '-') { + $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $oneMAIL[1]\'"; + } else { + $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT}\'"; + } + if ($oneMAIL[2] and $oneMAIL[2] ne '-' and -e $oneMAIL[2]) { + $options .= " -a \'$oneMAIL[2]\'"; + } + if ($oneREQ[2] =~ m/^([^.@]+)(\.[^.@]+)*@(([^.@]+\.)+([^.@]+))$/) { + my $domain = $3; + my $fulln = ''; + for my $login (keys(%USERS)) { + if ($USERS{$login}{EMAIL} =~ m/^$oneREQ[2]/) { + $fulln = $USERS{$login}{FULLNAME}; + } + } + if ($fulln ne '') { + $options .= qq( -e 'set from="$fulln <$oneREQ[2]>"'); + } + } + my $tmp_email_body = sprintf ("$WEBOBS{PATH_TMP_APACHE}/WOPB.$$.%16.6f", time); + if (open(my $body_file, ">", $tmp_email_body)) { + print $body_file "$oneREQ[3]" ; + if ($sp{'file='} && -f "$sp{'file='}") { + print $body_file "\n", read_file($sp{'file='}); + } + close $body_file + or logit("warning: an error occurred while closing $tmp_email_body"); + logit("executing '$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body'") if ($verbose); + system("$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body"); + if ($?) { logit("error: mailing failed: $?") } + unlink($tmp_email_body); + } else { + logit("error: couldn't open temporary file for mailing: $?"); + } + } # end we have non-empty email address(es) for this mail + } # end we have recipient(s) for this mail + } # end for each mail + } # we have mailing(s) in table for this event + } # end we know how to mail from config setting + + # ---- process action(s) if we have any for this event + my $allActions = fetch_actions($REQ[1]); + + if (@$allActions) { + for my $action (@$allActions) { + my $cmd = sprintf("%s %s", $action->[0], $REQ[3]); + logit("executing action '$cmd'") if ($verbose); + system($cmd); + if ($?) { logit("action command [$cmd] failed: $?: $!") } + } + } else { + logit("no actions for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); + } } # end of while (1) endit(99); - # Function definitions -------------------------------------------------------- sub db_connect { - # Open a connection to a SQLite database - # - # Usage example: - # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) - # || die "Error connecting to $dbname: $DBI::errstr"; - # - my $dbname = shift; - return DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) -} + # Open a connection to a SQLite database + # + # Usage example: + # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) + # || die "Error connecting to $dbname: $DBI::errstr"; + # + my $dbname = shift; + return DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) +} sub get_subscriptions_clause { - # Build and return the SQL 'where' clause to select subscriptions - # corresponding to the event. - my $event_name = shift; - my $where; - - if ($event_name =~ m/^submitrc\.(.*)$/) { - # Event is 'submitrc.{something}': grab subscriptions for - # 'submitrc.', 'submitrc.rc*', and 'submitrc.something.rc*' - return "(event = 'submitrc.' OR event LIKE 'submitrc.rc%' OR event LIKE 'submitrc.$1.rc%')"; - } - if ($event_name =~ m/^([^\.]*)\.(.*)$/) { - # Event is 'majorid.{minorid}': grab 'majorid.' + 'majorid.minorid' subscriptions - return "(event = '$event_name' OR event = '$1.')"; - } - # Event is 'majorid': grab 'majorid' subscriptions - return "event = '$event_name'"; -} + # Build and return the SQL 'where' clause to select subscriptions + # corresponding to the event. + my $event_name = shift; + my $where; -sub fetch_all { - # Connect to a database, run the given SQL statement, and - # return a reference to an array of array references. - my $dbname = shift; - my $query = shift; - - my $dbh = db_connect($dbname); - if (not $dbh) { - logit("Error connecting to $dbname: $DBI::errstr"); - return; - } - # Will raise an error if anything goes wrong - my $ref = $dbh->selectall_arrayref($query); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $dbname: " - . $dbh->errstr; - return $ref; + if ($event_name =~ m/^submitrc\.(.*)$/) { + + # Event is 'submitrc.{something}': grab subscriptions for + # 'submitrc.', 'submitrc.rc*', and 'submitrc.something.rc*' + return "(event = 'submitrc.' OR event LIKE 'submitrc.rc%' OR event LIKE 'submitrc.$1.rc%')"; + } + if ($event_name =~ m/^([^\.]*)\.(.*)$/) { + +# Event is 'majorid.{minorid}': grab 'majorid.' + 'majorid.minorid' subscriptions + return "(event = '$event_name' OR event = '$1.')"; + } + + # Event is 'majorid': grab 'majorid' subscriptions + return "event = '$event_name'"; } +sub fetch_all { -sub fetch_emails { - # Return the list of email subscriptions for an event - my $event_name = shift; - my $where_event = get_subscriptions_clause($event_name); - my $q = "SELECT uid,mailsubject,mailattach,validity,event" - ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." WHERE uid != '-' AND validity = 'Y' AND $where_event"; - - return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); + # Connect to a database, run the given SQL statement, and + # return a reference to an array of array references. + my $dbname = shift; + my $query = shift; + + my $dbh = db_connect($dbname); + if (not $dbh) { + logit("Error connecting to $dbname: $DBI::errstr"); + return; + } + + # Will raise an error if anything goes wrong + my $ref = $dbh->selectall_arrayref($query); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $dbname: " + . $dbh->errstr; + return $ref; } +sub fetch_emails { -sub fetch_actions { - # Return the list of actions for an event - my $event_name = shift; - my $where_event = get_subscriptions_clause($event_name); - my $q = "SELECT action FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." WHERE action != '-' AND validity = 'Y' AND $where_event"; + # Return the list of email subscriptions for an event + my $event_name = shift; + my $where_event = get_subscriptions_clause($event_name); + my $q = "SELECT uid,mailsubject,mailattach,validity,event" + ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." WHERE uid != '-' AND validity = 'Y' AND $where_event"; - return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); + return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); } +sub fetch_actions { -sub fetch_email_addrs { - # Return the list of email addresses for a user or a group - my $id = shift; # user or group id - my $q = "SELECT email FROM $WEBOBS{SQL_TABLE_USERS}" - ." WHERE uid = '$id'" - ." OR uid IN (SELECT uid FROM groups WHERE gid='$id')"; + # Return the list of actions for an event + my $event_name = shift; + my $where_event = get_subscriptions_clause($event_name); + my $q = "SELECT action FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." WHERE action != '-' AND validity = 'Y' AND $where_event"; - return fetch_all($WEBOBS{SQL_DB_USERS}, $q); + return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); } +sub fetch_email_addrs { + # Return the list of email addresses for a user or a group + my $id = shift; # user or group id + my $q = "SELECT email FROM $WEBOBS{SQL_TABLE_USERS}" + ." WHERE uid = '$id'" + ." OR uid IN (SELECT uid FROM groups WHERE gid='$id')"; + + return fetch_all($WEBOBS{SQL_DB_USERS}, $q); +} # ---------------------------------------------------------- # read mail contents from a file into a scalar # ---------------------------------------------------------- sub read_file { - my $filename = shift; - my $file; - my $content = ""; - if (not (defined($filename) && open($file, $filename))) { - logit("warning: couldn't read $filename"); - return; - } - local $/ = undef; - $content = <$file>; - close($file) or logit("warning: an error occured while closing $filename"); - return $content; + my $filename = shift; + my $file; + my $content = ""; + if (not (defined($filename) && open($file, $filename))) { + logit("warning: couldn't read $filename"); + return; + } + local $/ = undef; + $content = <$file>; + close($file) or logit("warning: an error occured while closing $filename"); + return $content; } # ---------------------------------------------------------- @@ -513,42 +523,42 @@ sub read_file { # eg: rccond ('submitrc.jidx.rc>=0, 0) returns true (1) # ---------------------------------------------------------- sub rccond { - return 1 if (@_ != 2); - return eval "($_[1] $1 $2)"?1:0 if ($_[0] =~ m/submitrc\..*rc([=>>$LOGNAME")) { - print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); - exit(1); + print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); + exit(1); } # ---- initialize: internal structures @@ -391,39 +392,39 @@ BEGIN $CFGF = $WEBOBS{CONF_SCHEDULER} if ($CFGF eq '' && -e $WEBOBS{CONF_SCHEDULER}); %SCHED = readCfg($CFGF); if ( scalar(keys(%SCHED)) <= 1 ) { - logit("scheduler can't start: no or invalid configuration file"); - printf("scheduler can't start: no or invalid configuration file\n"); - myexit(1); + logit("scheduler can't start: no or invalid configuration file"); + printf("scheduler can't start: no or invalid configuration file\n"); + myexit(1); } if ( !defined($SCHED{SQL_DB_JOBS}) ) { - logit("scheduler can't start: no JOBS database"); - printf("scheduler can't start: no JOBS database\n"); - myexit(1); + logit("scheduler can't start: no JOBS database"); + printf("scheduler can't start: no JOBS database\n"); + myexit(1); } # ---- UDP non-blocking socket, for incoming users requests # ----------------------------------------------------------------------------- my $SOCK = IO::Socket::INET->new( - 'LocalAddr' => $SCHED{LISTEN_ADDR} || 'localhost', - 'LocalPort' => $SCHED{PORT}, - 'Proto' => 'udp', - 'Blocking' => 0, -); + 'LocalAddr' => $SCHED{LISTEN_ADDR} || 'localhost', + 'LocalPort' => $SCHED{PORT}, + 'Proto' => 'udp', + 'Blocking' => 0, + ); my $sock_desc = sprintf("UDP socket %s:%d", $SCHED{LISTEN_ADDR} || 'localhost', - $SCHED{PORT}); + $SCHED{PORT}); if (!$SOCK) { - my $err = "scheduler[$$] cannot start because of $sock_desc error: $!"; - logit($err); - printf($err); - myexit(1); + my $err = "scheduler[$$] cannot start because of $sock_desc error: $!"; + logit($err); + printf($err); + myexit(1); } # ---- system load averages access+interpretation setups # ----------------------------------------------------------------------------- if (open FILE, "< /proc/cpuinfo") { - $ncpus = scalar grep(/^processor\s+:/,); - close FILE; + $ncpus = scalar grep(/^processor\s+:/,); + close FILE; } our ($avg1,$avg5,$avg15) = 0; # work-vars for sys load averages @@ -431,27 +432,27 @@ BEGIN # ----------------------------------------------------------------------------- system("mkdir -p $SAVELOGPATH"); if ( ! -d "$SAVELOGPATH" ) { - logit("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!"); - printf("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!\n"); - myexit(1); + logit("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!"); + printf("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!\n"); + myexit(1); } # --- root of all jobs' logs (STDOUT/STDERR redirections) directories # ----------------------------------------------------------------------------- system("mkdir -p $SCHED{PATH_STD}"); if ( ! -d $SCHED{PATH_STD} ) { - logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!"); - printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!\n"); - myexit(1); + logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!"); + printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!\n"); + myexit(1); } # --- root of all jobs' 'resource' (enq=locks) directories # ----------------------------------------------------------------------------- system("mkdir -p $SCHED{PATH_RES}"); if ( ! -d $SCHED{PATH_RES} ) { - logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!"); - printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!\n"); - myexit(1); + logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!"); + printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!\n"); + myexit(1); } system("rm -f $SCHED{PATH_RES}/*"); @@ -507,24 +508,24 @@ BEGIN # ---- make sure that all past runs are marked as ended for reporting purposes # ---- since we have no more knowledge/control over them when (re)starting if (defined($SCHED{CLEANUP_RUNS}) && $SCHED{CLEANUP_RUNS} ne '') { - my ($zrc, $zmsg) = split(/,/, $SCHED{CLEANUP_RUNS}); - $zrc ||= 999; - $zmsg ||= 'zombie'; - my $ztime = time; - my $q = "UPDATE runs SET endts=$ztime,rc=$zrc,rcmsg='$zmsg' WHERE endts=0"; - - my $dbh = db_connect($SCHED{SQL_DB_JOBS}); - if (not $dbh) { - logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); - myexit(1); - } - my $rv = $dbh->do($q); - $rv = 0 if ($rv == 0E0); - logit("cleaned up zombie runs: $rv"); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " - . $dbh->errstr; + my ($zrc, $zmsg) = split(/,/, $SCHED{CLEANUP_RUNS}); + $zrc ||= 999; + $zmsg ||= 'zombie'; + my $ztime = time; + my $q = "UPDATE runs SET endts=$ztime,rc=$zrc,rcmsg='$zmsg' WHERE endts=0"; + + my $dbh = db_connect($SCHED{SQL_DB_JOBS}); + if (not $dbh) { + logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); + myexit(1); + } + my $rv = $dbh->do($q); + $rv = 0 if ($rv == 0E0); + logit("cleaned up zombie runs: $rv"); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " + . $dbh->errstr; } # ---- loop forever handling commands and jobs to be started @@ -532,35 +533,35 @@ BEGIN # SCHEDULING LOOP - # wait (sleep) for next clock tick - # start clock tick processing - # decrement current BEAT count: it will trigger actual job scheduling when reaching 0 - # check the non-blocking UDP socket for clients' commands: - # processes 'commands' and also queues 'job requests' in JOBRQ - # leave (ignore) this tick if in PAUSE mode or not yet reach BEAT (not 0) - # at each BEAT tick (BEAT = 0) - # restore BEAT count - # decrement time in JOBQ for all jobs there, cancel them if needed - # triggers REAPER and ignore this tick if max number of forked kids reached - # ignore this tick if current system load too high (SYSLOAD) - # select candidate jobs for this BEAT tick from JOBRQ and JOBS DataBase - # all JOBRQ jobs - # + DataBase jobs whose last 'run' is older than their defined RUNINTERVAL. - # applying LMISS or EMISS biases to slow down 'candidate not forked loop' - # loop thru all candidate jobs: - # build job's execution command (kidcmd) as its XEQ1 + XEQ2 + XEQ3 - # insert into the RUNQ a candidate job that is allowed to be forked: - # having its defined MAXSYSLOAD less than the current system load 5' average - # may ENQ its defined resource - # candidates not eligible to RUNQ and coming from JOBRQ will 'return' to JOBRQ - # fork a kid to execute job - # kid's code inherits from parent's variables at time of fork - # kid's code triggers a system 'exec kidcmd' - # links kid's pid to runQ's id (both ways) for the job just started - # triggers REAPER that processes ended kids if any (non-blocking waitpid for kids) - # cleanup kids'/job's references - # update DataBase with 'last run' information for job - # loop after adjusting next wait time (loop execution drift) +# wait (sleep) for next clock tick +# start clock tick processing +# decrement current BEAT count: it will trigger actual job scheduling when reaching 0 +# check the non-blocking UDP socket for clients' commands: +# processes 'commands' and also queues 'job requests' in JOBRQ +# leave (ignore) this tick if in PAUSE mode or not yet reach BEAT (not 0) +# at each BEAT tick (BEAT = 0) +# restore BEAT count +# decrement time in JOBQ for all jobs there, cancel them if needed +# triggers REAPER and ignore this tick if max number of forked kids reached +# ignore this tick if current system load too high (SYSLOAD) +# select candidate jobs for this BEAT tick from JOBRQ and JOBS DataBase +# all JOBRQ jobs +# + DataBase jobs whose last 'run' is older than their defined RUNINTERVAL. +# applying LMISS or EMISS biases to slow down 'candidate not forked loop' +# loop thru all candidate jobs: +# build job's execution command (kidcmd) as its XEQ1 + XEQ2 + XEQ3 +# insert into the RUNQ a candidate job that is allowed to be forked: +# having its defined MAXSYSLOAD less than the current system load 5' average +# may ENQ its defined resource +# candidates not eligible to RUNQ and coming from JOBRQ will 'return' to JOBRQ +# fork a kid to execute job +# kid's code inherits from parent's variables at time of fork +# kid's code triggers a system 'exec kidcmd' +# links kid's pid to runQ's id (both ways) for the job just started +# triggers REAPER that processes ended kids if any (non-blocking waitpid for kids) +# cleanup kids'/job's references +# update DataBase with 'last run' information for job +# loop after adjusting next wait time (loop execution drift) # Alert of the start of the scheduler (the same way we alert of its shutdown) notifyit("scheduler.critical|$$|scheduler is starting"); @@ -568,189 +569,193 @@ BEGIN our $BEAT = $SCHED{BEAT}; while (1) { - my $psdmsg = sprintf ("%u %s wait %d (d=%f,beat=%d)", $$,$PAUSED?" paused":"",int($adjutick),$adjutick-int($adjutick),$BEAT); - logit($psdmsg) if ($verbose2); - usleep(int($adjutick)); - - my $t0 = [gettimeofday]; - $BEAT-- if (!$PAUSED); - - UDPS(); - if (!$PAUSED && !$BEAT) { - $BEAT = $SCHED{BEAT}; - TTLJOBRQ(); - if (REAPER() == $SCHED{MAX_CHILDREN}) { - notifyit("scheduler.critical|$$|Maximum number of started processes reached"); - next; - }; - if (SYSLOAD()) { - notifyit("scheduler.critical|$$|Loadavg thresholds reached"); - next; - } - CANDIDATES(); - if ($verbose2) { - logit(scalar(keys(%CANDIDATES))." candidate(s): "); - for my $c (keys(%CANDIDATES)) { - logit(" $CANDIDATES{$c}{JID}: $CANDIDATES{$c}{XEQ1} $CANDIDATES{$c}{XEQ2} $CANDIDATES{$c}{XEQ3} "); - } - } - for my $rid (keys(%CANDIDATES)) { - # build the actual command to be executed from components XEQx - - # no leading/trailing blanks in EACH components THEN derefrence $WEBOBS{} variables - $CANDIDATES{$rid}{XEQ1} =~ s/^\s+|\s+$//g; - $CANDIDATES{$rid}{XEQ2} =~ s/^\s+|\s+$//g; - $CANDIDATES{$rid}{XEQ3} =~ s/^\s+|\s+$//g; - - my $kidcmd = "$CANDIDATES{$rid}{XEQ1} $CANDIDATES{$rid}{XEQ2} $CANDIDATES{$rid}{XEQ3}"; - $kidcmd =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; - - # check if eligible for RUNQ ? - if ($CANDIDATES{$rid}{MAXSYSLOAD} <= $avg5) { - logit("jid($CANDIDATES{$rid}{JID}) candidate but CpuLoad too high"); - notifyit("scheduler.warning|$$|Job [ $CANDIDATES{$rid}{JID} ] candidate but CpuLoad too high"); - if ($SCHED{LMISS_BIAS}>0) { - $LMISS{$CANDIDATES{$rid}{JID}} = time; - } - next; - } - if (ENQ($CANDIDATES{$rid}{RES},$CANDIDATES{$rid}{JID}) == 1) { - logit("jid($CANDIDATES{$rid}{JID}) candidate but Resource busy"); - if ($SCHED{EMISS_BIAS}>0) { - $EMISS{$CANDIDATES{$rid}{JID}} = time; - } - next; - } - - # candidate is eligible, remove it from JOBRQ if it came in that way - if ($CANDIDATES{$rid}{ORG} eq "R") { - logit("rid $rid jid($CANDIDATES{$rid}{JID}) candidate, removed from JOBRQ") if ($verbose); - delete($JOBRQ{$rid}) - } - - # create the RUNQ structure for this job - my $Qid = $rid; - $RUNQ{$Qid}{kidcmd} = $kidcmd; - $RUNQ{$Qid}{kid} = 0; - $RUNQ{$Qid}{res} = $CANDIDATES{$rid}{RES} ; - $RUNQ{$Qid}{jid} = $CANDIDATES{$rid}{JID}; - $RUNQ{$Qid}{uid} = $CANDIDATES{$rid}{UID}; - $RUNQ{$Qid}{ORG} = $CANDIDATES{$rid}{ORG}; - - # take care of stdout/err redirections and targets - my $redir = '>'; - (my $RTNE_ = $CANDIDATES{$rid}{XEQ2}) =~ s/\s+/_/g; - $CANDIDATES{$rid}{LOGPATH} ||= $RTNE_ ; - if ($CANDIDATES{$rid}{LOGPATH} =~ m/(^>{1,2})(.*)$/) { - $redir = $1; - $CANDIDATES{$rid}{LOGPATH} = $2; - } - - $RUNQ{$Qid}{started} = time; - $CANDIDATES{$rid}{LOGPATH} =~ s/\{TS\}/$RUNQ{$Qid}{started}/g ; - $CANDIDATES{$rid}{LOGPATH} =~ s/\{RTNE\}/$RTNE_/g ; - my ($logfn, $logfd) = fileparse($CANDIDATES{$rid}{LOGPATH}); - $logfd =~ s|/$||; # Remove trailing slash from the dir - $RUNQ{$Qid}{logfd} = $logfd; - $RUNQ{$Qid}{logfn} = $logfn; - - # from now on we don't need the $CANDIDATES{$rid} anymore - delete($CANDIDATES{$rid}); - make_path("$SCHED{PATH_STD}/$logfd"); - - $RUNQ{$Qid}{kidcmd} =~ s/'/''/g; - DBUPDATE("UPDATE jobs set laststrts=$RUNQ{$Qid}{started} WHERE jid='$RUNQ{$Qid}{jid}'"); - DBUPDATE("INSERT INTO runs (jid,org,startts,cmd,endts)" - ." VALUES ('$RUNQ{$Qid}{jid}', '$RUNQ{$Qid}{ORG}', $RUNQ{$Qid}{started}, '$RUNQ{$Qid}{kidcmd}', 0)"); - DBUPDATE("DELETE FROM runs WHERE startts<=$RUNQ{$Qid}{started}-($SCHED{DAYS_IN_RUN}*86400) AND endts <> 0 "); - $JSTARTED++; - - my $kid = fork(); - if (!defined($kid)) { - logit("$$ couldn't fork [ $kidcmd ] !"); - notifyit("scheduler.critical|$$|couldn't fork [ $kidcmd ]"); - next; - } - - if ($kid == 0) { - # Child code - - # Create a new process group for the current process - setpgrp; - - my $log_basename = "$SCHED{PATH_STD}/$logfd/$logfn"; - my $merge_logs; - my $output_name; - my $run_path_ext; - my $stdout_ext; - - if ($SCHED{'MERGE_JOB_LOGS'} - and $SCHED{'MERGE_JOB_LOGS'} =~ /^\s*(?:y(?:es)?|1)\s*$/i) { - $merge_logs = 1; - $output_name = "STDOUT+STDERR"; - $run_path_ext = "log"; - $stdout_ext = "log"; - } else { - $merge_logs = 0; - $output_name = "STDOUT"; - $run_path_ext = "std{out,err}"; - $stdout_ext = "stdout"; - } - - open(STDOUT, $redir, "$log_basename.$stdout_ext") - or die "Could not redirect STDOUT: $!"; - printf(STDOUT "\n*** %s WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", $output_name, - strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); - - if ($merge_logs) { - # stdout and stderr should be redirected to the same file - open STDERR, ">&", \*STDOUT - or die "Could not redirect STDERR to STDOUT: $!";; - } else { - # Default behaviour: stdout and stderr should be redirected to different files - open STDERR, $redir, "$log_basename.stderr" - or die "Could not redirect STDERR: $!";; - printf(STDERR "\n*** STDERR WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", - strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); - } - DBUPDATE("UPDATE runs SET kid=$$,stdpath='$redir $logfd/$logfn.$run_path_ext'" - ." WHERE jid='$RUNQ{$Qid}{jid}' AND startts=$RUNQ{$Qid}{started}"); - - # alea jacta est ... one way ticket to the job ! - # exec may return on -1 (wrong attrs): force kid exit (so that reaper will see it) - exec $kidcmd - or logit("$$ couldn't exec [ $kidcmd ]: $? $!"); - - # Exit if exec failed - exit(-1); - - } # end of if ($kid == 0) - - # Continuing with parent's code - $RUNQ{$Qid}{kid} = $kid; # link runQ element to kid pid - $kids{$kid} = $Qid; # link kid pid list to runQ - if ($verbose) { - logit("forked $kid [ $kidcmd ] Q:$Qid,R(Q):$RUNQ{$Qid}{kid},K:$kids{$kid}"); - logit("logs $kid: $redir $logfd/$logfn.std{out,err}"); - } - next; - } # end of for my $rid (keys(%CANDIDATES)) - - REAPER(); - if ($verbose2) { - logit("$$ runQ: "); - for my $j (keys(%RUNQ)) { - logit(" runQ $j : jid($RUNQ{$j}{jid}) pid=$RUNQ{$j}{kid} started=$RUNQ{$j}{started} cmd=$RUNQ{$j}{kidcmd}"); - } - } - - my $tvi = tv_interval($t0); - if (($adjutick = $utick - $tvi) <= 0) { - logit("$$ drift >= $SCHED{TICK} !!!"); - $adjutick = 0; - } - $ELT += $tvi; - } + my $psdmsg = sprintf ("%u %s wait %d (d=%f,beat=%d)", $$,$PAUSED?" paused":"",int($adjutick),$adjutick-int($adjutick),$BEAT); + logit($psdmsg) if ($verbose2); + usleep(int($adjutick)); + + my $t0 = [gettimeofday]; + $BEAT-- if (!$PAUSED); + + UDPS(); + if (!$PAUSED && !$BEAT) { + $BEAT = $SCHED{BEAT}; + TTLJOBRQ(); + if (REAPER() == $SCHED{MAX_CHILDREN}) { + notifyit("scheduler.critical|$$|Maximum number of started processes reached"); + next; + }; + if (SYSLOAD()) { + notifyit("scheduler.critical|$$|Loadavg thresholds reached"); + next; + } + CANDIDATES(); + if ($verbose2) { + logit(scalar(keys(%CANDIDATES))." candidate(s): "); + for my $c (keys(%CANDIDATES)) { + logit(" $CANDIDATES{$c}{JID}: $CANDIDATES{$c}{XEQ1} $CANDIDATES{$c}{XEQ2} $CANDIDATES{$c}{XEQ3} "); + } + } + for my $rid (keys(%CANDIDATES)) { + + # build the actual command to be executed from components XEQx + +# no leading/trailing blanks in EACH components THEN derefrence $WEBOBS{} variables + $CANDIDATES{$rid}{XEQ1} =~ s/^\s+|\s+$//g; + $CANDIDATES{$rid}{XEQ2} =~ s/^\s+|\s+$//g; + $CANDIDATES{$rid}{XEQ3} =~ s/^\s+|\s+$//g; + + my $kidcmd = "$CANDIDATES{$rid}{XEQ1} $CANDIDATES{$rid}{XEQ2} $CANDIDATES{$rid}{XEQ3}"; + $kidcmd =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; + + # check if eligible for RUNQ ? + if ($CANDIDATES{$rid}{MAXSYSLOAD} <= $avg5) { + logit("jid($CANDIDATES{$rid}{JID}) candidate but CpuLoad too high"); + notifyit("scheduler.warning|$$|Job [ $CANDIDATES{$rid}{JID} ] candidate but CpuLoad too high"); + if ($SCHED{LMISS_BIAS}>0) { + $LMISS{$CANDIDATES{$rid}{JID}} = time; + } + next; + } + if (ENQ($CANDIDATES{$rid}{RES},$CANDIDATES{$rid}{JID}) == 1) { + logit("jid($CANDIDATES{$rid}{JID}) candidate but Resource busy"); + if ($SCHED{EMISS_BIAS}>0) { + $EMISS{$CANDIDATES{$rid}{JID}} = time; + } + next; + } + + # candidate is eligible, remove it from JOBRQ if it came in that way + if ($CANDIDATES{$rid}{ORG} eq "R") { + logit("rid $rid jid($CANDIDATES{$rid}{JID}) candidate, removed from JOBRQ") if ($verbose); + delete($JOBRQ{$rid}) + } + + # create the RUNQ structure for this job + my $Qid = $rid; + $RUNQ{$Qid}{kidcmd} = $kidcmd; + $RUNQ{$Qid}{kid} = 0; + $RUNQ{$Qid}{res} = $CANDIDATES{$rid}{RES} ; + $RUNQ{$Qid}{jid} = $CANDIDATES{$rid}{JID}; + $RUNQ{$Qid}{uid} = $CANDIDATES{$rid}{UID}; + $RUNQ{$Qid}{ORG} = $CANDIDATES{$rid}{ORG}; + + # take care of stdout/err redirections and targets + my $redir = '>'; + (my $RTNE_ = $CANDIDATES{$rid}{XEQ2}) =~ s/\s+/_/g; + $CANDIDATES{$rid}{LOGPATH} ||= $RTNE_ ; + if ($CANDIDATES{$rid}{LOGPATH} =~ m/(^>{1,2})(.*)$/) { + $redir = $1; + $CANDIDATES{$rid}{LOGPATH} = $2; + } + + $RUNQ{$Qid}{started} = time; + $CANDIDATES{$rid}{LOGPATH} =~ s/\{TS\}/$RUNQ{$Qid}{started}/g ; + $CANDIDATES{$rid}{LOGPATH} =~ s/\{RTNE\}/$RTNE_/g ; + my ($logfn, $logfd) = fileparse($CANDIDATES{$rid}{LOGPATH}); + $logfd =~ s|/$||; # Remove trailing slash from the dir + $RUNQ{$Qid}{logfd} = $logfd; + $RUNQ{$Qid}{logfn} = $logfn; + + # from now on we don't need the $CANDIDATES{$rid} anymore + delete($CANDIDATES{$rid}); + make_path("$SCHED{PATH_STD}/$logfd"); + + $RUNQ{$Qid}{kidcmd} =~ s/'/''/g; + DBUPDATE("UPDATE jobs set laststrts=$RUNQ{$Qid}{started} WHERE jid='$RUNQ{$Qid}{jid}'"); + DBUPDATE("INSERT INTO runs (jid,org,startts,cmd,endts)" + ." VALUES ('$RUNQ{$Qid}{jid}', '$RUNQ{$Qid}{ORG}', $RUNQ{$Qid}{started}, '$RUNQ{$Qid}{kidcmd}', 0)"); + DBUPDATE("DELETE FROM runs WHERE startts<=$RUNQ{$Qid}{started}-($SCHED{DAYS_IN_RUN}*86400) AND endts <> 0 "); + $JSTARTED++; + + my $kid = fork(); + if (!defined($kid)) { + logit("$$ couldn't fork [ $kidcmd ] !"); + notifyit("scheduler.critical|$$|couldn't fork [ $kidcmd ]"); + next; + } + + if ($kid == 0) { + + # Child code + + # Create a new process group for the current process + setpgrp; + + my $log_basename = "$SCHED{PATH_STD}/$logfd/$logfn"; + my $merge_logs; + my $output_name; + my $run_path_ext; + my $stdout_ext; + + if ($SCHED{'MERGE_JOB_LOGS'} + and $SCHED{'MERGE_JOB_LOGS'} =~ /^\s*(?:y(?:es)?|1)\s*$/i) { + $merge_logs = 1; + $output_name = "STDOUT+STDERR"; + $run_path_ext = "log"; + $stdout_ext = "log"; + } else { + $merge_logs = 0; + $output_name = "STDOUT"; + $run_path_ext = "std{out,err}"; + $stdout_ext = "stdout"; + } + + open(STDOUT, $redir, "$log_basename.$stdout_ext") + or die "Could not redirect STDOUT: $!"; + printf(STDOUT "\n*** %s WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", $output_name, + strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); + + if ($merge_logs) { + + # stdout and stderr should be redirected to the same file + open STDERR, ">&", \*STDOUT + or die "Could not redirect STDERR to STDOUT: $!";; + } else { + + # Default behaviour: stdout and stderr should be redirected to different files + open STDERR, $redir, "$log_basename.stderr" + or die "Could not redirect STDERR: $!";; + printf(STDERR "\n*** STDERR WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", + strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); + } + DBUPDATE("UPDATE runs SET kid=$$,stdpath='$redir $logfd/$logfn.$run_path_ext'" + ." WHERE jid='$RUNQ{$Qid}{jid}' AND startts=$RUNQ{$Qid}{started}"); + +# alea jacta est ... one way ticket to the job ! +# exec may return on -1 (wrong attrs): force kid exit (so that reaper will see it) + exec $kidcmd + or logit("$$ couldn't exec [ $kidcmd ]: $? $!"); + + # Exit if exec failed + exit(-1); + + } # end of if ($kid == 0) + + # Continuing with parent's code + $RUNQ{$Qid}{kid} = $kid; # link runQ element to kid pid + $kids{$kid} = $Qid; # link kid pid list to runQ + if ($verbose) { + logit("forked $kid [ $kidcmd ] Q:$Qid,R(Q):$RUNQ{$Qid}{kid},K:$kids{$kid}"); + logit("logs $kid: $redir $logfd/$logfn.std{out,err}"); + } + next; + } # end of for my $rid (keys(%CANDIDATES)) + + REAPER(); + if ($verbose2) { + logit("$$ runQ: "); + for my $j (keys(%RUNQ)) { + logit(" runQ $j : jid($RUNQ{$j}{jid}) pid=$RUNQ{$j}{kid} started=$RUNQ{$j}{started} cmd=$RUNQ{$j}{kidcmd}"); + } + } + + my $tvi = tv_interval($t0); + if (($adjutick = $utick - $tvi) <= 0) { + logit("$$ drift >= $SCHED{TICK} !!!"); + $adjutick = 0; + } + $ELT += $tvi; + } } # you should never get there ! @@ -760,169 +765,177 @@ BEGIN # non-blocking wait for children exit # ----------------------------------- sub REAPER { - my @DBupdates; - - while (($dcd = waitpid(-1, &WNOHANG)) > 0) { - my $dcdRC = ${^CHILD_ERROR_NATIVE}; # default, see below each case - my $tend = time; - my $dcdmsg = ''; - - if ($? == -1) { - $dcdmsg = sprintf (" failed to execute: $!"); - } elsif ($? & 127) { - $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); - } else { - $dcdRC = $? >> 8; - $dcdmsg = sprintf ("*%d", $dcdRC); - } - - my $dcdQid = $kids{$dcd}; - if ($dcdRC != 0) { - notifyit("scheduler.critical|$$|Job $RUNQ{$dcdQid}{jid} started at $RUNQ{$dcdQid}{started} returned non-null code $dcdRC.\nError message was : $dcdmsg"); - } - DBUPDATE("UPDATE runs SET endts=$tend,rc=$dcdRC,rcmsg=\"$dcdmsg\" WHERE jid=\"$RUNQ{$dcdQid}{jid}\" AND startts=$RUNQ{$dcdQid}{started}"); - - my $notifytxt = "submitrc.$RUNQ{$dcdQid}{jid}|$$|" - ."org=$RUNQ{$dcdQid}{ORG} rc=$dcdRC cmd=[ $RUNQ{$dcdQid}{kidcmd} ] log=[ $RUNQ{$dcdQid}{logfd}/$RUNQ{$dcdQid}{logfn}.std{out,err} ] "; - if (defined($RUNQ{$dcdQid}{uid}) && $RUNQ{$dcdQid}{uid} ne '') { - $notifytxt .= "uid=$RUNQ{$dcdQid}{uid}"; - } - WebObs::Config::notify($notifytxt); - - $JENDED++; - logit("reaper: kid($dcd), runQ($dcdQid), jid($RUNQ{$dcdQid}{jid})") if ($verbose); - DEQ($RUNQ{$dcdQid}{res},$RUNQ{$dcdQid}{jid}); - delete $RUNQ{$dcdQid}; - delete $kids{$dcd}; - } - return scalar(keys(%kids)); + my @DBupdates; + + while (($dcd = waitpid(-1, &WNOHANG)) > 0) { + my $dcdRC = ${^CHILD_ERROR_NATIVE}; # default, see below each case + my $tend = time; + my $dcdmsg = ''; + + if ($? == -1) { + $dcdmsg = sprintf (" failed to execute: $!"); + } elsif ($? & 127) { + $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); + } else { + $dcdRC = $? >> 8; + $dcdmsg = sprintf ("*%d", $dcdRC); + } + + my $dcdQid = $kids{$dcd}; + if ($dcdRC != 0) { + notifyit("scheduler.critical|$$|Job $RUNQ{$dcdQid}{jid} started at $RUNQ{$dcdQid}{started} returned non-null code $dcdRC.\nError message was : $dcdmsg"); + } + DBUPDATE("UPDATE runs SET endts=$tend,rc=$dcdRC,rcmsg=\"$dcdmsg\" WHERE jid=\"$RUNQ{$dcdQid}{jid}\" AND startts=$RUNQ{$dcdQid}{started}"); + + my $notifytxt = "submitrc.$RUNQ{$dcdQid}{jid}|$$|" + ."org=$RUNQ{$dcdQid}{ORG} rc=$dcdRC cmd=[ $RUNQ{$dcdQid}{kidcmd} ] log=[ $RUNQ{$dcdQid}{logfd}/$RUNQ{$dcdQid}{logfn}.std{out,err} ] "; + if (defined($RUNQ{$dcdQid}{uid}) && $RUNQ{$dcdQid}{uid} ne '') { + $notifytxt .= "uid=$RUNQ{$dcdQid}{uid}"; + } + WebObs::Config::notify($notifytxt); + + $JENDED++; + logit("reaper: kid($dcd), runQ($dcdQid), jid($RUNQ{$dcdQid}{jid})") if ($verbose); + DEQ($RUNQ{$dcdQid}{res},$RUNQ{$dcdQid}{jid}); + delete $RUNQ{$dcdQid}; + delete $kids{$dcd}; + } + return scalar(keys(%kids)); } # ------------------------------ # Exit scheduler on STOP command # ------------------------------ sub exit_after_jobs { - $PAUSED = 2; # Do not schedule new jobs - logit("scheduler[$$]: stop requested, waiting for kid(s) to exit..."); - notifyit("scheduler.critical|$$|scheduler is shutting down as requested."); - while (REAPER() != 0) { sleep(1); UDPS() }; - logit("kid(s) stopped. Exiting."); - myexit(0); + $PAUSED = 2; # Do not schedule new jobs + logit("scheduler[$$]: stop requested, waiting for kid(s) to exit..."); + notifyit("scheduler.critical|$$|scheduler is shutting down as requested."); + while (REAPER() != 0) { sleep(1); UDPS() }; + logit("kid(s) stopped. Exiting."); + myexit(0); } # ------------------------ # Exit scheduler on signal # ------------------------ sub exit_on_signal { - my $signame = shift || ''; - my $exit_code = shift // 1; - - logit("caught a SIG$signame"); - notifyit("scheduler.critical|$$|scheduler stopping on signal $signame"); - my $ets = REAPER(); # any extra-terrestrial survivors ? - logit("$ets kid(s) are still alive.") if ($ets>0); - print("exiting on signal SIG$signame.") if (-t STDOUT); - myexit($exit_code); + my $signame = shift || ''; + my $exit_code = shift // 1; + + logit("caught a SIG$signame"); + notifyit("scheduler.critical|$$|scheduler stopping on signal $signame"); + my $ets = REAPER(); # any extra-terrestrial survivors ? + logit("$ets kid(s) are still alive.") if ($ets>0); + print("exiting on signal SIG$signame.") if (-t STDOUT); + myexit($exit_code); } # ---------------------------------------------------------- # SYSLOAD true if system's loadavg > user-defined thresholds # ---------------------------------------------------------- sub SYSLOAD { - # ---- grab fresh system's loadavg figures - if (open FILE, "< /proc/loadavg") { - ($avg1, $avg5, $avg15, undef, undef) = split / /, ; - close FILE; - # load averages in users's definitions are relative to 1 cpu; - # fix /proc/loadavg values to match actual number of cpus - $avg1 /= $ncpus; $avg5 /= $ncpus; $avg15 /= $ncpus; - # ---- system's loadavg vs user thresholds - if ($avg1>$SCHED{LOADAVG1_THRESHOLD} || $avg5>$SCHED{LOADAVG5_THRESHOLD} || $avg15>$SCHED{LOADAVG15_THRESHOLD}) { - #logit(" $$ system load > threshold: $avg1/$SCHED{LOADAVG1_THRESHOLD} $avg5/$SCHED{LOADAVG5_THRESHOLD} $avg15/$SCHED{LOADAVG15_THRESHOLD}") if ($verbose); - logit(" $$ system load > threshold") if ($verbose); - return(1); - } - } else { - logit("$$ cpu loadavg not refreshed: $!"); - } - return(0); + + # ---- grab fresh system's loadavg figures + if (open FILE, "< /proc/loadavg") { + ($avg1, $avg5, $avg15, undef, undef) = split / /, ; + close FILE; + + # load averages in users's definitions are relative to 1 cpu; + # fix /proc/loadavg values to match actual number of cpus + $avg1 /= $ncpus; $avg5 /= $ncpus; $avg15 /= $ncpus; + + # ---- system's loadavg vs user thresholds + if ($avg1>$SCHED{LOADAVG1_THRESHOLD} || $avg5>$SCHED{LOADAVG5_THRESHOLD} || $avg15>$SCHED{LOADAVG15_THRESHOLD}) { + +#logit(" $$ system load > threshold: $avg1/$SCHED{LOADAVG1_THRESHOLD} $avg5/$SCHED{LOADAVG5_THRESHOLD} $avg15/$SCHED{LOADAVG15_THRESHOLD}") if ($verbose); + logit(" $$ system load > threshold") if ($verbose); + return(1); + } + } else { + logit("$$ cpu loadavg not refreshed: $!"); + } + return(0); } # ---------------------------------------------------------- # CANDIDATES select all jobs that could be run now, from DB and Q # ---------------------------------------------------------- sub CANDIDATES { - %CANDIDATES = %{DBSELECT()}; - for my $key (keys %CANDIDATES) { - usleep 1; - my $art = time; - $CANDIDATES{$art} = delete $CANDIDATES{$key}; - } - - for my $jtk (keys(%JOBRQ)) { - my $jrq = $JOBRQ{$jtk}{REQ}; - $jrq =~ s/^\s+|\s+$//g; - if ( $jrq =~ m/JID=\s*(.+)\s*/i ) { - # a %CANDIDATES entry from a submit "jid=" - my $jrqid = $1; - my %tmp = %{DBSELECT($jrqid)}; - if (defined($tmp{$jrqid})) { - $CANDIDATES{$jtk} = delete $tmp{$jrqid}; - } else { - logit("$$ deleting submitted job jid($jrqid): not defined"); - delete($JOBRQ{$jtk}); - } - } else { - # a %CANDIDATES entry from a submit "XEQ1:gnagna,XEQ2:blabla,..." - if (JDPARSE($jtk) == 0) { - logit("$$ deleting submitted job jid($JOBRQ{$jtk}{JID}): parse failed [ $jrq ]"); - delete($JOBRQ{$jtk}); - } - } - } - # ignore JIDs for which exists a 'pending delay' due to a previous threshold OR enq condition - for my $key (keys %CANDIDATES) { - if (defined($LMISS{$CANDIDATES{$key}{JID}})) { - if ($LMISS{$CANDIDATES{$key}{JID}} + $SCHED{LMISS_BIAS} >= time) { - delete $CANDIDATES{$key}; - } else { - delete $LMISS{$CANDIDATES{$key}}; - } - } - if (defined($EMISS{$CANDIDATES{$key}{JID}})) { - if ($EMISS{$CANDIDATES{$key}{JID}} + $SCHED{EMISS_BIAS} >= time) { - delete $CANDIDATES{$key}; - } else { - delete $EMISS{$CANDIDATES{$key}}; - } - } - } - return scalar(keys(%CANDIDATES)); + %CANDIDATES = %{DBSELECT()}; + for my $key (keys %CANDIDATES) { + usleep 1; + my $art = time; + $CANDIDATES{$art} = delete $CANDIDATES{$key}; + } + + for my $jtk (keys(%JOBRQ)) { + my $jrq = $JOBRQ{$jtk}{REQ}; + $jrq =~ s/^\s+|\s+$//g; + if ( $jrq =~ m/JID=\s*(.+)\s*/i ) { + + # a %CANDIDATES entry from a submit "jid=" + my $jrqid = $1; + my %tmp = %{DBSELECT($jrqid)}; + if (defined($tmp{$jrqid})) { + $CANDIDATES{$jtk} = delete $tmp{$jrqid}; + } else { + logit("$$ deleting submitted job jid($jrqid): not defined"); + delete($JOBRQ{$jtk}); + } + } else { + + # a %CANDIDATES entry from a submit "XEQ1:gnagna,XEQ2:blabla,..." + if (JDPARSE($jtk) == 0) { + logit("$$ deleting submitted job jid($JOBRQ{$jtk}{JID}): parse failed [ $jrq ]"); + delete($JOBRQ{$jtk}); + } + } + } + +# ignore JIDs for which exists a 'pending delay' due to a previous threshold OR enq condition + for my $key (keys %CANDIDATES) { + if (defined($LMISS{$CANDIDATES{$key}{JID}})) { + if ($LMISS{$CANDIDATES{$key}{JID}} + $SCHED{LMISS_BIAS} >= time) { + delete $CANDIDATES{$key}; + } else { + delete $LMISS{$CANDIDATES{$key}}; + } + } + if (defined($EMISS{$CANDIDATES{$key}{JID}})) { + if ($EMISS{$CANDIDATES{$key}{JID}} + $SCHED{EMISS_BIAS} >= time) { + delete $CANDIDATES{$key}; + } else { + delete $EMISS{$CANDIDATES{$key}}; + } + } + } + return scalar(keys(%CANDIDATES)); } + # ---------------------------------------------------------- # helper: parse job definitions from Q (ie. user input) # its JID (dynamic, negative) has been assigned when command was received # parses user's string "XEQ1:'launch text',XEQ2:'routine text',XEQ3:'a1 a2',...." # ---------------------------------------------------------- sub JDPARSE { - my $jrq = $JOBRQ{$_[0]}{REQ}; - my @req = split(/,/,$jrq); - my %KW = map { split(/:/,$_,2) } @req; - $KW{XEQ1} ||= ''; - $KW{XEQ2} ||= ''; - $KW{XEQ3} ||= ''; - $KW{MAXINSTANCES} ||= 0; - $KW{MAXSYSLOAD} ||= 0.8; - $KW{LOGPATH} ||= 'undef'; - $KW{RES} ||= ''; - $KW{UID} ||= ''; - $KW{ORG} = 'R'; - if ("$KW{XEQ1}$KW{XEQ2}$KW{XEQ3}" ne "") { - $CANDIDATES{$_[0]} = \%KW; - $CANDIDATES{$_[0]}{JID} = $JOBRQ{$_[0]}{JID}; - return 1; - } - return 0; + my $jrq = $JOBRQ{$_[0]}{REQ}; + my @req = split(/,/,$jrq); + my %KW = map { split(/:/,$_,2) } @req; + $KW{XEQ1} ||= ''; + $KW{XEQ2} ||= ''; + $KW{XEQ3} ||= ''; + $KW{MAXINSTANCES} ||= 0; + $KW{MAXSYSLOAD} ||= 0.8; + $KW{LOGPATH} ||= 'undef'; + $KW{RES} ||= ''; + $KW{UID} ||= ''; + $KW{ORG} = 'R'; + if ("$KW{XEQ1}$KW{XEQ2}$KW{XEQ3}" ne "") { + $CANDIDATES{$_[0]} = \%KW; + $CANDIDATES{$_[0]}{JID} = $JOBRQ{$_[0]}{JID}; + return 1; + } + return 0; } # ---------------------------------------------------------- @@ -930,16 +943,16 @@ sub JDPARSE { # and cancels (removes) those jobs whose ttl drops below 0 # ---------------------------------------------------------- sub TTLJOBRQ { - for my $j (keys(%JOBRQ)) { - $JOBRQ{$j}{TTL} -= $SCHED{BEAT}*($utick/1000000); - if ($JOBRQ{$j}{TTL} <= 0) { - logit("cancelling TTL-expired waiting job jid($JOBRQ{$j}{JID}) [ $JOBRQ{$j}{REQ} ]"); - delete($JOBRQ{$j}); - delete($LMISS{$JOBRQ{$j}{JID}}) if (defined($LMISS{$JOBRQ{$j}{JID}})); - delete($EMISS{$JOBRQ{$j}{JID}}) if (defined($EMISS{$JOBRQ{$j}{JID}})); - } - } - return; + for my $j (keys(%JOBRQ)) { + $JOBRQ{$j}{TTL} -= $SCHED{BEAT}*($utick/1000000); + if ($JOBRQ{$j}{TTL} <= 0) { + logit("cancelling TTL-expired waiting job jid($JOBRQ{$j}{JID}) [ $JOBRQ{$j}{REQ} ]"); + delete($JOBRQ{$j}); + delete($LMISS{$JOBRQ{$j}{JID}}) if (defined($LMISS{$JOBRQ{$j}{JID}})); + delete($EMISS{$JOBRQ{$j}{JID}}) if (defined($EMISS{$JOBRQ{$j}{JID}})); + } + } + return; } # ---------------------------------------------------------- @@ -950,12 +963,12 @@ sub TTLJOBRQ { # || die "Error connecting to $dbname: $DBI::errstr"; # ---------------------------------------------------------- sub db_connect { - my $dbname = shift; - return DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) + my $dbname = shift; + return DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) } # ---------------------------------------------------------- @@ -964,56 +977,58 @@ sub db_connect { # if its job's ID (JID) is passed as argument # ---------------------------------------------------------- sub DBSELECT { - my $job_id = shift; - my $origin; - my $wclause; - - if ($job_id) { - $origin = "R"; - $wclause = "JID = '$job_id' "; - } else { - $origin = 'S'; - #FWIW: +BEAT prevent accumulating shifts; cast(LASTSTRTS as int) would also act as floor(LASTSTRTS) - $wclause = "strftime('%s', 'now')-LASTSTRTS+$BEAT >= RUNINTERVAL AND VALIDITY = 'Y' "; - } - - my $dbh = db_connect($SCHED{SQL_DB_JOBS}); - if (not $dbh) { - logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); - myexit(1); - } - - my $q = qq(SELECT JID,"$origin" as ORG,'' as RQ,RES,XEQ1,XEQ2,XEQ3,MAXSYSLOAD,LOGPATH) - .qq( FROM JOBS WHERE $wclause); - # Return reference for future %CANDIDATES = %{$rs}; - my $ref = $dbh->selectall_hashref($q, 'JID'); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " - . $dbh->errstr; - return $ref; + my $job_id = shift; + my $origin; + my $wclause; + + if ($job_id) { + $origin = "R"; + $wclause = "JID = '$job_id' "; + } else { + $origin = 'S'; + +#FWIW: +BEAT prevent accumulating shifts; cast(LASTSTRTS as int) would also act as floor(LASTSTRTS) + $wclause = "strftime('%s', 'now')-LASTSTRTS+$BEAT >= RUNINTERVAL AND VALIDITY = 'Y' "; + } + + my $dbh = db_connect($SCHED{SQL_DB_JOBS}); + if (not $dbh) { + logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); + myexit(1); + } + + my $q = qq(SELECT JID,"$origin" as ORG,'' as RQ,RES,XEQ1,XEQ2,XEQ3,MAXSYSLOAD,LOGPATH) + .qq( FROM JOBS WHERE $wclause); + + # Return reference for future %CANDIDATES = %{$rs}; + my $ref = $dbh->selectall_hashref($q, 'JID'); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " + . $dbh->errstr; + return $ref; } # ---------------------------------------------------------- # insert or update DB : execute SQL query passed in # ---------------------------------------------------------- sub DBUPDATE { - my $query = shift; - return if not $query; - - my $dbh = db_connect($SCHED{SQL_DB_JOBS}); - if (not $dbh) { - logit("Error connecting to $SCHED{SQL_DB_JOBS} for update: $DBI::errstr"); - return; - } - - logit("Executing query [$query]") if ($verbose); - my $rv = $dbh->do($query); # This will die on error - - $dbh->disconnect() - or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " - . $dbh->errstr; - return $rv == 0E0 ? 0 : $rv; + my $query = shift; + return if not $query; + + my $dbh = db_connect($SCHED{SQL_DB_JOBS}); + if (not $dbh) { + logit("Error connecting to $SCHED{SQL_DB_JOBS} for update: $DBI::errstr"); + return; + } + + logit("Executing query [$query]") if ($verbose); + my $rv = $dbh->do($query); # This will die on error + + $dbh->disconnect() + or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " + . $dbh->errstr; + return $rv == 0E0 ? 0 : $rv; } # ---------------------------------------------------------- @@ -1025,28 +1040,28 @@ sub DBUPDATE { # returns 1 if resource busy # ---------------------------------------------------------- sub ENQ { - if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { - my $ts = strftime("%Y%m%d-%H%M%S",localtime(time)); - my @res = split(/\+/,$_[0]); - foreach (@res) { s/^\s+|\s+$//g } - - # fails if one of requested resources is not free - foreach (@res) { - my @u = glob("$SCHED{PATH_RES}/$_--*"); - return 1 if scalar(@u) > 0; - } - - # then actually enq all requested resources - foreach (@res) { - my $resource_file = "$SCHED{PATH_RES}/$_--$_[1]-$ts"; - open(my $f, '>', $resource_file) - or die "Unable to create file '$resource_file': $!"; - close($f) - or warn "Error while closing file '$resource_file': $!"; - logit("enq $_, jid($_[1])") if ($verbose); - } - } - return 0 + if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { + my $ts = strftime("%Y%m%d-%H%M%S",localtime(time)); + my @res = split(/\+/,$_[0]); + foreach (@res) { s/^\s+|\s+$//g } + + # fails if one of requested resources is not free + foreach (@res) { + my @u = glob("$SCHED{PATH_RES}/$_--*"); + return 1 if scalar(@u) > 0; + } + + # then actually enq all requested resources + foreach (@res) { + my $resource_file = "$SCHED{PATH_RES}/$_--$_[1]-$ts"; + open(my $f, '>', $resource_file) + or die "Unable to create file '$resource_file': $!"; + close($f) + or warn "Error while closing file '$resource_file': $!"; + logit("enq $_, jid($_[1])") if ($verbose); + } + } + return 0 } # ---------------------------------------------------------- @@ -1058,269 +1073,271 @@ sub ENQ { # ** TBD: could check that only jid that ENQd can DEQ # ---------------------------------------------------------- sub DEQ { - if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { - foreach my $res (split(/\+/,$_[0])) { - $res =~ s/^\s+|\s+$//g; - my @g = glob("$SCHED{PATH_RES}/$res--*"); - if (@g) { - unlink @g; - logit("deq $res, jid($_[1])") if ($verbose); - } - } - } - return 0 + if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { + foreach my $res (split(/\+/,$_[0])) { + $res =~ s/^\s+|\s+$//g; + my @g = glob("$SCHED{PATH_RES}/$res--*"); + if (@g) { + unlink @g; + logit("deq $res, jid($_[1])") if ($verbose); + } + } + } + return 0 } # ---------------------------------------------------------- # UDPS receives incoming cmds/jobs on non-blocking socket # ---------------------------------------------------------- sub UDPS { - my $msg = ''; - my $cmd = ''; - my $ans = ''; - my $junk = ''; - - # Read message from the UDFP socket, if any, or return - $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) or return; - - my $sock_client_id = $SOCK->peerhost().":".$SOCK->peerport(); - $msg =~ s/^\s+|\s+$//g; - ($cmd, $msg) = split / /, $msg, 2; - $cmd ||= 'nil'; - $msg ||= 'nil' ; - for ($cmd) { - if (/^JOB/i && $msg) { - my $timekey = time; - $JOBRQ{$timekey}{REQ} = $msg; - $JOBRQ{$timekey}{TTL} = $SCHED{CANCEL_SUBMIT}; - # assign a dynamic jid, even if overidden later because it appears to be a jid= command - $DynJid = -1 if (--$DynJid < -10E9); # dynamic jid , -10**9 rollover - $JOBRQ{$timekey}{JID} = "$DynJid"; - $ans = "request for job queued\n"; - next; - } - if (/^KILLJOB/i && $msg) { - if (not $msg =~ /^kid=(\d+)$/) { - $ans = "killjob command: invalid argument, should be 'kid=XXX'\n"; - next; - } - my $pid = $1; - logit("killing job $pid") if ($verbose); - my $count = kill 'TERM', $pid; - if ($count > 0) { - $ans = "job with pid = $pid has been killed. Please check!\n"; - } else { - $ans = "ERROR: unable to kill job with pid = $pid. Please check the kid argument.\n"; - } - next; - } - if (/^ENQ/i && $msg) { - if (ENQ($msg,$sock_client_id)) { - $ans = "busy $msg"; - } else { - $ans = "ENQ'd $msg\n"; - } - next; - } - if (/^DEQ/i && $msg) { - if (DEQ($msg,$sock_client_id)) { - $ans = "failed DEQ $msg"; - } else { - $ans = "DEQ'd $msg\n"; - } - next; - } - if (/CMD/i) { - for ($msg) { - if (/^PAUSE$/i && $PAUSED != 2) { - $PAUSED = 1 ; - $ans = "Paused\n"; - next; - } - if (/^RESUME$/i && $PAUSED != 2) { - $PAUSED = 0; - $ans = "Resumed\n"; - next; - } - if (/^RUNQ/i) { - $ans = ''; - if (not %RUNQ) { - $ans .= "No running jobs.\n"; - next; - } - for my $id (sort keys %RUNQ) { - my $start_dt = DateTime->from_epoch(epoch => $id, - time_zone => $local_tz); - $ans .= sprintf("RUNQ(%s) started on %s %s\n", $id, - $start_dt->strftime('%F %T (UTC%z)')); - for my $j (sort keys %{$RUNQ{$id}}) { - $ans .= " $j="; - $ans .= defined($RUNQ{$id}{$j}) ? "$RUNQ{$id}{$j}\n" : "nil\n"; - } - } - next; - } - if (/^JOBQ/i) { - $ans = ''; - if (not %JOBRQ) { - $ans .= "No jobs in waiting queue.\n"; - next; - } - for my $j (sort keys (%JOBRQ)) { - $ans .= "ttl=$JOBRQ{$j}{TTL} ".substr($JOBRQ{$j}{REQ},0,40)."...\n"; - } - next; - } - if (/^QS/i) { - my @jobq = map("$JOBRQ{$_}{JID}", sort(keys(%JOBRQ))); - my @lmiss = sort(keys(%LMISS)); - my @emiss = sort(keys(%EMISS)); - my @runq = map("$RUNQ{$_}{jid} (pid $RUNQ{$_}{kid})", - sort(keys(%RUNQ))); - my @enqs = map { s/$SCHED{PATH_RES}\///; s/--.*$//; $_; } - (sort glob("$SCHED{PATH_RES}/*")); - - $ans = "JOBQ: " . (@jobq ? join(', ', @jobq) : "none") - ."\nLMISS: " . (@lmiss ? join(', ', @lmiss) : "none") - ."\nEMISS: " . (@emiss ? join(', ', @emiss) : "none") - ."\nRUNQ: " . (@runq ? join(', ', @runq) : "none") - ."\nENQs: " . (@enqs ? join(', ', @enqs) : "none") - ."\n"; - next; - } - if (/^VERBOSE$/i && $PAUSED != 2) { - $verbose = 1; - $ans = "Verbose On\n"; - next; - } - if (/^QUIET$/i && $PAUSED != 2) { - $verbose = 0; - $ans = "Verbose Off\n"; - next; - } - if (/^FLOG$/i && $PAUSED != 2) { - $forcesavelog = 1; - $ans = "Log will be backed up on next write\n"; - next; - } - if (/^STOP$/i && $PAUSED != 2) { - $ans = 'Stopping'; - my $nb_kids = keys(%kids); - if ($nb_kids) { - $ans .= " after waiting for $nb_kids job(s)" - ." to end: ".join(', ', keys(%kids)); - } else { - $ans .= " now."; - } - $SOCK->send("$ans\n"); - logit("client ".$sock_client_id." sent [ $msg ]"); - exit_after_jobs(); - next; - } - if (/^STAT$/i) { - my $now = time; - $ans = "STATTIME=".strftime("%Y-%m-%d %H:%M:%S (UTC%z)",localtime($now))."\n"; - my @enqs = glob("$SCHED{PATH_RES}/*"); - my @paused = ('No','Yes','Stopping...'); - $ans .= "STARTED=$STRTTS\n"; - $ans .= "PID=$PID\n"; - $ans .= "USER=$PUID\n"; - $ans .= "uTICK=$utick\n"; - $ans .= "BEAT=$SCHED{BEAT}\n"; - $ans .= sprintf("ELT=%.3f (%.2f%%)\n", $ELT, ($ELT*100)/($now-$STRT)); - $ans .= "LOG=$LOGNAME\n"; - $ans .= "JOBSDB=$SCHED{SQL_DB_JOBS}\n"; - $ans .= "JOBS STDio=$SCHED{PATH_STD}\n"; - $ans .= "JOBS RESource=$SCHED{PATH_RES}\n"; - $ans .= "PAUSED=$paused[$PAUSED]\n"; - $ans .= "#JOBSTART=$JSTARTED\n"; - $ans .= "#JOBSEND=$JENDED\n"; - $ans .= "KIDS=".scalar(keys(%kids))."\n"; - $ans .= "ENQs=".scalar(@enqs)."\n"; - next; - } - $ans = "command unknown or invalid at this time\n"; - } - next; - } - $ans = "Unknown action '$_'.\n"; - } - $SOCK->send($ans); - logit("client ".$sock_client_id." sent [ $cmd $msg ]; reply ".length($ans)." bytes") if ($verbose); + my $msg = ''; + my $cmd = ''; + my $ans = ''; + my $junk = ''; + + # Read message from the UDFP socket, if any, or return + $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) or return; + + my $sock_client_id = $SOCK->peerhost().":".$SOCK->peerport(); + $msg =~ s/^\s+|\s+$//g; + ($cmd, $msg) = split / /, $msg, 2; + $cmd ||= 'nil'; + $msg ||= 'nil' ; + for ($cmd) { + if (/^JOB/i && $msg) { + my $timekey = time; + $JOBRQ{$timekey}{REQ} = $msg; + $JOBRQ{$timekey}{TTL} = $SCHED{CANCEL_SUBMIT}; + +# assign a dynamic jid, even if overidden later because it appears to be a jid= command + $DynJid = -1 if (--$DynJid < -10E9); # dynamic jid , -10**9 rollover + $JOBRQ{$timekey}{JID} = "$DynJid"; + $ans = "request for job queued\n"; + next; + } + if (/^KILLJOB/i && $msg) { + if (not $msg =~ /^kid=(\d+)$/) { + $ans = "killjob command: invalid argument, should be 'kid=XXX'\n"; + next; + } + my $pid = $1; + logit("killing job $pid") if ($verbose); + my $count = kill 'TERM', $pid; + if ($count > 0) { + $ans = "job with pid = $pid has been killed. Please check!\n"; + } else { + $ans = "ERROR: unable to kill job with pid = $pid. Please check the kid argument.\n"; + } + next; + } + if (/^ENQ/i && $msg) { + if (ENQ($msg,$sock_client_id)) { + $ans = "busy $msg"; + } else { + $ans = "ENQ'd $msg\n"; + } + next; + } + if (/^DEQ/i && $msg) { + if (DEQ($msg,$sock_client_id)) { + $ans = "failed DEQ $msg"; + } else { + $ans = "DEQ'd $msg\n"; + } + next; + } + if (/CMD/i) { + for ($msg) { + if (/^PAUSE$/i && $PAUSED != 2) { + $PAUSED = 1 ; + $ans = "Paused\n"; + next; + } + if (/^RESUME$/i && $PAUSED != 2) { + $PAUSED = 0; + $ans = "Resumed\n"; + next; + } + if (/^RUNQ/i) { + $ans = ''; + if (not %RUNQ) { + $ans .= "No running jobs.\n"; + next; + } + for my $id (sort keys %RUNQ) { + my $start_dt = DateTime->from_epoch(epoch => $id, + time_zone => $local_tz); + $ans .= sprintf("RUNQ(%s) started on %s %s\n", $id, + $start_dt->strftime('%F %T (UTC%z)')); + for my $j (sort keys %{$RUNQ{$id}}) { + $ans .= " $j="; + $ans .= defined($RUNQ{$id}{$j}) ? "$RUNQ{$id}{$j}\n" : "nil\n"; + } + } + next; + } + if (/^JOBQ/i) { + $ans = ''; + if (not %JOBRQ) { + $ans .= "No jobs in waiting queue.\n"; + next; + } + for my $j (sort keys (%JOBRQ)) { + $ans .= "ttl=$JOBRQ{$j}{TTL} ".substr($JOBRQ{$j}{REQ},0,40)."...\n"; + } + next; + } + if (/^QS/i) { + my @jobq = map("$JOBRQ{$_}{JID}", sort(keys(%JOBRQ))); + my @lmiss = sort(keys(%LMISS)); + my @emiss = sort(keys(%EMISS)); + my @runq = map("$RUNQ{$_}{jid} (pid $RUNQ{$_}{kid})", + sort(keys(%RUNQ))); + my @enqs = map { s/$SCHED{PATH_RES}\///; s/--.*$//; $_; } + (sort glob("$SCHED{PATH_RES}/*")); + + $ans = "JOBQ: " . (@jobq ? join(', ', @jobq) : "none") + ."\nLMISS: " . (@lmiss ? join(', ', @lmiss) : "none") + ."\nEMISS: " . (@emiss ? join(', ', @emiss) : "none") + ."\nRUNQ: " . (@runq ? join(', ', @runq) : "none") + ."\nENQs: " . (@enqs ? join(', ', @enqs) : "none") + ."\n"; + next; + } + if (/^VERBOSE$/i && $PAUSED != 2) { + $verbose = 1; + $ans = "Verbose On\n"; + next; + } + if (/^QUIET$/i && $PAUSED != 2) { + $verbose = 0; + $ans = "Verbose Off\n"; + next; + } + if (/^FLOG$/i && $PAUSED != 2) { + $forcesavelog = 1; + $ans = "Log will be backed up on next write\n"; + next; + } + if (/^STOP$/i && $PAUSED != 2) { + $ans = 'Stopping'; + my $nb_kids = keys(%kids); + if ($nb_kids) { + $ans .= " after waiting for $nb_kids job(s)" + ." to end: ".join(', ', keys(%kids)); + } else { + $ans .= " now."; + } + $SOCK->send("$ans\n"); + logit("client ".$sock_client_id." sent [ $msg ]"); + exit_after_jobs(); + next; + } + if (/^STAT$/i) { + my $now = time; + $ans = "STATTIME=".strftime("%Y-%m-%d %H:%M:%S (UTC%z)",localtime($now))."\n"; + my @enqs = glob("$SCHED{PATH_RES}/*"); + my @paused = ('No','Yes','Stopping...'); + $ans .= "STARTED=$STRTTS\n"; + $ans .= "PID=$PID\n"; + $ans .= "USER=$PUID\n"; + $ans .= "uTICK=$utick\n"; + $ans .= "BEAT=$SCHED{BEAT}\n"; + $ans .= sprintf("ELT=%.3f (%.2f%%)\n", $ELT, ($ELT*100)/($now-$STRT)); + $ans .= "LOG=$LOGNAME\n"; + $ans .= "JOBSDB=$SCHED{SQL_DB_JOBS}\n"; + $ans .= "JOBS STDio=$SCHED{PATH_STD}\n"; + $ans .= "JOBS RESource=$SCHED{PATH_RES}\n"; + $ans .= "PAUSED=$paused[$PAUSED]\n"; + $ans .= "#JOBSTART=$JSTARTED\n"; + $ans .= "#JOBSEND=$JENDED\n"; + $ans .= "KIDS=".scalar(keys(%kids))."\n"; + $ans .= "ENQs=".scalar(@enqs)."\n"; + next; + } + $ans = "command unknown or invalid at this time\n"; + } + next; + } + $ans = "Unknown action '$_'.\n"; + } + $SOCK->send($ans); + logit("client ".$sock_client_id." sent [ $cmd $msg ]; reply ".length($ans)." bytes") if ($verbose); } # ---------------------------------------------------------- # write to scheduler's log # ---------------------------------------------------------- sub logit { - my ($logtxt) = @_; - my $TS=[gettimeofday]; - my $ts=sprintf ("%s.%6.6s", strftime("%Y-%m-%d %H:%M:%S",localtime(@$TS[0])),@$TS[1]*100); - my $tsdate=substr($ts,0,10); - - if (($lldate ne '' && $tsdate ne $lldate) || $forcesavelog == 1) { - # it is time to save the log file and start a new one - $forcesavelog = 0; - close(LOG); - (my $tsfn = $ts) =~ s| |-|g; - my $rc = move("$LOGNAME", "$SAVELOGPATH/$tsfn"); - open LOG, ">>$LOGNAME"; - if ($rc == 0) { - print LOG "$ts saved log to $SAVELOGPATH/$tsfn\n"; - } else { - print LOG "$ts: Error: could not move file '$LOGNAME' to '$SAVELOGPATH/$tsfn'\n"; - } - } - - if ($logtxt ne $DITTO) { - if ($DITTO ne '' && $DITTOCNT != 0) { - print LOG "$ts $DITTO (x$DITTOCNT)\n"; - } - print LOG "$ts $logtxt\n"; - $DITTO = $logtxt; - $DITTOCNT = 0; - } else { - if ($DITTOCNT++ == $SCHED{DITTO_LOG_MAX}-1) { - print LOG "$ts $DITTO (x$DITTOCNT)\n"; - $DITTOCNT = 0; - } - } - $lldate = $tsdate; + my ($logtxt) = @_; + my $TS=[gettimeofday]; + my $ts=sprintf ("%s.%6.6s", strftime("%Y-%m-%d %H:%M:%S",localtime(@$TS[0])),@$TS[1]*100); + my $tsdate=substr($ts,0,10); + + if (($lldate ne '' && $tsdate ne $lldate) || $forcesavelog == 1) { + + # it is time to save the log file and start a new one + $forcesavelog = 0; + close(LOG); + (my $tsfn = $ts) =~ s| |-|g; + my $rc = move("$LOGNAME", "$SAVELOGPATH/$tsfn"); + open LOG, ">>$LOGNAME"; + if ($rc == 0) { + print LOG "$ts saved log to $SAVELOGPATH/$tsfn\n"; + } else { + print LOG "$ts: Error: could not move file '$LOGNAME' to '$SAVELOGPATH/$tsfn'\n"; + } + } + + if ($logtxt ne $DITTO) { + if ($DITTO ne '' && $DITTOCNT != 0) { + print LOG "$ts $DITTO (x$DITTOCNT)\n"; + } + print LOG "$ts $logtxt\n"; + $DITTO = $logtxt; + $DITTOCNT = 0; + } else { + if ($DITTOCNT++ == $SCHED{DITTO_LOG_MAX}-1) { + print LOG "$ts $DITTO (x$DITTOCNT)\n"; + $DITTOCNT = 0; + } + } + $lldate = $tsdate; } # ---------------------------------------------------------- # send notification to postboard # ---------------------------------------------------------- sub notifyit { - my ($ntftxt) = @_; - my $ntf; - - if ($ntftxt ne $DITTONTF) { - if ($DITTONTF ne '' && $DITTONTFCNT != 0){ - $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); - WebObs::Config::notify("$ntf"); - } - $ntf=sprintf ("%s", $ntftxt); - WebObs::Config::notify("$ntf"); - $DITTONTF = $ntftxt; - $DITTONTFCNT = 0; - } else { - if ($DITTONTFCNT++ == $SCHED{DITTO_LOG_MAX}-1) { - $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); - WebObs::Config::notify("$ntf"); - $DITTONTFCNT = 0; - } - } + my ($ntftxt) = @_; + my $ntf; + + if ($ntftxt ne $DITTONTF) { + if ($DITTONTF ne '' && $DITTONTFCNT != 0){ + $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); + WebObs::Config::notify("$ntf"); + } + $ntf=sprintf ("%s", $ntftxt); + WebObs::Config::notify("$ntf"); + $DITTONTF = $ntftxt; + $DITTONTFCNT = 0; + } else { + if ($DITTONTFCNT++ == $SCHED{DITTO_LOG_MAX}-1) { + $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); + WebObs::Config::notify("$ntf"); + $DITTONTFCNT = 0; + } + } } # ---------------------------------------------------------- # clean exit with optional rc # ---------------------------------------------------------- sub myexit { - my $code = shift // 1; - logit("scheduler[$$] exiting with code $code."); - close(LOG); - exit($code); + my $code = shift // 1; + logit("scheduler[$$] exiting with code $code."); + close(LOG); + exit($code); } __END__ diff --git a/CODE/perl/seiscomp2mc3.pl b/CODE/perl/seiscomp2mc3.pl index 7a30c136..75ea8158 100755 --- a/CODE/perl/seiscomp2mc3.pl +++ b/CODE/perl/seiscomp2mc3.pl @@ -44,6 +44,7 @@ =head1 DEPENDENCIES use WebObs::Config; use WebObs::QML; + # Date parsing library use DateTime::Format::Strptime; @@ -62,60 +63,60 @@ =head1 DEPENDENCIES # ---- help text when no arguments if (@ARGV == 0) { - print "WebObs SeisComP to MC3 seismic bulletin\n\n", - "Usage: $0 COMMAND [OPTIONS]\n\n", - "\tThe script checks new events in QuakeML SeisComP database and updates\n", - "\tif necessary the MC3 database by creating new events entries. List of\n", - "\tavailable commands and options:\n\n", - "\tupdate\n", - "\t\tUpdates MC3 database.\n", - "\tcheck\n", - "\t\tchecks MC3 database (read only).\n", - "\tdumper\n", - "\t\tchecks and dumps XML tree (read only).\n", - "\t-f MC3NAME\n", - "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", - "\t-n SEFRAN3 name\n", - "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", - "\n\tFrancois Beauducel, IPGP \n\n" - ; - exit(0); + print "WebObs SeisComP to MC3 seismic bulletin\n\n", + "Usage: $0 COMMAND [OPTIONS]\n\n", + "\tThe script checks new events in QuakeML SeisComP database and updates\n", + "\tif necessary the MC3 database by creating new events entries. List of\n", + "\tavailable commands and options:\n\n", + "\tupdate\n", + "\t\tUpdates MC3 database.\n", + "\tcheck\n", + "\t\tchecks MC3 database (read only).\n", + "\tdumper\n", + "\t\tchecks and dumps XML tree (read only).\n", + "\t-f MC3NAME\n", + "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", + "\t-n SEFRAN3 name\n", + "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", + "\n\tFrancois Beauducel, IPGP \n\n" + ; + exit(0); } # ---- check for command and option my $arg; if (@ARGV > 0) { - $arg = shift; - if (!($arg =~ /update|check|dumper/)) { - print "'$arg' invalid command\n"; - exit(1); - } - my $opt = shift || ''; - if ( $opt =~ /-f/ ) { - $opt = shift; - if ( $opt ) { - if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { - $mc3 = $opt; - } else { - print "'$opt' does not exists\n"; - exit(1); - } - } else { - print "invalid -f option\n"; - exit(1); - } - } - if ( $opt =~ /-n/ ) { - $opt = shift; - if ( $opt ) { - $sefran3_name = $opt; - print "-n option $sefran3_name\n"; - $opt = shift || ''; - } else { - print "invalid -n option\n"; - exit(1); - } - } + $arg = shift; + if (!($arg =~ /update|check|dumper/)) { + print "'$arg' invalid command\n"; + exit(1); + } + my $opt = shift || ''; + if ( $opt =~ /-f/ ) { + $opt = shift; + if ( $opt ) { + if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { + $mc3 = $opt; + } else { + print "'$opt' does not exists\n"; + exit(1); + } + } else { + print "invalid -f option\n"; + exit(1); + } + } + if ( $opt =~ /-n/ ) { + $opt = shift; + if ( $opt ) { + $sefran3_name = $opt; + print "-n option $sefran3_name\n"; + $opt = shift || ''; + } else { + print "invalid -n option\n"; + exit(1); + } + } } # ---- read config @@ -124,8 +125,8 @@ =head1 DEPENDENCIES my @blacklist_types = split(/,/,$MC3{SC3_EVENT_TYPES_BLACKLIST}); if (! -d $MC3{SC3_EVENTS_ROOT} ) { - print "creating $MC3{SC3_EVENTS_ROOT}\n"; - my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); + print "creating $MC3{SC3_EVENTS_ROOT}\n"; + my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); } # ---- gets the list of last events @@ -135,340 +136,358 @@ =head1 DEPENDENCIES # checks if events exist in MC database for (@last) { - my $name = $_; - $name =~ s/$MC3{SC3_EVENTS_ROOT}\///; - my ($evt_y,$evt_m,$evt_d,$evt_id) = split(/\//,$name); - my $fullname = "$_/$evt_id.last.xml"; - print "--- checking $fullname ---\n"; - - my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; - my @lines = qx(grep "$evt_id" $mc_path|cut -d'|' -f14|xargs echo -n); - my $mc_file; - - if (@lines) { - # event's ID already exists in MC: do nothing (for the moment...) - $mc_file = ""; - } else { - - # ------------------------------------------------------------------------- - # event seems new: updates MC file - print "new event : $evt_id\n"; - - my @tab; - my $s; - - my @event = qx($WEBOBS{XML2_PRGM} < $fullname); - - $s = '/seiscomp/EventParameters'; - foreach (@event) { s/^$s//g; } - - if ($arg =~ /dumper/) { - print join('',@event); - } - chomp(@event); - - # --- gets event type - my $evt_type = findvalue('/event/type=',\@event) // ''; - print "event type = $evt_type\n"; - if (grep(/^$evt_type$/,@blacklist_types)) { - print "Warning: Event type '$evt_type' is blacklisted!\n"; - } else { - - # --- gets preferred origin ID - my $evt_origID = findvalue('/event/preferredOriginID=',\@event); - print "origin ID = $evt_origID\n"; - - # --- selects preferred origin - my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); - - # --- gets origin:time - my $evt_time = findvalue('/time/value=',\@origin); - print "origin time = $evt_time\n"; - - # --- gets origin:latitude - my $evt_lat = findvalue('/latitude/value=',\@origin); - print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; - - # --- gets origin:longitude - my $evt_lon = findvalue('/longitude/value=',\@origin); - print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; - - # --- gets origin:methodID - my $evt_mcID = findvalue('/methodID=',\@origin) // ''; - print "origin methodID (MCID) = $evt_mcID\n"; - my ($mcIDname,$mcIDym,$mcIDid) = split(/\//,$evt_mcID); - - # --- gets origin:depth - my $evt_dep = findvalue('/depth/value=',\@origin); - print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; - - # --- gets origin:evaluationMode and origin:evaluationStatus - my $evt_mode = findvalue('/evaluationMode=',\@origin); - my $evt_status = findvalue('/evaluationStatus=',\@origin); - if ($evt_status && $evt_status eq 'confirmed') { - $evt_type = 'UNKNOWN'; - } else { - $evt_type = 'AUTO'; - } - - print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; - print "origin status = ".($evt_status ? "$evt_status":"")."\n"; - - # --- gets preferred magnitude ID - my $evt_magID = findvalue('/event/preferredMagnitudeID=',\@event); - - my $evt_mag = ''; - my $evt_smag = ''; - my @magnitude; - if ($evt_magID) { - print "origin magnitude ID = $evt_magID\n"; - @magnitude = findnode('/origin/magnitude',"/\@publicID=$evt_magID",\@event); - } else { - @magnitude = findnode('/origin/magnitude','/\@publicID=',\@event); - print "* Warning: no preferred magnitude! Takes first...\n"; - } - if (@magnitude) { - $evt_mag = findvalue('/magnitude/value=',\@magnitude); - print "origin magnitude = $evt_mag\n"; - $evt_smag = $evt_mag; - } else { - print "* Warning: no magnitude!\n"; - } - - - # --- selects first pick - # sorting pick:time:value = chronological order - @tab = sort(findvalues('/pick/time/value=',\@event)); - my $evt_pick = $tab[0]; - my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); - my $evt_pickID = findvalue('/\@publicID=',\@pick); - my $evt_sdate = substr($evt_pick,0,10) // ''; - my $evt_stime = substr($evt_pick,11,11) // ''; - $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" - my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; - my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; - my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; - my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; - my $evt_scode = "$NET.$STA.$LOC.$CHA"; - print "station pickID = $evt_pickID\n"; - print "station time = $evt_pick\n"; - print "station code = $evt_scode\n"; - - - my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); - - my $evt_pha = ''; - my $evt_dist = ''; - my $evt_unique = 0; - my $evt_SP = ''; - if (@arrival) { - # --- unique arrival or not - if (scalar(@arrival) == 1) { - $evt_unique = 1; - } - - # --- finds first station phase and distance (using "origin:arrival") - $evt_pha = findvalue('/phase=',\@arrival); - $evt_dist = findvalue('/distance=',\@arrival); - $evt_dist *= 111 if ($evt_dist); - print "station phase = $evt_pha\n"; - print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; - # --- computes S-P and duration from distance and magnitude - $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); - print "station S-P = $evt_SP\n"; - } else { - print "* Warning: no arrivals (phase, distance, S-P)!\n"; - } - - # --- computes duration from distance and magnitude - my $evt_dur = ''; - if ($evt_smag && $evt_dist) { - $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); - print "station duration = $evt_dur\n"; - if ($evt_dur == 0) { - $evt_dur = ''; - } - } else { - print "* Warning: no duration!\n"; - } - - # --- selects first station arrival (using "amplitude") - my @amplitude = findnode('/amplitude',"/pickID=$evt_pickID",\@event); - - my $evt_samp = ''; - if (@amplitude) { - # --- gets amplitude:value - $evt_samp = findvalue('/amplitude/value=',\@amplitude); - print "station amplitude = $evt_samp\n"; - } else { - print "* Warning: no amplitude!\n"; - } - - if (!$evt_sdate) { - # If the event doesn't have any picks, we get /origin/time/value (already stored in $evt_time) - $evt_sdate = substr($evt_time,0,10) || ''; - $evt_stime = substr($evt_time,11,11) || ''; - $evt_stime =~ s/[A-Z]/0/g; # remove trailing "Z" in "2012-05-07T18:46:53.7Z" - } - - - my $lockFile = "/tmp/.$mc3.lock"; - - if ($arg =~ /update/) { - # --- checks lock file - if (-e $lockFile) { - my $lockWho = qx(cat $lockFile | xargs echo -n); - die "WEBOBS: MC is presently edited by $lockWho ..."; - } else { - my $retLock = qx(echo "$oper" > $lockFile); - } - } - - my $mc_id; - my $newID = 1; - my $maxID = 0; - - # --- reads MC file - my ($mcy,$mcm) = split(/-/,$evt_sdate); - # The date of the event is mandatory - if (defined($mcy)) { - $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; - my @lignes; - if (-e $mc_file) { - print "MC file: $mc_file ..."; - open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); - while() { - my $line = $_; - my $line2=$line; - chomp($line2); - ($mc_id) = split(/\|/,$line2); - # Ignore blank lines - if (defined($mc_id)) { - # check if $evt_mcID found - if ($evt_mcID ne '') { - if ($mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { - my @txt = split(/\|/,$line); - # Sanity check : we mustn't change a SC3 ID already stored in the MC3 file - if ( $txt[13] eq '' ) { - # Sanity check : we update the MC file only if the date of the event is the same (under $max_dts_sc3_mc3) - # It is necessary if the MC file has been corrupted or deleted and the new file doesn't have the same IDs than before, so we can't use the MC IDs stored in SC3 - my $strp = DateTime::Format::Strptime->new( - pattern => '%Y-%m-%d %H:%M:%S', - time_zone => 'UTC', - ); - # Datetimes in XML and MC3 (truncated to second) - my $dt_qml = $strp->parse_datetime($evt_sdate." ".substr($evt_stime,0,8)); - my $dt_mc = $strp->parse_datetime($txt[1]." ".substr($txt[2],0,8)); - # Unix timestamps in XML and MC3 - my $ts_qml=$dt_qml->epoch; - my $ts_mc=$dt_mc->epoch; - # Difference of timestamps : it must be under $max_dts_sc3_mc3 - my $dts=abs($ts_qml-$ts_mc); - # If it's the same event - if ($dts < $max_dts_sc3_mc3) { - $newID = 0; - # Update Event ID - print "Replacing ID $txt[13] by $evt_y/$evt_m/$evt_d/$evt_id (dts $dts)\n"; - $txt[13] = "$evt_y/$evt_m/$evt_d/$evt_id"; - # @txt last field already contains "\n" - $line = join('|',@txt); - } else { - print "Same MC ID ($mc_id) but with different date : $evt_sdate $evt_stime (QML) != $txt[1] $txt[2] (MC)\n" - } - } else { - print "This MC ID ($mc_id) already has a SC3 ID ($txt[13]) !\n" - } - } - } - $maxID = abs($mc_id) if (abs($mc_id) > $maxID); - } - push(@lignes,$line); - } - close(FILE); - print " imported (max ID = $maxID).\n"; - } else { - # MC file does not exist: need to create directory and empty file. - if ($arg =~ /update/) { - qx(mkdir -p `dirname $mc_file`); - open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); - print FILE (""); - close(FILE); - $mc_id = 1; - } - } - - # --- outputs for MC - if ($newID > 0) { - $mc_id = $maxID + 1; - my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$evt_y/$evt_m/$evt_d/$evt_id||$oper|\n"; - print "$newline\n"; - push(@lignes,$newline); - } - - - - if ($arg =~ /update/) { - @lignes = sort Sort_date_with_id(@lignes); - - # Temporary file for sanity check before replacing - my $mc_file_temp="$mc_file.tmp"; - # Open temporary file for writing - open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); - # Write the updated lines - print FILE @lignes; - close(FILE); - # Sanity check : the columns number must always be 17 (empty lines are ignored) - if (system("awk -F'|' 'NF>0&&NF!=17{exit 1}' $mc_file") == 0) { - # Test passed, the file isn't corrupted - # The update should have increased the file size - if ( -s $mc_file_temp >= -s $mc_file ) { - # The file size is increased - # Replace the old file by the new one - if ( system("mv $mc_file_temp $mc_file") == 0 ) { - print "MC file: $mc_file updated\n"; - } else { - Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); - } - } - } else { - print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; - } - - } - } else { - print "No date for this new event !"; - } - if ($arg =~ /update/) { - # --- deletes lock file - if (-e $lockFile) { - unlink $lockFile; - } - } - } - } - - setlocale(LC_NUMERIC,$old_locale); + my $name = $_; + $name =~ s/$MC3{SC3_EVENTS_ROOT}\///; + my ($evt_y,$evt_m,$evt_d,$evt_id) = split(/\//,$name); + my $fullname = "$_/$evt_id.last.xml"; + print "--- checking $fullname ---\n"; + + my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; + my @lines = qx(grep "$evt_id" $mc_path|cut -d'|' -f14|xargs echo -n); + my $mc_file; + + if (@lines) { + + # event's ID already exists in MC: do nothing (for the moment...) + $mc_file = ""; + } else { + + # ------------------------------------------------------------------------- + # event seems new: updates MC file + print "new event : $evt_id\n"; + + my @tab; + my $s; + + my @event = qx($WEBOBS{XML2_PRGM} < $fullname); + + $s = '/seiscomp/EventParameters'; + foreach (@event) { s/^$s//g; } + + if ($arg =~ /dumper/) { + print join('',@event); + } + chomp(@event); + + # --- gets event type + my $evt_type = findvalue('/event/type=',\@event) // ''; + print "event type = $evt_type\n"; + if (grep(/^$evt_type$/,@blacklist_types)) { + print "Warning: Event type '$evt_type' is blacklisted!\n"; + } else { + + # --- gets preferred origin ID + my $evt_origID = findvalue('/event/preferredOriginID=',\@event); + print "origin ID = $evt_origID\n"; + + # --- selects preferred origin + my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); + + # --- gets origin:time + my $evt_time = findvalue('/time/value=',\@origin); + print "origin time = $evt_time\n"; + + # --- gets origin:latitude + my $evt_lat = findvalue('/latitude/value=',\@origin); + print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; + + # --- gets origin:longitude + my $evt_lon = findvalue('/longitude/value=',\@origin); + print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; + + # --- gets origin:methodID + my $evt_mcID = findvalue('/methodID=',\@origin) // ''; + print "origin methodID (MCID) = $evt_mcID\n"; + my ($mcIDname,$mcIDym,$mcIDid) = split(/\//,$evt_mcID); + + # --- gets origin:depth + my $evt_dep = findvalue('/depth/value=',\@origin); + print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; + + # --- gets origin:evaluationMode and origin:evaluationStatus + my $evt_mode = findvalue('/evaluationMode=',\@origin); + my $evt_status = findvalue('/evaluationStatus=',\@origin); + if ($evt_status && $evt_status eq 'confirmed') { + $evt_type = 'UNKNOWN'; + } else { + $evt_type = 'AUTO'; + } + + print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; + print "origin status = ".($evt_status ? "$evt_status":"")."\n"; + + # --- gets preferred magnitude ID + my $evt_magID = findvalue('/event/preferredMagnitudeID=',\@event); + + my $evt_mag = ''; + my $evt_smag = ''; + my @magnitude; + if ($evt_magID) { + print "origin magnitude ID = $evt_magID\n"; + @magnitude = findnode('/origin/magnitude',"/\@publicID=$evt_magID",\@event); + } else { + @magnitude = findnode('/origin/magnitude','/\@publicID=',\@event); + print "* Warning: no preferred magnitude! Takes first...\n"; + } + if (@magnitude) { + $evt_mag = findvalue('/magnitude/value=',\@magnitude); + print "origin magnitude = $evt_mag\n"; + $evt_smag = $evt_mag; + } else { + print "* Warning: no magnitude!\n"; + } + + # --- selects first pick + # sorting pick:time:value = chronological order + @tab = sort(findvalues('/pick/time/value=',\@event)); + my $evt_pick = $tab[0]; + my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); + my $evt_pickID = findvalue('/\@publicID=',\@pick); + my $evt_sdate = substr($evt_pick,0,10) // ''; + my $evt_stime = substr($evt_pick,11,11) // ''; + $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" + my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; + my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; + my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; + my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; + my $evt_scode = "$NET.$STA.$LOC.$CHA"; + print "station pickID = $evt_pickID\n"; + print "station time = $evt_pick\n"; + print "station code = $evt_scode\n"; + + my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); + + my $evt_pha = ''; + my $evt_dist = ''; + my $evt_unique = 0; + my $evt_SP = ''; + if (@arrival) { + + # --- unique arrival or not + if (scalar(@arrival) == 1) { + $evt_unique = 1; + } + + # --- finds first station phase and distance (using "origin:arrival") + $evt_pha = findvalue('/phase=',\@arrival); + $evt_dist = findvalue('/distance=',\@arrival); + $evt_dist *= 111 if ($evt_dist); + print "station phase = $evt_pha\n"; + print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; + + # --- computes S-P and duration from distance and magnitude + $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); + print "station S-P = $evt_SP\n"; + } else { + print "* Warning: no arrivals (phase, distance, S-P)!\n"; + } + + # --- computes duration from distance and magnitude + my $evt_dur = ''; + if ($evt_smag && $evt_dist) { + $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); + print "station duration = $evt_dur\n"; + if ($evt_dur == 0) { + $evt_dur = ''; + } + } else { + print "* Warning: no duration!\n"; + } + + # --- selects first station arrival (using "amplitude") + my @amplitude = findnode('/amplitude',"/pickID=$evt_pickID",\@event); + + my $evt_samp = ''; + if (@amplitude) { + + # --- gets amplitude:value + $evt_samp = findvalue('/amplitude/value=',\@amplitude); + print "station amplitude = $evt_samp\n"; + } else { + print "* Warning: no amplitude!\n"; + } + + if (!$evt_sdate) { + +# If the event doesn't have any picks, we get /origin/time/value (already stored in $evt_time) + $evt_sdate = substr($evt_time,0,10) || ''; + $evt_stime = substr($evt_time,11,11) || ''; + $evt_stime =~ s/[A-Z]/0/g; # remove trailing "Z" in "2012-05-07T18:46:53.7Z" + } + + my $lockFile = "/tmp/.$mc3.lock"; + + if ($arg =~ /update/) { + + # --- checks lock file + if (-e $lockFile) { + my $lockWho = qx(cat $lockFile | xargs echo -n); + die "WEBOBS: MC is presently edited by $lockWho ..."; + } else { + my $retLock = qx(echo "$oper" > $lockFile); + } + } + + my $mc_id; + my $newID = 1; + my $maxID = 0; + + # --- reads MC file + my ($mcy,$mcm) = split(/-/,$evt_sdate); + + # The date of the event is mandatory + if (defined($mcy)) { + $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; + my @lignes; + if (-e $mc_file) { + print "MC file: $mc_file ..."; + open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); + while() { + my $line = $_; + my $line2=$line; + chomp($line2); + ($mc_id) = split(/\|/,$line2); + + # Ignore blank lines + if (defined($mc_id)) { + + # check if $evt_mcID found + if ($evt_mcID ne '') { + if ($mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { + my @txt = split(/\|/,$line); + + # Sanity check : we mustn't change a SC3 ID already stored in the MC3 file + if ( $txt[13] eq '' ) { + +# Sanity check : we update the MC file only if the date of the event is the same (under $max_dts_sc3_mc3) +# It is necessary if the MC file has been corrupted or deleted and the new file doesn't have the same IDs than before, so we can't use the MC IDs stored in SC3 + my $strp = DateTime::Format::Strptime->new( + pattern => '%Y-%m-%d %H:%M:%S', + time_zone => 'UTC', + ); + + # Datetimes in XML and MC3 (truncated to second) + my $dt_qml = $strp->parse_datetime($evt_sdate." ".substr($evt_stime,0,8)); + my $dt_mc = $strp->parse_datetime($txt[1]." ".substr($txt[2],0,8)); + + # Unix timestamps in XML and MC3 + my $ts_qml=$dt_qml->epoch; + my $ts_mc=$dt_mc->epoch; + + # Difference of timestamps : it must be under $max_dts_sc3_mc3 + my $dts=abs($ts_qml-$ts_mc); + + # If it's the same event + if ($dts < $max_dts_sc3_mc3) { + $newID = 0; + + # Update Event ID + print "Replacing ID $txt[13] by $evt_y/$evt_m/$evt_d/$evt_id (dts $dts)\n"; + $txt[13] = "$evt_y/$evt_m/$evt_d/$evt_id"; + + # @txt last field already contains "\n" + $line = join('|',@txt); + } else { + print "Same MC ID ($mc_id) but with different date : $evt_sdate $evt_stime (QML) != $txt[1] $txt[2] (MC)\n" + } + } else { + print "This MC ID ($mc_id) already has a SC3 ID ($txt[13]) !\n" + } + } + } + $maxID = abs($mc_id) if (abs($mc_id) > $maxID); + } + push(@lignes,$line); + } + close(FILE); + print " imported (max ID = $maxID).\n"; + } else { + + # MC file does not exist: need to create directory and empty file. + if ($arg =~ /update/) { + qx(mkdir -p `dirname $mc_file`); + open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); + print FILE (""); + close(FILE); + $mc_id = 1; + } + } + + # --- outputs for MC + if ($newID > 0) { + $mc_id = $maxID + 1; + my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$evt_y/$evt_m/$evt_d/$evt_id||$oper|\n"; + print "$newline\n"; + push(@lignes,$newline); + } + + if ($arg =~ /update/) { + @lignes = sort Sort_date_with_id(@lignes); + + # Temporary file for sanity check before replacing + my $mc_file_temp="$mc_file.tmp"; + + # Open temporary file for writing + open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); + + # Write the updated lines + print FILE @lignes; + close(FILE); + + # Sanity check : the columns number must always be 17 (empty lines are ignored) + if (system("awk -F'|' 'NF>0&&NF!=17{exit 1}' $mc_file") == 0) { + + # Test passed, the file isn't corrupted + # The update should have increased the file size + if ( -s $mc_file_temp >= -s $mc_file ) { + + # The file size is increased + # Replace the old file by the new one + if ( system("mv $mc_file_temp $mc_file") == 0 ) { + print "MC file: $mc_file updated\n"; + } else { + Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); + } + } + } else { + print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; + } + + } + } else { + print "No date for this new event !"; + } + if ($arg =~ /update/) { + + # --- deletes lock file + if (-e $lockFile) { + unlink $lockFile; + } + } + } + } + + setlocale(LC_NUMERIC,$old_locale); } - #-------------------------------------------------------------------------------------------------------------------------------------- sub Sort_date_with_id ($$) { - my ($c,$d) = @_; + my ($c,$d) = @_; - # removes the first field (ID) - $c =~ s/^[\-0-9]+\|//; - $d =~ s/^[\-0-9]+\|//; + # removes the first field (ID) + $c =~ s/^[\-0-9]+\|//; + $d =~ s/^[\-0-9]+\|//; - return $d cmp $c; + return $d cmp $c; } #-------------------------------------------------------------------------------------------------------------------------------------- sub Quit { - if (-e $_[0]) { - unlink $_[0]; - } - die "WEBOBS: $_[1]"; + if (-e $_[0]) { + unlink $_[0]; + } + die "WEBOBS: $_[1]"; } __END__ diff --git a/CODE/perl/sendTHEIA.pl b/CODE/perl/sendTHEIA.pl index c2eab5ae..5af9fc41 100755 --- a/CODE/perl/sendTHEIA.pl +++ b/CODE/perl/sendTHEIA.pl @@ -48,11 +48,11 @@ =head1 DESCRIPTION # ---- local functions # Compress $tmpdir's files into $zipfile without the whole path in the compress archive sub compressTxtFiles { - my $dataset = shift; - my $dataName = (split /\_/, $dataset)[-1]; - my $tmpdir = shift; - zip [ <$tmpdir/*$dataName\_*.txt> ] => "$tmpdir/$dataset.zip", - FilterName => sub { s[^$tmpdir/][] }; + my $dataset = shift; + my $dataName = (split /\_/, $dataset)[-1]; + my $tmpdir = shift; + zip [ <$tmpdir/*$dataName\_*.txt> ] => "$tmpdir/$dataset.zip", + FilterName => sub { s[^$tmpdir/][] }; } # ---- creating tmp and exports/theia directories if required @@ -60,15 +60,15 @@ sub compressTxtFiles { my $theiadir = "$WEBOBS{ROOT_OUTE}/theia/$datedir"; if ( ! -e $tmpdir ) { - make_path($tmpdir, {chmod => 0775}); + make_path($tmpdir, {chmod => 0775}); } if ( ! -e $theiadir ) { - make_path($theiadir, {chmod => 0775}); + make_path($theiadir, {chmod => 0775}); } my $json_validator_path = "$WEBOBS{ROOT_CODE}/bin/java/JSON-schema-validation-0-jar-with-dependencies.jar"; if ( ! -e $json_validator_path ) { - die "Please install $json_validator_path\n"; + die "Please install $json_validator_path\n"; } my @zip_files; @@ -85,58 +85,60 @@ sub compressTxtFiles { my %producer; while( my @row = $sth->fetchrow_array() ) { - %producer = ( - producerId => $row[0], - name => decode("utf8", $row[1]), - title => decode("utf8", $row[2]), - description => decode("utf8", $row[3]), - email => $row[6] - ); - if ($row[4] ne "") { - $producer{'objectives'} = decode("utf8", $row[4]); - } - if ($row[5] ne "") { - $producer{'measuredVariables'} = decode("utf8", $row[5]); - } - if ($row[9] ne "") { - # ---- parsing online resources - my %resource; - foreach(split(/_,/, $row[9])) { - my $typeUrl =(split '@', $_)[0]; - my $url = (split '@', $_)[1]; - if ($typeUrl =~ /download/) { - $resource{'urlDownload'} = $url; - } elsif ($typeUrl =~ /info/) { - $resource{'urlInfo'} = $url; - } elsif ($typeUrl =~ /doi/) { - $resource{'doi'} = $url; - } - } - $producer{'onlineResource'} = \%resource; - } - - # ---- extracting contacts data - - my $stmt2 = qq(SELECT * FROM contacts;); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - my @contacts; - - while( my @row2 = $sth2->fetchrow_array() ) { - if ($row2[4] eq $producer{'producerId'}) { - # ---- parsing contacts - my %contact = ( - firstName => decode("utf8", $row2[1]), - lastName => decode("utf8", $row2[2]), - email => $row2[0], - role => $row2[3], - ); - push(@contacts, \%contact); - } - } - - $producer{'contacts'} = \@contacts; + %producer = ( + producerId => $row[0], + name => decode("utf8", $row[1]), + title => decode("utf8", $row[2]), + description => decode("utf8", $row[3]), + email => $row[6] + ); + if ($row[4] ne "") { + $producer{'objectives'} = decode("utf8", $row[4]); + } + if ($row[5] ne "") { + $producer{'measuredVariables'} = decode("utf8", $row[5]); + } + if ($row[9] ne "") { + + # ---- parsing online resources + my %resource; + foreach(split(/_,/, $row[9])) { + my $typeUrl =(split '@', $_)[0]; + my $url = (split '@', $_)[1]; + if ($typeUrl =~ /download/) { + $resource{'urlDownload'} = $url; + } elsif ($typeUrl =~ /info/) { + $resource{'urlInfo'} = $url; + } elsif ($typeUrl =~ /doi/) { + $resource{'doi'} = $url; + } + } + $producer{'onlineResource'} = \%resource; + } + + # ---- extracting contacts data + + my $stmt2 = qq(SELECT * FROM contacts;); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + my @contacts; + + while( my @row2 = $sth2->fetchrow_array() ) { + if ($row2[4] eq $producer{'producerId'}) { + + # ---- parsing contacts + my %contact = ( + firstName => decode("utf8", $row2[1]), + lastName => decode("utf8", $row2[2]), + email => $row2[0], + role => $row2[3], + ); + push(@contacts, \%contact); + } + } + + $producer{'contacts'} = \@contacts; } $stmt = qq(SELECT * FROM organisations;); @@ -146,15 +148,16 @@ sub compressTxtFiles { my @fundings; while( my @row = $sth->fetchrow_array() ) { - # ---- parsing fundings - my %funding = ( - type => $row[0], - iso3166 => $row[1], - idScanR => $row[4], - name => decode("utf8", $row[3]), - acronym => $row[2], - ); - push(@fundings, \%funding); + + # ---- parsing fundings + my %funding = ( + type => $row[0], + iso3166 => $row[1], + idScanR => $row[4], + name => decode("utf8", $row[3]), + acronym => $row[2], + ); + push(@fundings, \%funding); } $producer{'fundings'} = \@fundings; @@ -165,109 +168,111 @@ sub compressTxtFiles { my @observations; foreach (@channels) { - $stmt = "SELECT * FROM observations "; - $stmt .= "INNER JOIN sampling_features ON observations.stationname = sampling_features.identifier "; - $stmt .= "INNER JOIN observed_properties ON observations.observedproperty = observed_properties.identifier"; - $stmt .= " WHERE observations.identifier = '$_'"; - $stmt = qq($stmt); - $sth = $dbh->prepare( $stmt ); - $rv = $sth->execute() or die $DBI::errstr; - - while( my @row = $sth->fetchrow_array() ) { - # print "\n", join(" ", @row[0 .. $#row-6]), "\n"; - # ---- data from observed_properties table - my %observedProperty = ( - name => decode("utf8", $row[13]), - unit => decode("utf8", $row[14]) - ); - - my @theiaCategories; - foreach (split(',', $row[15])) { - $_ =~ s/(\n)//g; - push(@theiaCategories, $_); - } - $observedProperty{"theiaCategories"} = \@theiaCategories; - - #print $observation{'observedProperty'}{'theiaCategories'}->[0]; - # ---- data from sampling_features table - # ---- parsing coordinates - my $geometry = (split ':', $row[11])[1]; - my $position = (split '\(|\)', $geometry)[1]; - my @coordinates = split(',', $position); - $coordinates[0] += 0; - my $lat = $coordinates[0]; - $coordinates[1] += 0; - my $lon = $coordinates[1]; - $coordinates[2] += 0; - my $alt = $coordinates[2]; - - my @new_crds = ($coordinates[1], $coordinates[0]); - - my %geometry = ( - type => (split '\(|\)', $geometry)[0], - coordinates => \@new_crds, - ); - my %samplingFeature = ( - name => $row[6], - geometry => \%geometry, - type => "Feature", - properties => {} - ); - my %featureOfInterest = ( - samplingFeature => \%samplingFeature, - ); - - my $GRIDType = 'PROC'; - my $GRIDName = (split /\./, $row[6])[0]; - my $NODEName = (split /\./, $row[6])[1]; - my $timescale = (split /\_/, $row[8])[-1]; - $timescale = (split /\./, $timescale)[0]; - my %datafile = ( - name => $producer{'producerId'}."_OBS_$GRIDName.$NODEName\_$observedProperty{'name'}.txt", - ); - my %result = ( - dataFile => \%datafile, - ); - - # ---- now generating the .txt file - my $dataname = "$NODEName\_$timescale.txt"; - my $filepath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/exports/"; - my $chan_nb = 5 + $row[16]; - my $obsfile = "$tmpdir/$datafile{'name'}"; - - # ---- generating .txt files for the observed properties - # ---- header - my $header = "#Date_of_extraction;$today;\n"; - $header .= "#Observation_ID;$row[0];\n"; - $header .= "#Dataset_title;;\n"; - $header .= "#Variable_name;".$row[5].";\n"; - $header .= "dateBeg;dateEnd;latitude;longitude;altitude;value;qualityFlags;\n"; - # ---- content - my $content = "grep -v '^#' $filepath$dataname | awk 'FS=\" \" {print \";\"\$1\"-\"\$2\"-\"\$3\"T\"\$4\":\"\$5\":\"\$6\"Z\",\"$lat\",\"$lon\",\"$alt\",\$$chan_nb\";\"}' OFS=\";\""; - $content = qx($content); - $header .= $content; - open(FILE, '>', $obsfile); - print FILE $header; - close(FILE); - - my %temporalExtent = ( - dateBeg => (split '/', $row[3])[0], - dateEnd => (split '/', $row[3])[1], - ); - - my %observation = ( - observationId => $row[0], - observedProperty => \%observedProperty, - featureOfInterest => \%featureOfInterest, - result => \%result, - dataType => $row[2], - timeSerie => \1, - temporalExtent => \%temporalExtent, - processingLevel => $row[1], - ); - - push(@observations, \%observation); - } + $stmt = "SELECT * FROM observations "; + $stmt .= "INNER JOIN sampling_features ON observations.stationname = sampling_features.identifier "; + $stmt .= "INNER JOIN observed_properties ON observations.observedproperty = observed_properties.identifier"; + $stmt .= " WHERE observations.identifier = '$_'"; + $stmt = qq($stmt); + $sth = $dbh->prepare( $stmt ); + $rv = $sth->execute() or die $DBI::errstr; + + while( my @row = $sth->fetchrow_array() ) { + + # print "\n", join(" ", @row[0 .. $#row-6]), "\n"; + # ---- data from observed_properties table + my %observedProperty = ( + name => decode("utf8", $row[13]), + unit => decode("utf8", $row[14]) + ); + + my @theiaCategories; + foreach (split(',', $row[15])) { + $_ =~ s/(\n)//g; + push(@theiaCategories, $_); + } + $observedProperty{"theiaCategories"} = \@theiaCategories; + + #print $observation{'observedProperty'}{'theiaCategories'}->[0]; + # ---- data from sampling_features table + # ---- parsing coordinates + my $geometry = (split ':', $row[11])[1]; + my $position = (split '\(|\)', $geometry)[1]; + my @coordinates = split(',', $position); + $coordinates[0] += 0; + my $lat = $coordinates[0]; + $coordinates[1] += 0; + my $lon = $coordinates[1]; + $coordinates[2] += 0; + my $alt = $coordinates[2]; + + my @new_crds = ($coordinates[1], $coordinates[0]); + + my %geometry = ( + type => (split '\(|\)', $geometry)[0], + coordinates => \@new_crds, + ); + my %samplingFeature = ( + name => $row[6], + geometry => \%geometry, + type => "Feature", + properties => {} + ); + my %featureOfInterest = ( + samplingFeature => \%samplingFeature, + ); + + my $GRIDType = 'PROC'; + my $GRIDName = (split /\./, $row[6])[0]; + my $NODEName = (split /\./, $row[6])[1]; + my $timescale = (split /\_/, $row[8])[-1]; + $timescale = (split /\./, $timescale)[0]; + my %datafile = ( + name => $producer{'producerId'}."_OBS_$GRIDName.$NODEName\_$observedProperty{'name'}.txt", + ); + my %result = ( + dataFile => \%datafile, + ); + + # ---- now generating the .txt file + my $dataname = "$NODEName\_$timescale.txt"; + my $filepath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/exports/"; + my $chan_nb = 5 + $row[16]; + my $obsfile = "$tmpdir/$datafile{'name'}"; + + # ---- generating .txt files for the observed properties + # ---- header + my $header = "#Date_of_extraction;$today;\n"; + $header .= "#Observation_ID;$row[0];\n"; + $header .= "#Dataset_title;;\n"; + $header .= "#Variable_name;".$row[5].";\n"; + $header .= "dateBeg;dateEnd;latitude;longitude;altitude;value;qualityFlags;\n"; + + # ---- content + my $content = "grep -v '^#' $filepath$dataname | awk 'FS=\" \" {print \";\"\$1\"-\"\$2\"-\"\$3\"T\"\$4\":\"\$5\":\"\$6\"Z\",\"$lat\",\"$lon\",\"$alt\",\$$chan_nb\";\"}' OFS=\";\""; + $content = qx($content); + $header .= $content; + open(FILE, '>', $obsfile); + print FILE $header; + close(FILE); + + my %temporalExtent = ( + dateBeg => (split '/', $row[3])[0], + dateEnd => (split '/', $row[3])[1], + ); + + my %observation = ( + observationId => $row[0], + observedProperty => \%observedProperty, + featureOfInterest => \%featureOfInterest, + result => \%result, + dataType => $row[2], + timeSerie => \1, + temporalExtent => \%temporalExtent, + processingLevel => $row[1], + ); + + push(@observations, \%observation); + } } # ---- extracting datasets data @@ -275,120 +280,127 @@ sub compressTxtFiles { my @datasets; foreach (@nodes) { - chomp($_); - $stmt = qq(SELECT * FROM datasets WHERE datasets.identifier = '$_';); - $sth = $dbh->prepare( $stmt ); - $rv = $sth->execute() or die $DBI::errstr; - - while( my @row = $sth->fetchrow_array() ) { - my $datasetId = (split /_DAT_/, $row[0]) [1]; - (my $GRIDName, my $NODEName) = (split /\./, $datasetId); - my %S = readNode($NODEName, "novsub"); - my %NODE = %{$S{$NODEName}}; - my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; - - my $topicCategories = (split '_', $row[2])[0]; - my @topicCategories; - foreach(split('_,', $topicCategories)) { - my $category = (split(':', $_))[1]; - #$category =~ s/(\r\n)//g; - push(@topicCategories, $category); - } - my %geometry = ( - type => JSON->new->utf8->decode($row[3])->{'type'}, - coordinates => JSON->new->utf8->decode($row[3])->{'coordinates'} - ); - my %spatialExtent = ( - type => "Feature", - properties => {}, - geometry => \%geometry, - ); - # print JSON->new->utf8->decode($row[$#row-1])->{'type'}; - my %dataConstraint = ( - accessUseConstraint => "No conditions to access and use", - ); - - my %metadata = ( - title => decode("utf8", $row[1]), - datasetLineage => $row[4], - dataConstraint => \%dataConstraint, - topicCategories => \@topicCategories, - inspireTheme => (split '_inspireTheme:', $row[2])[1], - spatialExtent => \%spatialExtent, - ); - $metadata{'inspireTheme'} =~ s/(\r\n)//g; - $metadata{'description'} = $desc; - - my %dataset = ( - datasetId => $row[0], - ); - - # ---- extracting contacts data - - my $stmt2 = qq(SELECT * FROM contacts;); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - my @contacts; - while( my @row2 = $sth2->fetchrow_array() ) { - if ($row2[4] eq $dataset{'datasetId'}) { - # ---- parsing contacts - my %contact = ( - firstName => decode("utf8", $row2[1]), - lastName => decode("utf8", $row2[2]), - email => $row2[0], - role => $row2[3], - ); - push(@contacts, \%contact); - } - } - - $metadata{'contacts'} = \@contacts; - $dataset{'metadata'} = \%metadata; - - my @ds_obs; - foreach(@observations) { - if (defined($_->{'observationId'})) { - my $obsId = (split /\./, $_->{'observationId'})[1]; - $obsId = (split /\_/, $obsId)[0]; - my $datId = (split /\./, $row[0])[1]; - if ($obsId eq $datId) { - push(@ds_obs, $_); - my $filename = decode_json encode_json $_->{'result'}->{'dataFile'}->{'name'}; - # ---- adding the title dataset into $filename - # ---- first we open $filename while creating a new $filename where we will write the line we want to insert - open my $in, '<', "$tmpdir/$filename" or die "Can't read old file: $!"; - open my $out, '>', "$tmpdir/$filename.new" or die "Can't write new file: $!"; - my $title = decode("utf8", $row[1]); - while( <$in> ) { - s/Dataset_title;/Dataset_title;$title/; # ---- writing the dataset title in the right row - print $out $_; - } - close $in; - close $out; - rename "$tmpdir/$filename.new", "$tmpdir/$filename"; - } - } - } - - #print encode_json $ds_obs[0]; - $dataset{'observations'} = \@ds_obs; - #print scalar(@{$dataset{'observations'}}), "\n"; - $empty = $dataset{'observations'} ? "yup" : "nope"; - # ---- compressing observations files into OBSE_DAT_PROC.NODE.zip - if ($empty eq "yup") { - if (@{$dataset{'observations'}}) { - push(@datasets, \%dataset); - compressTxtFiles("$dataset{'datasetId'}", $tmpdir) - #or die "$dataset{'datasetId'} needs to be associated with at least one observation !\n"; - } else { - print "$_ was discarded. There are no observations for this dataset!\n"; - } - } else { - compressTxtFiles("$dataset{'datasetId'}", $tmpdir) - or die "zip failed: $ZipError\n"; - } - } + chomp($_); + $stmt = qq(SELECT * FROM datasets WHERE datasets.identifier = '$_';); + $sth = $dbh->prepare( $stmt ); + $rv = $sth->execute() or die $DBI::errstr; + + while( my @row = $sth->fetchrow_array() ) { + my $datasetId = (split /_DAT_/, $row[0]) [1]; + (my $GRIDName, my $NODEName) = (split /\./, $datasetId); + my %S = readNode($NODEName, "novsub"); + my %NODE = %{$S{$NODEName}}; + my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; + + my $topicCategories = (split '_', $row[2])[0]; + my @topicCategories; + foreach(split('_,', $topicCategories)) { + my $category = (split(':', $_))[1]; + + #$category =~ s/(\r\n)//g; + push(@topicCategories, $category); + } + my %geometry = ( + type => JSON->new->utf8->decode($row[3])->{'type'}, + coordinates => JSON->new->utf8->decode($row[3])->{'coordinates'} + ); + my %spatialExtent = ( + type => "Feature", + properties => {}, + geometry => \%geometry, + ); + + # print JSON->new->utf8->decode($row[$#row-1])->{'type'}; + my %dataConstraint = ( + accessUseConstraint => "No conditions to access and use", + ); + + my %metadata = ( + title => decode("utf8", $row[1]), + datasetLineage => $row[4], + dataConstraint => \%dataConstraint, + topicCategories => \@topicCategories, + inspireTheme => (split '_inspireTheme:', $row[2])[1], + spatialExtent => \%spatialExtent, + ); + $metadata{'inspireTheme'} =~ s/(\r\n)//g; + $metadata{'description'} = $desc; + + my %dataset = ( + datasetId => $row[0], + ); + + # ---- extracting contacts data + + my $stmt2 = qq(SELECT * FROM contacts;); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + my @contacts; + while( my @row2 = $sth2->fetchrow_array() ) { + if ($row2[4] eq $dataset{'datasetId'}) { + + # ---- parsing contacts + my %contact = ( + firstName => decode("utf8", $row2[1]), + lastName => decode("utf8", $row2[2]), + email => $row2[0], + role => $row2[3], + ); + push(@contacts, \%contact); + } + } + + $metadata{'contacts'} = \@contacts; + $dataset{'metadata'} = \%metadata; + + my @ds_obs; + foreach(@observations) { + if (defined($_->{'observationId'})) { + my $obsId = (split /\./, $_->{'observationId'})[1]; + $obsId = (split /\_/, $obsId)[0]; + my $datId = (split /\./, $row[0])[1]; + if ($obsId eq $datId) { + push(@ds_obs, $_); + my $filename = decode_json encode_json $_->{'result'}->{'dataFile'}->{'name'}; + +# ---- adding the title dataset into $filename +# ---- first we open $filename while creating a new $filename where we will write the line we want to insert + open my $in, '<', "$tmpdir/$filename" or die "Can't read old file: $!"; + open my $out, '>', "$tmpdir/$filename.new" or die "Can't write new file: $!"; + my $title = decode("utf8", $row[1]); + while( <$in> ) { + s/Dataset_title;/Dataset_title;$title/; # ---- writing the dataset title in the right row + print $out $_; + } + close $in; + close $out; + rename "$tmpdir/$filename.new", "$tmpdir/$filename"; + } + } + } + + #print encode_json $ds_obs[0]; + $dataset{'observations'} = \@ds_obs; + + #print scalar(@{$dataset{'observations'}}), "\n"; + $empty = $dataset{'observations'} ? "yup" : "nope"; + + # ---- compressing observations files into OBSE_DAT_PROC.NODE.zip + if ($empty eq "yup") { + if (@{$dataset{'observations'}}) { + push(@datasets, \%dataset); + compressTxtFiles("$dataset{'datasetId'}", $tmpdir) + +#or die "$dataset{'datasetId'} needs to be associated with at least one observation !\n"; + } else { + print "$_ was discarded. There are no observations for this dataset!\n"; + } + } else { + compressTxtFiles("$dataset{'datasetId'}", $tmpdir) + or die "zip failed: $ZipError\n"; + } + } } #print encode_json \@datasets; @@ -396,15 +408,16 @@ sub compressTxtFiles { # ---- creating the final json object my %json = ( - producer => \%producer, - datasets => \@datasets, - version => "1.0", -); + producer => \%producer, + datasets => \@datasets, + version => "1.0", + ); $dbh->disconnect(); $filename = "$json{'producer'}{'producerId'}_en.json"; my $filepath = "$tmpdir/$filename"; + #print $cgi->header(-type=>'text/html', -charset=>'utf-8'); #print $filepath; #print encode_json $json{'datasets'}->[0]{'metadata'}{'contacts'}; @@ -426,27 +439,27 @@ sub compressTxtFiles { my $producerId = $producer{'producerId'}; my $zipfile = $producerId . "_THEIA.zip"; if ( $output =~ /success/ ) { - zip [ <$tmpdir/*DAT*.zip>, $filepath ] => "$theiadir/$zipfile", - FilterName => sub { s[^$tmpdir/][] } or die "zip failed: $ZipError\n"; - rmtree($tmpdir); + zip [ <$tmpdir/*DAT*.zip>, $filepath ] => "$theiadir/$zipfile", + FilterName => sub { s[^$tmpdir/][] } or die "zip failed: $ZipError\n"; + rmtree($tmpdir); } else { - print "The JSON metadata file is not valid :\n".$output; + print "The JSON metadata file is not valid :\n".$output; }; # ---- Send archive to Theia/OZCAR if ( $output =~ /success/ ) { - my $url = "https://in-situ.theia-land.fr/data/$producerId/new/"; - my $password = $WEBOBS{PASSWORD_THEIA}; - my $response = qx(curl -T "$theiadir/$zipfile" -u $producerId:$password -s -o /dev/null -w "%{http_code}" $url); - if ( rindex($response,"2", 0) eq 0 ) { - print "Data upload successful. Data are available at https://in-situ.theia-land.fr/data/OBSE/previous/", "\n"; - } - else { - print "Data upload failed: ", $response, "\n"; - die; - } + my $url = "https://in-situ.theia-land.fr/data/$producerId/new/"; + my $password = $WEBOBS{PASSWORD_THEIA}; + my $response = qx(curl -T "$theiadir/$zipfile" -u $producerId:$password -s -o /dev/null -w "%{http_code}" $url); + if ( rindex($response,"2", 0) eq 0 ) { + print "Data upload successful. Data are available at https://in-situ.theia-land.fr/data/OBSE/previous/", "\n"; + } + else { + print "Data upload failed: ", $response, "\n"; + die; + } } #print $observations[1]{'featureOfInterest'}{'samplingFeature'}{'geometry'}{'coordinates'}; diff --git a/CODE/perl/volcauto2mc.pl b/CODE/perl/volcauto2mc.pl index 815ac77c..64c938a9 100755 --- a/CODE/perl/volcauto2mc.pl +++ b/CODE/perl/volcauto2mc.pl @@ -25,11 +25,11 @@ use VolcAuto qw(create_mc3_lock remove_mc3_lock process_autovolc_csv); BEGIN { + # Suppress the default fatalsToBrowser from CGI::Carp $CGI::Carp::TO_BROWSER = 0; } - # ----------------------------------------------------------------------------- # Read script parameters # @@ -38,19 +38,19 @@ BEGIN my $mc3_name = $ARGV[0] || $WEBOBS{'MC3_DEFAULT_NAME'}; my $sefran_name = $ARGV[1] || $WEBOBS{'SEFRAN3_DEFAULT_NAME'}; - # ----------------------------------------------------------------------------- # Make sure the lock will be removed however the script is ended # END { + # Remove the lock (if we've created it ourself) remove_mc3_lock($mc3_name); } + # Handle Ctrl-c event (the END block will then be called) $SIG{'INT'} = sub { say STDERR "SIGINT caught, exiting."; exit(130); }; $SIG{'PIPE'} = sub { say STDERR "SIGPIPE caught, exiting."; exit(141); }; - # ----------------------------------------------------------------------------- # Main instructions diff --git a/CODE/perl/wiki2mmd.pl b/CODE/perl/wiki2mmd.pl index d861cbe5..a92bda4e 100755 --- a/CODE/perl/wiki2mmd.pl +++ b/CODE/perl/wiki2mmd.pl @@ -25,31 +25,30 @@ =head1 DESCRIPTION my $mmd = $WEBOBS{WIKI_MMD} // 'YES'; if ($mmd eq 'NO') { - print "Can't convert, configuration says WIKI_MMD|NO\n"; exit; + print "Can't convert, configuration says WIKI_MMD|NO\n"; exit; } - my $file = $ARGV[0] // ""; my $txt = ""; my $titre = ""; my @lines; if ($file ne "") { - if (!open(FILE, "<$file")) { print "Couldn't read $file\n"; exit; } - @lines = ; - close FILE; + if (!open(FILE, "<$file")) { print "Couldn't read $file\n"; exit; } + @lines = ; + close FILE; } else { print "No filename specified\n"; exit; } # convert if needed, print to stdout # $lines[0] =~ /^TITRE.*\n/ and $titre = $lines[0] and shift(@lines); ($txt, my @meta) = WebObs::Wiki::stripMDmetadata(join("",@lines)); -if (scalar(@meta) == 0) { - $txt = wiki2MMD($txt); - print($titre) if ($titre ne ""); - print "WebObs: converted with wiki2mmd.pl\n\n$txt\n"; -} else { - print "$file already MMD\n" -} +if (scalar(@meta) == 0) { + $txt = wiki2MMD($txt); + print($titre) if ($titre ne ""); + print "WebObs: converted with wiki2mmd.pl\n\n$txt\n"; +} else { + print "$file already MMD\n" +} exit; diff --git a/CODE/perl/woc.pl b/CODE/perl/woc.pl index 8450f020..9cf688ec 100755 --- a/CODE/perl/woc.pl +++ b/CODE/perl/woc.pl @@ -27,7 +27,7 @@ =head1 DESCRIPTION # ------------------------------------------------------------------------------ use strict; use FindBin; -use lib $FindBin::Bin; +use lib $FindBin::Bin; use Data::Dumper; use Term::ReadLine; use POSIX; @@ -44,8 +44,8 @@ =head1 DESCRIPTION use WebObs::Users; use WebObs::Form; our %SCHED; -if (defined($WEBOBS{CONF_SCHEDULER}) && -e $WEBOBS{CONF_SCHEDULER}) - { %SCHED = readCfg($WEBOBS{CONF_SCHEDULER}) } +if (defined($WEBOBS{CONF_SCHEDULER}) && -e $WEBOBS{CONF_SCHEDULER}) +{ %SCHED = readCfg($WEBOBS{CONF_SCHEDULER}) } #$SIG{'INT'} = 'hINT'; $SIG{__WARN__} = 'hWARN'; @@ -57,42 +57,43 @@ =head1 DESCRIPTION # WOC commands definitions/vectors --------------------------------------------- # ------------------------------------------------------------------------------ my %vectors = - ( - '%WEBOBS' => {'rtne' => \&dwebobs, 'seq' => 10, 'auth' => 'R' ,'help' => '%WEBOBS [key] : dump %WEBOBS key or all'}, - '-%WEBOBS' => {'rtne' => \&rwebobs, 'seq' => 20, 'auth' => 'R' ,'help' => '-%WEBOBS value : which %WEBOBS key(s) holds value'}, - '%OWNERS' => {'rtne' => \&downers, 'seq' => 30, 'auth' => 'R' ,'help' => '%OWNERS : dump all %OWNRS'}, - '%DISCP' => {'rtne' => \&ddiscp, 'seq' => 40, 'auth' => 'R' ,'help' => '%DISCP [discp] : dump %DISCP discp discipline or all'}, - '%USERS' => {'rtne' => \&dusers, 'seq' => 50, 'auth' => 'A' ,'help' => '%USERS [login] : dump %USERS login or all'}, - 'authres' => {'rtne' => \&authres, 'seq' => 55, 'auth' => 'A' ,'help' => 'authres : list all \'named\' auth resources'}, - 'user' => {'rtne' => \&dbuser, 'seq' => 60, 'auth' => 'A' ,'help' => 'user login : query DB USERS for login'}, - 'newuser' => {'rtne' => \&siuser, 'seq' => 70, 'auth' => 'A' ,'help' => 'newuser : add a user'}, - 'newgroup' => {'rtne' => \&sigroup, 'seq' => 75, 'auth' => 'A' ,'help' => 'newgroup : add a users group'}, - 'deluser' => {'rtne' => \&sruser, 'seq' => 80, 'auth' => 'A' ,'help' => 'deluser : delete a user'}, - 'delgroup' => {'rtne' => \&srgroup, 'seq' => 85, 'auth' => 'A' ,'help' => 'delgroup : delete a users group'}, - 'grant' => {'rtne' => \&siauth, 'seq' => 90, 'auth' => 'A' ,'help' => 'grant auth : grant access in auth table'}, - 'auth' => {'rtne' => \&duauth, 'seq' => 100, 'auth' => 'A' ,'help' => 'auth login : dump login authorizations'}, - '%NODES' => {'rtne' => \&dnodesc, 'seq' => 110, 'auth' => 'R' ,'help' => '%NODES [key] : dump %NODES key or all'}, - 'proc' => {'rtne' => \&dproc, 'seq' => 120, 'auth' => 'R' ,'help' => 'proc [proc] : dump PROC proc or all'}, - 'form' => {'rtne' => \&dform, 'seq' => 125, 'auth' => 'R' ,'help' => 'form [form] : dump FORM form or all'}, - 'view' => {'rtne' => \&dview, 'seq' => 130, 'auth' => 'R' ,'help' => 'view [view] : dump VIEW view or all'}, - 'node' => {'rtne' => \&dstatn, 'seq' => 140, 'auth' => 'R' ,'help' => 'node [node] : dump NODE node or list node names'}, - 'newnode' => {'rtne' => \&dnnode, 'seq' => 145, 'auth' => 'R' ,'help' => 'newnode node as other : define a new node as othernode'}, - 'delnode' => {'rtne' => \&drmnode, 'seq' => 146, 'auth' => 'R' ,'help' => 'delnode node : delete a node'}, - 'nodegrids' => {'rtne' => \&dstatg, 'seq' => 150, 'auth' => 'R' ,'help' => 'nodegrids [node] : list grids referencing node'}, - 'nodedev' => {'rtne' => \&ddev, 'seq' => 155, 'auth' => 'A' ,'help' => 'nodedev [node] : list features+devices for node (or all dev)' }, - 'statnodes' => {'rtne' => \&statnodes,'seq' => 157, 'auth' => 'R' ,'help' => 'statnodes : statistics on node+grids' }, - 'readcfg' => {'rtne' => \&rc, 'seq' => 190, 'auth' => 'R' ,'help' => 'readcfg file : readCfg file' }, - 'dbjobs' => {'rtne' => \&dbjobs, 'seq' => 195, 'auth' => 'A' ,'help' => 'dbjobs : list all jobs definitions' }, - 'newjob' => {'rtne' => \&sijob, 'seq' => 196, 'auth' => 'A' ,'help' => 'newjob : add a job definition' }, - 'dbruns' => {'rtne' => \&dbruns, 'seq' => 200, 'auth' => 'A' ,'help' => 'dbruns : list all jobs last run info' }, - 'sys' => {'rtne' => \&sys, 'seq' => 300, 'auth' => 'R' ,'help' => 'sys : print system information' }, + ( + '%WEBOBS' => {'rtne' => \&dwebobs, 'seq' => 10, 'auth' => 'R' ,'help' => '%WEBOBS [key] : dump %WEBOBS key or all'}, + '-%WEBOBS' => {'rtne' => \&rwebobs, 'seq' => 20, 'auth' => 'R' ,'help' => '-%WEBOBS value : which %WEBOBS key(s) holds value'}, + '%OWNERS' => {'rtne' => \&downers, 'seq' => 30, 'auth' => 'R' ,'help' => '%OWNERS : dump all %OWNRS'}, + '%DISCP' => {'rtne' => \&ddiscp, 'seq' => 40, 'auth' => 'R' ,'help' => '%DISCP [discp] : dump %DISCP discp discipline or all'}, + '%USERS' => {'rtne' => \&dusers, 'seq' => 50, 'auth' => 'A' ,'help' => '%USERS [login] : dump %USERS login or all'}, + 'authres' => {'rtne' => \&authres, 'seq' => 55, 'auth' => 'A' ,'help' => 'authres : list all \'named\' auth resources'}, + 'user' => {'rtne' => \&dbuser, 'seq' => 60, 'auth' => 'A' ,'help' => 'user login : query DB USERS for login'}, + 'newuser' => {'rtne' => \&siuser, 'seq' => 70, 'auth' => 'A' ,'help' => 'newuser : add a user'}, + 'newgroup' => {'rtne' => \&sigroup, 'seq' => 75, 'auth' => 'A' ,'help' => 'newgroup : add a users group'}, + 'deluser' => {'rtne' => \&sruser, 'seq' => 80, 'auth' => 'A' ,'help' => 'deluser : delete a user'}, + 'delgroup' => {'rtne' => \&srgroup, 'seq' => 85, 'auth' => 'A' ,'help' => 'delgroup : delete a users group'}, + 'grant' => {'rtne' => \&siauth, 'seq' => 90, 'auth' => 'A' ,'help' => 'grant auth : grant access in auth table'}, + 'auth' => {'rtne' => \&duauth, 'seq' => 100, 'auth' => 'A' ,'help' => 'auth login : dump login authorizations'}, + '%NODES' => {'rtne' => \&dnodesc, 'seq' => 110, 'auth' => 'R' ,'help' => '%NODES [key] : dump %NODES key or all'}, + 'proc' => {'rtne' => \&dproc, 'seq' => 120, 'auth' => 'R' ,'help' => 'proc [proc] : dump PROC proc or all'}, + 'form' => {'rtne' => \&dform, 'seq' => 125, 'auth' => 'R' ,'help' => 'form [form] : dump FORM form or all'}, + 'view' => {'rtne' => \&dview, 'seq' => 130, 'auth' => 'R' ,'help' => 'view [view] : dump VIEW view or all'}, + 'node' => {'rtne' => \&dstatn, 'seq' => 140, 'auth' => 'R' ,'help' => 'node [node] : dump NODE node or list node names'}, + 'newnode' => {'rtne' => \&dnnode, 'seq' => 145, 'auth' => 'R' ,'help' => 'newnode node as other : define a new node as othernode'}, + 'delnode' => {'rtne' => \&drmnode, 'seq' => 146, 'auth' => 'R' ,'help' => 'delnode node : delete a node'}, + 'nodegrids' => {'rtne' => \&dstatg, 'seq' => 150, 'auth' => 'R' ,'help' => 'nodegrids [node] : list grids referencing node'}, + 'nodedev' => {'rtne' => \&ddev, 'seq' => 155, 'auth' => 'A' ,'help' => 'nodedev [node] : list features+devices for node (or all dev)' }, + 'statnodes' => {'rtne' => \&statnodes,'seq' => 157, 'auth' => 'R' ,'help' => 'statnodes : statistics on node+grids' }, + 'readcfg' => {'rtne' => \&rc, 'seq' => 190, 'auth' => 'R' ,'help' => 'readcfg file : readCfg file' }, + 'dbjobs' => {'rtne' => \&dbjobs, 'seq' => 195, 'auth' => 'A' ,'help' => 'dbjobs : list all jobs definitions' }, + 'newjob' => {'rtne' => \&sijob, 'seq' => 196, 'auth' => 'A' ,'help' => 'newjob : add a job definition' }, + 'dbruns' => {'rtne' => \&dbruns, 'seq' => 200, 'auth' => 'A' ,'help' => 'dbruns : list all jobs last run info' }, + 'sys' => {'rtne' => \&sys, 'seq' => 300, 'auth' => 'R' ,'help' => 'sys : print system information' }, + # '!' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '! cmd : exec shell cmd (WebObs vars single-quoted for interpolation)' }, # '=' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '= expr : exec perl expr (interactive mode only)' }, - 'dd' => {'rtne' => \&dd, 'seq' => 320, 'auth' => 'A' ,'help' => 'dd : keys of main hashes and their occurence' }, - 'ddxref' => {'rtne' => \&ddx, 'seq' => 321, 'auth' => 'A' ,'help' => 'ddxref : keys of main hashes + their occurence + xref' }, - 'help' => {'rtne' => \&dhelp, 'seq' => 400, 'auth' => 'R' ,'help' => 'help : this help text !' }, - 'quit' => {'rtne' => \&bye, 'seq' => 410, 'auth' => 'R' ,'help' => 'quit : make a guess !' }, - ); + 'dd' => {'rtne' => \&dd, 'seq' => 320, 'auth' => 'A' ,'help' => 'dd : keys of main hashes and their occurence' }, + 'ddxref' => {'rtne' => \&ddx, 'seq' => 321, 'auth' => 'A' ,'help' => 'ddxref : keys of main hashes + their occurence + xref' }, + 'help' => {'rtne' => \&dhelp, 'seq' => 400, 'auth' => 'R' ,'help' => 'help : this help text !' }, + 'quit' => {'rtne' => \&bye, 'seq' => 410, 'auth' => 'R' ,'help' => 'quit : make a guess !' }, + ); # Get system/environment information ------------------------------------------- # ------------------------------------------------------------------------------ @@ -102,47 +103,47 @@ =head1 DESCRIPTION our $localeNum = setlocale(LC_NUMERIC); our @i18nSup = qx(ls $WEBOBS{ROOT_I18N}/locales); chomp(@i18nSup); our $WOCSYS = qx(uname -osrv); - $WOCSYS .= "\"WebObs-$WEBOBS{WEBOBS_ID}\" $WEBOBS{VERSION} [$WOLNK]\n"; - $WOCSYS .= "woc pid $$ started $^T by $WOCusr[0] ($) in ".qx(pwd)."\n"; - $WOCSYS .= "Perl \$^V = $^V \n"; - $WOCSYS .= "\$ENV{PATH} = $ENV{PATH}\n"; - $WOCSYS .= "\@INC : ".join(":",@INC)."\n"; - $WOCSYS .= "\$POSIX::VERSION = ".qq($POSIX::VERSION)."\n"; - $WOCSYS .= "POSIX::tzname = ".join(' ',POSIX::tzname())."\n"; - $WOCSYS .= "\$ENV{TZ} " . (defined($ENV{TZ}) ? "= $ENV{TZ}\n" : "undefined\n"); - $WOCSYS .= "/etc/localtime -> ".qx(tail -1 /etc/localtime); my $tnow = time; - $WOCSYS .= "local now: ".strftime("%Y-%m-%d %H:%M:%S %Z (%z) %s ",localtime($tnow))."($tnow)\n"; - $WOCSYS .= "UTC now: ".strftime("%Y-%m-%d %H:%M:%S %s ",gmtime($tnow))."\n"; - $WOCSYS .= "Environment LC_ALL:$ENV{LC_ALL}, LANGUAGE:$ENV{LANGUAGE}, LC_NUMERIC:$ENV{LC_NUMERIC}, LANG:$ENV{LANG}\n"; - $WOCSYS .= "Perl setlocale LC_ALL:$localeAll"; $WOCSYS .= ", LC_NUMERIC:$localeNum" unless ( $localeAll =~ /\QLC_NUMERIC/); $WOCSYS .= "\n"; - $WOCSYS .= "i18n Available/Installed: "; map {$WOCSYS .= (grep /\Q$_/ , @localeIns) ? "$_ = S/I; " : "$_ = S/?; "} @i18nSup ; $WOCSYS .= "\n"; - $WOCSYS .= sprintf("UMASK %03o\n",umask); - if (defined $ENV{GATEWAY_INTERFACE}) { - $WOCSYS .= "$ENV{REQUEST_URI}\n"; - $WOCSYS .= "HTTP Server = $ENV{SERVER_NAME} [$ENV{SERVER_ADDR}:$ENV{SERVER_PORT}]\n"; - $WOCSYS .= " CGI = $ENV{GATEWAY_INTERFACE}\n"; - $WOCSYS .= " $ENV{SERVER_PROTOCOL} - $ENV{SERVER_SOFTWARE}\n"; - $WOCSYS .= "HTTP User = $ENV{REMOTE_USER} - $ENV{REMOTE_HOST} [$ENV{REMOTE_ADDR}:$ENV{REMOTE_PORT}]\n"; - $WOCSYS .= " AuthType = $ENV{AUTH_TYPE}\n"; - $WOCSYS .= " UserAgent = $ENV{HTTP_USER_AGENT}\n"; - $WOCSYS .= "WEBOBS User = $CLIENT"; - } +$WOCSYS .= "\"WebObs-$WEBOBS{WEBOBS_ID}\" $WEBOBS{VERSION} [$WOLNK]\n"; +$WOCSYS .= "woc pid $$ started $^T by $WOCusr[0] ($) in ".qx(pwd)."\n"; +$WOCSYS .= "Perl \$^V = $^V \n"; +$WOCSYS .= "\$ENV{PATH} = $ENV{PATH}\n"; +$WOCSYS .= "\@INC : ".join(":",@INC)."\n"; +$WOCSYS .= "\$POSIX::VERSION = ".qq($POSIX::VERSION)."\n"; +$WOCSYS .= "POSIX::tzname = ".join(' ',POSIX::tzname())."\n"; +$WOCSYS .= "\$ENV{TZ} " . (defined($ENV{TZ}) ? "= $ENV{TZ}\n" : "undefined\n"); +$WOCSYS .= "/etc/localtime -> ".qx(tail -1 /etc/localtime); my $tnow = time; +$WOCSYS .= "local now: ".strftime("%Y-%m-%d %H:%M:%S %Z (%z) %s ",localtime($tnow))."($tnow)\n"; +$WOCSYS .= "UTC now: ".strftime("%Y-%m-%d %H:%M:%S %s ",gmtime($tnow))."\n"; +$WOCSYS .= "Environment LC_ALL:$ENV{LC_ALL}, LANGUAGE:$ENV{LANGUAGE}, LC_NUMERIC:$ENV{LC_NUMERIC}, LANG:$ENV{LANG}\n"; +$WOCSYS .= "Perl setlocale LC_ALL:$localeAll"; $WOCSYS .= ", LC_NUMERIC:$localeNum" unless ( $localeAll =~ /\QLC_NUMERIC/); $WOCSYS .= "\n"; +$WOCSYS .= "i18n Available/Installed: "; map {$WOCSYS .= (grep /\Q$_/ , @localeIns) ? "$_ = S/I; " : "$_ = S/?; "} @i18nSup ; $WOCSYS .= "\n"; +$WOCSYS .= sprintf("UMASK %03o\n",umask); +if (defined $ENV{GATEWAY_INTERFACE}) { + $WOCSYS .= "$ENV{REQUEST_URI}\n"; + $WOCSYS .= "HTTP Server = $ENV{SERVER_NAME} [$ENV{SERVER_ADDR}:$ENV{SERVER_PORT}]\n"; + $WOCSYS .= " CGI = $ENV{GATEWAY_INTERFACE}\n"; + $WOCSYS .= " $ENV{SERVER_PROTOCOL} - $ENV{SERVER_SOFTWARE}\n"; + $WOCSYS .= "HTTP User = $ENV{REMOTE_USER} - $ENV{REMOTE_HOST} [$ENV{REMOTE_ADDR}:$ENV{REMOTE_PORT}]\n"; + $WOCSYS .= " AuthType = $ENV{AUTH_TYPE}\n"; + $WOCSYS .= " UserAgent = $ENV{HTTP_USER_AGENT}\n"; + $WOCSYS .= "WEBOBS User = $CLIENT"; +} # WOC batch mode if arguments on command line ---------------------------------- # interpret/execute these args as a single woc command and quit # ------------------------------------------------------------------------------ #our @opt = @ARGV; -chomp(@ARGV); +chomp(@ARGV); our @opt = $#ARGV ? @ARGV : split(' ',$ARGV[0]); if (@opt) { - $mode = 'batch'; - ($op,@obj) = @opt; - exit if ($op eq '='); # ignore this one !! - if ( defined($vectors{$op}) ) { - eval { &{$vectors{$op}{rtne}} (@obj) }; - warn() if $@; - } - exit; + $mode = 'batch'; + ($op,@obj) = @opt; + exit if ($op eq '='); # ignore this one !! + if ( defined($vectors{$op}) ) { + eval { &{$vectors{$op}{rtne}} (@obj) }; + warn() if $@; + } + exit; } # WOC interactive mode system setups ------------------------------------------- @@ -154,29 +155,31 @@ =head1 DESCRIPTION our $WOCtmpprefx = glob("~/tmpwoc"); our $WOCwd = qx(pwd); chomp($WOCwd); our $term = new Term::ReadLine 'WebObs Console'; + #our $prompt = "\x1b[38;5;24m "; our $prompt = " "; our $OUT = $term->OUT || \*STDOUT; my $attribs = $term->Attribs; $attribs->{completion_function} = sub { - my ($text, $line, $start) = @_; - my @from = keys(%vectors); - if ($line =~ /^w /) {@from = keys(%WebObs::Config::WEBOBS)} - if ($line =~ /^d /) {@from = keys(%WebObs::Grids::DISCP)} - if ($line =~ /^u /) {@from = keys(%WebObs::Users::USERS)} - return grep(/^$text/, @from); -}; + my ($text, $line, $start) = @_; + my @from = keys(%vectors); + if ($line =~ /^w /) {@from = keys(%WebObs::Config::WEBOBS)} + if ($line =~ /^d /) {@from = keys(%WebObs::Grids::DISCP)} + if ($line =~ /^u /) {@from = keys(%WebObs::Users::USERS)} + return grep(/^$text/, @from); + }; # Signal Handlers -------------------------------------------------------------- # ------------------------------------------------------------------------------ sub hINT { print("Use q at prompt to quit!\n"); - return; + return; } sub hWARN { - my($signal) = @_; - $signal =~ s/\.\.\.caught at.*//g; + my($signal) = @_; + $signal =~ s/\.\.\.caught at.*//g; + #print("\x1b[38;5;88mWOC caught $signal"); print("*** WOC caught $signal"); } @@ -184,11 +187,11 @@ sub hWARN { # yes/no from user ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub yesno { - my $a = ""; - while ($a !~ m/[YN]$/) { - $a = $term->readline("Y/N ? "); - } - return $a; + my $a = ""; + while ($a !~ m/[YN]$/) { + $a = $term->readline("Y/N ? "); + } + return $a; } # ------------------------------------------------------------------------------ @@ -197,697 +200,710 @@ sub yesno { print "\033[2J\033[0;0H"; #clear the screen & jump to 0,0 print "WOC version 1.6, D.Lafon Apr2013\n"; print "At WOC prompt: command , 'help', or 'quit' \n\n"; + #print "\n$WOCSYS\n"; while ( defined ($cmd = $term->readline($prompt)) ) { - chomp($cmd); - $cmd =~ s/(\s)+/ /g; - $cmd =~ s/^[\s]+//g; - ($op,@obj) = split(' ',$cmd); - if (defined($vectors{$op}) ) { - if ($op eq '=') { # ignore vector for this one ! - my $obj = join(' ',@obj); - print "== $obj\n"; - $obj .= ";print '\n'"; # to flush expr output if any - eval $obj; - } - else { - eval { &{$vectors{$op}{rtne}} (@obj) }; - warn() if $@; - $term->addhistory($cmd) if /\S/; - } - } + chomp($cmd); + $cmd =~ s/(\s)+/ /g; + $cmd =~ s/^[\s]+//g; + ($op,@obj) = split(' ',$cmd); + if (defined($vectors{$op}) ) { + if ($op eq '=') { # ignore vector for this one ! + my $obj = join(' ',@obj); + print "== $obj\n"; + $obj .= ";print '\n'"; # to flush expr output if any + eval $obj; + } + else { + eval { &{$vectors{$op}{rtne}} (@obj) }; + warn() if $@; + $term->addhistory($cmd) if /\S/; + } + } } -# End Read-Evaluate-Process Woc Command ---------------------------------------- +# End Read-Evaluate-Process Woc Command ---------------------------------------- # ------------------------------------------------------------------------------ # help command : print from vectors # ------------------------------------------------------------------------------ sub dhelp { - for ( sort {$vectors{$a}->{seq} <=> $vectors{$b}->{seq}} keys %vectors ) { - my $l = $vectors{$_}; - printf( "%s\n", $l->{help} ); - } - print "\n"; + for ( sort {$vectors{$a}->{seq} <=> $vectors{$b}->{seq}} keys %vectors ) { + my $l = $vectors{$_}; + printf( "%s\n", $l->{help} ); + } + print "\n"; } # ------------------------------------------------------------------------------ # system information command: dump system string # ------------------------------------------------------------------------------ sub sys { - print "\n$WOCSYS\n"; + print "\n$WOCSYS\n"; } # ------------------------------------------------------------------------------ # WOC Out Of Date (ie. conf file changes occurred): I can restart myself # ------------------------------------------------------------------------------ sub ood { - if ( $mode eq 'interactive' ) { - print "WOC now out of date, Y to restart\n"; - if (yesno() == 'Y') { - exec( $^X, $WOCmyname, @WOCmyargs); - } - print "\n"; - } + if ( $mode eq 'interactive' ) { + print "WOC now out of date, Y to restart\n"; + if (yesno() == 'Y') { + exec( $^X, $WOCmyname, @WOCmyargs); + } + print "\n"; + } } # ------------------------------------------------------------------------------ # get out of here # ------------------------------------------------------------------------------ sub bye { - print "Bye.\n\n" ; - exit(0); + print "Bye.\n\n" ; + exit(0); } # ------------------------------------------------------------------------------ # execute a system command, with hash variable double-interpolation # ------------------------------------------------------------------------------ sub xsys { - my @obj = @_; - my $obj = join(' ',@obj); - $obj = eval qq!"$obj"!; - print "!= $obj\n"; - system($obj); - printf ("!rc= 0x%.2X\n",$?); + my @obj = @_; + my $obj = join(' ',@obj); + $obj = eval qq!"$obj"!; + print "!= $obj\n"; + system($obj); + printf ("!rc= 0x%.2X\n",$?); } # ------------------------------------------------------------------------------ # dump WEBOBS global ---------------------------------------------------------- # ------------------------------------------------------------------------------ sub dwebobs { - if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, (sort (keys(%WebObs::Config::WEBOBS)))) } - else {@L = (sort (keys(%WebObs::Config::WEBOBS))) } - for (@L) { print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" } - print "\n"; + if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, (sort (keys(%WebObs::Config::WEBOBS)))) } + else {@L = (sort (keys(%WebObs::Config::WEBOBS))) } + for (@L) { print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" } + print "\n"; } # ------------------------------------------------------------------------------ # 'reverse' dump WEBOBS global : which key holds a value ---------------------- # ------------------------------------------------------------------------------ -sub rwebobs { - if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} - my $re = $_[0]; - for (keys(%WebObs::Config::WEBOBS)) { - if ($WebObs::Config::WEBOBS{$_} =~ /$re/) { - print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" ; - } - } - print "\n"; +sub rwebobs { + if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} + my $re = $_[0]; + for (keys(%WebObs::Config::WEBOBS)) { + if ($WebObs::Config::WEBOBS{$_} =~ /$re/) { + print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" ; + } + } + print "\n"; } # ------------------------------------------------------------------------------ # raw dump of the hash generated by readCfg on a file ------------------------- # ------------------------------------------------------------------------------ sub rc { - no strict; - $_[0] =~ s/[\$](.*)[\{](.*?)[\}]/$$1{$2}/g; - use strict; - # try to figure out whether hash or array can be read - if (-e $_[0]) { - print "$_[0]\n"; - my @tag=qx(grep -P '^=key' $_[0]); - if ($tag[0]) { - my %F = readCfg($_[0]); - print Dumper(\%F) if (%F); - } else { - my @F = readCfg($_[0]); - print Dumper(\@F) if (@F); - } - } - print "\n"; + no strict; + $_[0] =~ s/[\$](.*)[\{](.*?)[\}]/$$1{$2}/g; + use strict; + + # try to figure out whether hash or array can be read + if (-e $_[0]) { + print "$_[0]\n"; + my @tag=qx(grep -P '^=key' $_[0]); + if ($tag[0]) { + my %F = readCfg($_[0]); + print Dumper(\%F) if (%F); + } else { + my @F = readCfg($_[0]); + print Dumper(\@F) if (@F); + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump %USERS global ---------------------------------------------------------- # ------------------------------------------------------------------------------ -sub dusers { - if (defined($WebObs::Users::USERS_LFN)) {print "[[ \%USERS $WebObs::Users::USERS_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Users::USERS))} - else {@L = keys(%WebObs::Users::USERS)} - for $l (@L) { - print "\$USERS\{$l\} => $WebObs::Users::USERS{$l}\n" ; - for ( keys(%{$WebObs::Users::USERS{$l}}) ) { - print " $_ ==> $WebObs::Users::USERS{$l}{$_}\n"; - } - } - print "\n" +sub dusers { + if (defined($WebObs::Users::USERS_LFN)) {print "[[ \%USERS $WebObs::Users::USERS_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Users::USERS))} + else {@L = keys(%WebObs::Users::USERS)} + for $l (@L) { + print "\$USERS\{$l\} => $WebObs::Users::USERS{$l}\n" ; + for ( keys(%{$WebObs::Users::USERS{$l}}) ) { + print " $_ ==> $WebObs::Users::USERS{$l}{$_}\n"; + } + } + print "\n" } # ------------------------------------------------------------------------------ # list a user's authorizations ------------------------------------------------ # ------------------------------------------------------------------------------ sub duauth { - if (defined($_[0])) { - my %A = WebObs::Users::userListAuth($_[0]); - for (keys(%A)) { print "$_ =>\n"; for ($A{$_}) { for (@$_) {print " @$_\n" } } }; - #print Dumper \%A; - } + if (defined($_[0])) { + my %A = WebObs::Users::userListAuth($_[0]); + for (keys(%A)) { print "$_ =>\n"; for ($A{$_}) { for (@$_) {print " @$_\n" } } }; + + #print Dumper \%A; + } } # ------------------------------------------------------------------------------ # dump %OWNRS global ---------------------------------------------------------- # ------------------------------------------------------------------------------ -sub downers { - if (defined($WebObs::Grids::OWNRS_LFN)) {print "[[ \%OWNRS $WebObs::Grids::OWNRS_LFN ]]\n"} - for (keys(%WebObs::Grids::OWNRS)) { print "\$OWNRS\{$_\} => $WebObs::Grids::OWNRS{$_}\n" } - print "\n"; +sub downers { + if (defined($WebObs::Grids::OWNRS_LFN)) {print "[[ \%OWNRS $WebObs::Grids::OWNRS_LFN ]]\n"} + for (keys(%WebObs::Grids::OWNRS)) { print "\$OWNRS\{$_\} => $WebObs::Grids::OWNRS{$_}\n" } + print "\n"; } # ------------------------------------------------------------------------------ # dump %DISCP global ---------------------------------------------------------- # ------------------------------------------------------------------------------ -sub ddiscp { - if (defined($WebObs::Grids::DISCP_LFN)) {print "[[ \%DISCP $WebObs::Grids::DISCP_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::DISCP))} - else {@L = keys(%WebObs::Grids::DISCP)} - for $l (@L) { - print "\$DISCP\{$l\} => $WebObs::Grids::DISCP{$l}\n" ; - for ( keys(%{$WebObs::Grids::DISCP{$l}})) { - print " $_ ==> $WebObs::Grids::DISCP{$l}{$_}\n"; - } - } - print "\n"; +sub ddiscp { + if (defined($WebObs::Grids::DISCP_LFN)) {print "[[ \%DISCP $WebObs::Grids::DISCP_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::DISCP))} + else {@L = keys(%WebObs::Grids::DISCP)} + for $l (@L) { + print "\$DISCP\{$l\} => $WebObs::Grids::DISCP{$l}\n" ; + for ( keys(%{$WebObs::Grids::DISCP{$l}})) { + print " $_ ==> $WebObs::Grids::DISCP{$l}{$_}\n"; + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump a PROC grid ------------------------------------------------------------ # ------------------------------------------------------------------------------ sub dproc { - my $net; - if (!defined($_[0])) { - my @net = WebObs::Grids::listProcNames(); - for (@net) { print "$_\n" } - } - else { - my %net = WebObs::Grids::readProc($_[0]); - for $l (keys(%net)) { - print "$l\n" ; - for ( keys(%{$net{$l}}) ) { - if (($_ eq 'NODESLIST')) { - my $addr = $net{$l}{$_}; my @w = @$addr; - print " $_ ==>\n"; - for (my $i=0;$i<$#w;$i+=3) { - print " $w[$i] $w[$i+1] $w[$i+2]\n"; - } - } else { - print " $_ ==> $net{$l}{$_}\n"; - } - } - } - } - print "\n"; + my $net; + if (!defined($_[0])) { + my @net = WebObs::Grids::listProcNames(); + for (@net) { print "$_\n" } + } + else { + my %net = WebObs::Grids::readProc($_[0]); + for $l (keys(%net)) { + print "$l\n" ; + for ( keys(%{$net{$l}}) ) { + if (($_ eq 'NODESLIST')) { + my $addr = $net{$l}{$_}; my @w = @$addr; + print " $_ ==>\n"; + for (my $i=0;$i<$#w;$i+=3) { + print " $w[$i] $w[$i+1] $w[$i+2]\n"; + } + } else { + print " $_ ==> $net{$l}{$_}\n"; + } + } + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump a FORM ----------------------------------------------------------------- # ------------------------------------------------------------------------------ sub dform { - if (!defined($_[0])) { - my @lf = qx(ls $WEBOBS{PATH_FORMS}); - chomp(@lf); - for (@lf) { print "$_\n" } - } - else { - my $F = new WebObs::Form($_[0]); - print $F->dump; - } - print "\n"; + if (!defined($_[0])) { + my @lf = qx(ls $WEBOBS{PATH_FORMS}); + chomp(@lf); + for (@lf) { print "$_\n" } + } + else { + my $F = new WebObs::Form($_[0]); + print $F->dump; + } + print "\n"; } # ------------------------------------------------------------------------------ # dump a VIEW grid ------------------------------------------------------------ # ------------------------------------------------------------------------------ sub dview { - my $net; - if (!defined($_[0])) { - my @net = WebObs::Grids::listViewNames(); - for (@net) { print "$_\n" } - } - else { - my %net = WebObs::Grids::readView($_[0]); - for $l (keys(%net)) { - print "$l\n" ; - for ( keys(%{$net{$l}}) ) { - if ($_ eq 'NODESLIST') { - my $addr = $net{$l}{$_}; my @w = @$addr; - print " $_ ==>\n"; - for (my $i=0;$i<$#w;$i+=3) { - print " $w[$i] $w[$i+1] $w[$i+2]\n"; - } - } else { - print " $_ ==> $net{$l}{$_}\n"; - } - } - } - } - print "\n"; + my $net; + if (!defined($_[0])) { + my @net = WebObs::Grids::listViewNames(); + for (@net) { print "$_\n" } + } + else { + my %net = WebObs::Grids::readView($_[0]); + for $l (keys(%net)) { + print "$l\n" ; + for ( keys(%{$net{$l}}) ) { + if ($_ eq 'NODESLIST') { + my $addr = $net{$l}{$_}; my @w = @$addr; + print " $_ ==>\n"; + for (my $i=0;$i<$#w;$i+=3) { + print " $w[$i] $w[$i+1] $w[$i+2]\n"; + } + } else { + print " $_ ==> $net{$l}{$_}\n"; + } + } + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump NODES configuration ------------------------------------------------ # ------------------------------------------------------------------------------ sub dnodesc { - if (defined($WebObs::Grids::NODES_LFN)) {print "[[ \%NODES $WebObs::Grids::NODES_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::NODES))} - else {@L = keys(%WebObs::Grids::NODES)} - for (@L) { print "\$NODES\{$_\} => $WebObs::Grids::NODES{$_}\n" } - print "\n"; + if (defined($WebObs::Grids::NODES_LFN)) {print "[[ \%NODES $WebObs::Grids::NODES_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::NODES))} + else {@L = keys(%WebObs::Grids::NODES)} + for (@L) { print "\$NODES\{$_\} => $WebObs::Grids::NODES{$_}\n" } + print "\n"; } # ------------------------------------------------------------------------------ # dump a NODE ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub dstatn { - my $nodes; - if (!defined($_[0])) { - my @nodes = WebObs::Grids::listNodeNames(); - for (my $i=0; $i $node{$l}{$_}\n"; - } - } - } - print "\n"; + my $nodes; + if (!defined($_[0])) { + my @nodes = WebObs::Grids::listNodeNames(); + for (my $i=0; $i $node{$l}{$_}\n"; + } + } + } + print "\n"; } # ------------------------------------------------------------------------------ # list grids for node(s) --------------------------------------------------- # ------------------------------------------------------------------------------ sub dstatg { - my %s = WebObs::Grids::listNodeGrids(node=>$_[0]); - for (keys(%s)) { - print "$_ :\n"; - if (scalar(@{$s{$_}}) == 0) { print " not in any grid\n"} - else { - for (@{$s{$_}}) { print " $_\n" } - } - print "\n" - } + my %s = WebObs::Grids::listNodeGrids(node=>$_[0]); + for (keys(%s)) { + print "$_ :\n"; + if (scalar(@{$s{$_}}) == 0) { print " not in any grid\n"} + else { + for (@{$s{$_}}) { print " $_\n" } + } + print "\n" + } } # ------------------------------------------------------------------------------ # list all authorization 'named' resources ---------------------------------- # ------------------------------------------------------------------------------ sub authres { - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHPROCS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHPROCS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHVIEWS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHVIEWS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHFORMS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHFORMS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHWIKIS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHWIKIS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHMISC} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHMISC} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - - print "\n"; + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHPROCS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHPROCS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHVIEWS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHVIEWS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHFORMS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHFORMS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHWIKIS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHWIKIS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHMISC} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHMISC} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + + print "\n"; } # ------------------------------------------------------------------------------ # user info from sql ---------------------------------------------------------- # ------------------------------------------------------------------------------ sub dbuser { - my $u = $_[0] ? $_[0] : ''; - if ($u ne '' && defined($USERS{$u}{LOGIN})) { - my $v = $USERS{$u}{UID}; - my @q = qx(sqlite3 -list -separator ',' $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_USERS} where login = '$u' order by login"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - print "\n$WEBOBS{SQL_TABLE_AUTHPROCS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHPROCS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHVIEWS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHVIEWS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHFORMS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHFORMS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHWIKIS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHWIKIS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHMISC}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHMISC} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_GROUPS} :"; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_GROUPS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_NOTIFICATIONS} :"; - my @q = qx(sqlite3 -list $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_NOTIFICATIONS} where mailid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - } else { - my @q = qx(sqlite3 -column -header $WEBOBS{SQL_DB_USERS} "select LOGIN, UID from $WEBOBS{SQL_TABLE_USERS}"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - } + my $u = $_[0] ? $_[0] : ''; + if ($u ne '' && defined($USERS{$u}{LOGIN})) { + my $v = $USERS{$u}{UID}; + my @q = qx(sqlite3 -list -separator ',' $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_USERS} where login = '$u' order by login"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + print "\n$WEBOBS{SQL_TABLE_AUTHPROCS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHPROCS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHVIEWS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHVIEWS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHFORMS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHFORMS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHWIKIS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHWIKIS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHMISC}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHMISC} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_GROUPS} :"; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_GROUPS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_NOTIFICATIONS} :"; + my @q = qx(sqlite3 -list $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_NOTIFICATIONS} where mailid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + } else { + my @q = qx(sqlite3 -column -header $WEBOBS{SQL_DB_USERS} "select LOGIN, UID from $WEBOBS{SQL_TABLE_USERS}"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + } } # ------------------------------------------------------------------------------ # insert new user ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub siuser { - return if ( $mode eq 'batch' && $_[0] eq "" ) ; - dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_USERS},$_[0]); + return if ( $mode eq 'batch' && $_[0] eq "" ) ; + dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_USERS},$_[0]); } # ------------------------------------------------------------------------------ # insert new group ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub sigroup { - return if ( $mode eq 'batch' && $_[0] eq "" ) ; - dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_GROUPS},$_[0]); + return if ( $mode eq 'batch' && $_[0] eq "" ) ; + dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_GROUPS},$_[0]); } # ------------------------------------------------------------------------------ # delete a user --------------------------------------------------------------- # ------------------------------------------------------------------------------ sub sruser { - if (defined($_[0]) && ($_[0] ne "")) { - my $q = "delete from $WEBOBS{SQL_TABLE_USERS} where login = $_[0]"; - print "= $q\n"; - if (yesno() eq 'Y') { - my @q = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "$q" 2>&1); - if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } - ood(); - } - - } + if (defined($_[0]) && ($_[0] ne "")) { + my $q = "delete from $WEBOBS{SQL_TABLE_USERS} where login = $_[0]"; + print "= $q\n"; + if (yesno() eq 'Y') { + my @q = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "$q" 2>&1); + if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } + ood(); + } + + } } # ------------------------------------------------------------------------------ # delete a group --------------------------------------------------------------- # ------------------------------------------------------------------------------ sub srgroup { - if (defined($_[0]) && ($_[0] ne "")) { - my $q = "delete from $WEBOBS{SQL_TABLE_GROUPS} where gid = $_[0]"; - print "= $q\n"; - if (yesno() eq 'Y') { - my @q = qx(sqlite3 $WEBOBS{SQL_DB_GROUPS} "$q" 2>&1); - if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } - ood(); - } - - } + if (defined($_[0]) && ($_[0] ne "")) { + my $q = "delete from $WEBOBS{SQL_TABLE_GROUPS} where gid = $_[0]"; + print "= $q\n"; + if (yesno() eq 'Y') { + my @q = qx(sqlite3 $WEBOBS{SQL_DB_GROUPS} "$q" 2>&1); + if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } + ood(); + } + + } } # ------------------------------------------------------------------------------ # insert new authorization ---------------------------------------------------- # ------------------------------------------------------------------------------ sub siauth { - my ($table, $row) = @_; - return if ( $table eq '' ); - return if ( $mode eq 'batch' && $row eq "" ) ; - dbinsert($WEBOBS{SQL_DB_USERS}, $table, $row); + my ($table, $row) = @_; + return if ( $table eq '' ); + return if ( $mode eq 'batch' && $row eq "" ) ; + dbinsert($WEBOBS{SQL_DB_USERS}, $table, $row); } # ------------------------------------------------------------------------------ # jobs definitions from db --------------------------------------------------- # ------------------------------------------------------------------------------ sub dbjobs { - if ( defined($SCHED{SQL_DB_JOBS}) ) { - my @q = qx(sqlite3 -line $SCHED{SQL_DB_JOBS} "select JID,VALIDITY,XEQ1,XEQ2,XEQ3,RUNINTERVAL,MAXSYSLOAD,LOGPATH from JOBS ORDER by JID"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - } + if ( defined($SCHED{SQL_DB_JOBS}) ) { + my @q = qx(sqlite3 -line $SCHED{SQL_DB_JOBS} "select JID,VALIDITY,XEQ1,XEQ2,XEQ3,RUNINTERVAL,MAXSYSLOAD,LOGPATH from JOBS ORDER by JID"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + } } # ------------------------------------------------------------------------------ # insert new job ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub sijob { - return if ( $mode eq 'batch' && $_[0] eq "" ) ; - dbinsert($SCHED{SQL_DB_JOBS}, "JOBS", $_[0]); + return if ( $mode eq 'batch' && $_[0] eq "" ) ; + dbinsert($SCHED{SQL_DB_JOBS}, "JOBS", $_[0]); } # ------------------------------------------------------------------------------ # jobs last run info from db ------------------------------------------------- # ------------------------------------------------------------------------------ sub dbruns { - if ( defined($SCHED{SQL_DB_JOBS}) ) { - my @q = qx(sqlite3 -column -column -header $SCHED{SQL_DB_JOBS} "select JID,datetime(STARTTS,'unixepoch') as STARTED,datetime(ENDTS,'unixepoch') as ENDED,round(ENDTS-STARTTS,3) as ELAPSED, CMD,STDPATH,RC,RCMSG from RUNS order by STARTTS,JID"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - } + if ( defined($SCHED{SQL_DB_JOBS}) ) { + my @q = qx(sqlite3 -column -column -header $SCHED{SQL_DB_JOBS} "select JID,datetime(STARTTS,'unixepoch') as STARTED,datetime(ENDTS,'unixepoch') as ENDED,round(ENDTS-STARTTS,3) as ELAPSED, CMD,STDPATH,RC,RCMSG from RUNS order by STARTTS,JID"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + } } # ------------------------------------------------------------------------------ # inspect DEVICES the way it is handled by showNODE----------------------------- # ------------------------------------------------------------------------------ sub ddev { - # legacy code to create %liste_liens_fiches : NODES links to other nodes - my @conf_liens_stations = readCfgFile("$NODES{FILE_NODES2NODES}"); - my %liste_liens_fiches; - my $station_parente_old = ""; - my $caracteristique_old = ""; - my $i = 0; - for (@conf_liens_stations) { - my ($station_parente,$caracteristique,$station_fille)=split(/\|/,$_); - if ( $station_parente."|".$caracteristique ne $station_parente_old."|".$caracteristique_old ) { - $i = 0; - } - my $nom_lien = $station_parente."|".$caracteristique; - $liste_liens_fiches{$nom_lien} .= ($i++==0?"":"|").$station_fille; - $station_parente_old = $station_parente; - $caracteristique_old = $caracteristique; - } - - if ($_[0]) { - - my $NODEName = $_[0]; - my $hits = 0; - - print "$NODEName occurences in $NODES{FILE_NODES2NODES} :\n"; - for ( sort keys(%liste_liens_fiches) ) { - my $temp = $_."==>".$liste_liens_fiches{$_}; - if ( $temp =~ m/$NODEName/g ) { print " $temp\n"; $hits++ } - } - if ($hits == 0) { print" NONE!\n"; } + + # legacy code to create %liste_liens_fiches : NODES links to other nodes + my @conf_liens_stations = readCfgFile("$NODES{FILE_NODES2NODES}"); + my %liste_liens_fiches; + my $station_parente_old = ""; + my $caracteristique_old = ""; + my $i = 0; + for (@conf_liens_stations) { + my ($station_parente,$caracteristique,$station_fille)=split(/\|/,$_); + if ( $station_parente."|".$caracteristique ne $station_parente_old."|".$caracteristique_old ) { + $i = 0; + } + my $nom_lien = $station_parente."|".$caracteristique; + $liste_liens_fiches{$nom_lien} .= ($i++==0?"":"|").$station_fille; + $station_parente_old = $station_parente; + $caracteristique_old = $caracteristique; + } + + if ($_[0]) { + + my $NODEName = $_[0]; + my $hits = 0; + + print "$NODEName occurences in $NODES{FILE_NODES2NODES} :\n"; + for ( sort keys(%liste_liens_fiches) ) { + my $temp = $_."==>".$liste_liens_fiches{$_}; + if ( $temp =~ m/$NODEName/g ) { print " $temp\n"; $hits++ } + } + if ($hits == 0) { print" NONE!\n"; } else { - $hits = 0; - # legacy showNODE code for 'parents' - print "$NODEName is a feature of other node in $NODES{FILE_NODES2NODES} :\n"; - my $liens_fiches_parentes = ""; - for my $nom_lien (keys %liste_liens_fiches) { - my @liste_fiches_filles = split(/\|/,$liste_liens_fiches{$nom_lien}); - for (@liste_fiches_filles) { - if ( $_ eq $NODEName ) { - my @data = split(/\|/,$nom_lien); - print " $data[1] of $data[0]\n"; - $hits++; - } - } - } - if ($hits == 0) { print" NONE!\n"; } - - my %NODE = readNode($NODEName); - my $editOK = 1; - # legacy showNODE code "other nodes from NODE's features" - my @listeCarFiles=split(/\|/,$NODE{$_[0]}{FILES_FEATURES}); - $hits = 0; - print "$NODEName has feature(s) in $NODEName.cnf :\n"; - for (@listeCarFiles) { print " '$_'" ; $hits++ } - if ($hits == 0) { print" NONE!"; } - print ("\n"); - - if ($hits > 0) { - my @listeFinaleCarFiles; - my $flag=0; - my %lienNode; - # for each defined features in NODEName.cnf ONLY: - for (@listeCarFiles) { - my $carFileName=$_; - my $carFile="$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; - my $nom_lien = $NODEName."|".$carFileName; - $lienNode{$carFileName} = ""; - my $lien_car = 0; - # if this feature appears in $NODES{FILE_NODES2NODES} ONLY: - # mark this feature as defined in $NODES{FILE_NODES2NODES} (lien_car = 1) - # enter all 'child' nodes definitions for this feature in %lienNode - if ( exists($liste_liens_fiches{$nom_lien}) ) { - my @liste_liens=split(/\|/,$liste_liens_fiches{$nom_lien}); - for (@liste_liens) { - if ( length($_) > 0 ) { - $lienNode{$carFileName} .= $_; - if ( getNodeString(node=>$_) eq "") { $lienNode{$carFileName} .= " (no NodeString) "} - else { $lienNode{$carFileName} .= " " } - # $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "\n").getNodeString(node=>$_); - } - } - #if ( $lienNode{$carFileName} ne "" ) { - # $lienNode{$carFileName} .= "\n\n"; - #} - $lien_car = 1; - } - printf (" %s %s $NODES{FILE_NODES2NODES} , %s\n",$carFileName,($lien_car==1)?"in ":"not in" ,(-e $carFile)?"has $carFile":"has no txt file"); - if ((-e $carFile && (-s $carFile || $editOK == 1)) || $lien_car == 1) { - push(@listeFinaleCarFiles,$carFileName); - } - print " + $lienNode{$carFileName}\n" if ($lienNode{$carFileName} ne ""); - } - printf ("%s feature(s) could show up in showNODE\n",$#listeFinaleCarFiles+1); - for (@listeFinaleCarFiles) { print " $_" } - } - } - } - print("\n"); + $hits = 0; + + # legacy showNODE code for 'parents' + print "$NODEName is a feature of other node in $NODES{FILE_NODES2NODES} :\n"; + my $liens_fiches_parentes = ""; + for my $nom_lien (keys %liste_liens_fiches) { + my @liste_fiches_filles = split(/\|/,$liste_liens_fiches{$nom_lien}); + for (@liste_fiches_filles) { + if ( $_ eq $NODEName ) { + my @data = split(/\|/,$nom_lien); + print " $data[1] of $data[0]\n"; + $hits++; + } + } + } + if ($hits == 0) { print" NONE!\n"; } + + my %NODE = readNode($NODEName); + my $editOK = 1; + + # legacy showNODE code "other nodes from NODE's features" + my @listeCarFiles=split(/\|/,$NODE{$_[0]}{FILES_FEATURES}); + $hits = 0; + print "$NODEName has feature(s) in $NODEName.cnf :\n"; + for (@listeCarFiles) { print " '$_'" ; $hits++ } + if ($hits == 0) { print" NONE!"; } + print ("\n"); + + if ($hits > 0) { + my @listeFinaleCarFiles; + my $flag=0; + my %lienNode; + + # for each defined features in NODEName.cnf ONLY: + for (@listeCarFiles) { + my $carFileName=$_; + my $carFile="$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; + my $nom_lien = $NODEName."|".$carFileName; + $lienNode{$carFileName} = ""; + my $lien_car = 0; + + # if this feature appears in $NODES{FILE_NODES2NODES} ONLY: + # mark this feature as defined in $NODES{FILE_NODES2NODES} (lien_car = 1) + # enter all 'child' nodes definitions for this feature in %lienNode + if ( exists($liste_liens_fiches{$nom_lien}) ) { + my @liste_liens=split(/\|/,$liste_liens_fiches{$nom_lien}); + for (@liste_liens) { + if ( length($_) > 0 ) { + $lienNode{$carFileName} .= $_; + if ( getNodeString(node=>$_) eq "") { $lienNode{$carFileName} .= " (no NodeString) "} + else { $lienNode{$carFileName} .= " " } + +# $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "\n").getNodeString(node=>$_); + } + } + + #if ( $lienNode{$carFileName} ne "" ) { + # $lienNode{$carFileName} .= "\n\n"; + #} + $lien_car = 1; + } + printf (" %s %s $NODES{FILE_NODES2NODES} , %s\n",$carFileName,($lien_car==1)?"in ":"not in" ,(-e $carFile)?"has $carFile":"has no txt file"); + if ((-e $carFile && (-s $carFile || $editOK == 1)) || $lien_car == 1) { + push(@listeFinaleCarFiles,$carFileName); + } + print " + $lienNode{$carFileName}\n" if ($lienNode{$carFileName} ne ""); + } + printf ("%s feature(s) could show up in showNODE\n",$#listeFinaleCarFiles+1); + for (@listeFinaleCarFiles) { print " $_" } + } + } + } + print("\n"); } # ------------------------------------------------------------------------------ # data dictionary for main hashes, + occurences ----------------------------- # ------------------------------------------------------------------------------ sub dd { - my $oldDumperSortkeys = $Data::Dumper::Sortkeys; - my $oldDumperVarname = $Data::Dumper::Varname; - $Data::Dumper::Sortkeys = 1; + my $oldDumperSortkeys = $Data::Dumper::Sortkeys; + my $oldDumperVarname = $Data::Dumper::Varname; + $Data::Dumper::Sortkeys = 1; - my ($nV, %keysView) = ddcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView, "VIEWS"); - my ($nP, %keysProc) = ddcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); - my ($nN, %keysNode) = ddcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); + my ($nV, %keysView) = ddcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView, "VIEWS"); + my ($nP, %keysProc) = ddcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); + my ($nN, %keysNode) = ddcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); - $Data::Dumper::Sortkeys = $oldDumperSortkeys; - $Data::Dumper::Varname = $oldDumperVarname; - print("\n"); + $Data::Dumper::Sortkeys = $oldDumperSortkeys; + $Data::Dumper::Varname = $oldDumperVarname; + print("\n"); } # ------------------------------------------------------------------------------ # data dictionary XREF for main hashes ------------------------ # ------------------------------------------------------------------------------ sub ddx { - - my $oldDumperSortkeys = $Data::Dumper::Sortkeys; - my $oldDumperVarname = $Data::Dumper::Varname; - $Data::Dumper::Sortkeys = 1; - - my ($nV, %keysView) = ddxcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView,"VIEWS"); - ddxrevcore(\%keysView, "views"); - - my ($nV, %keysProc) = ddxcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); - ddxrevcore(\%keysProc, "procs"); - - my ($nV, %keysNode) = ddxcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); - ddxrevcore(\%keysNode, "nodes"); - - my %keysWO; - for my $i (keys(%WEBOBS)) { - if (!exists($keysWO{$i})) { $keysWO{$i}{cgibin} = join(" ",REKCGI($i)); - $keysWO{$i}{matlab} = join(" ",REKMAT($i)); - } - } - print "\n"; - $Data::Dumper::Varname = 'WEBOBS'; - print Dumper \%keysWO; - ddxrevcore(\%keysWO, "webobs"); - -# print"\n**************************************************************\n"; -# print"* xrefs might NOT be comprehensive lists. They are built *\n"; -# print"* using naming/coding conventions & also scan comments. *\n"; -# print"* cgi: 'key' looked for in {key} or {'key'} case insensitive.*\n"; -# print"* mat: 'key' looked for in xx.key, xx 1 or 2 uppercase alpha.*\n"; -# print"**************************************************************\n"; + + my $oldDumperSortkeys = $Data::Dumper::Sortkeys; + my $oldDumperVarname = $Data::Dumper::Varname; + $Data::Dumper::Sortkeys = 1; + + my ($nV, %keysView) = ddxcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView,"VIEWS"); + ddxrevcore(\%keysView, "views"); + + my ($nV, %keysProc) = ddxcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); + ddxrevcore(\%keysProc, "procs"); + + my ($nV, %keysNode) = ddxcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); + ddxrevcore(\%keysNode, "nodes"); + + my %keysWO; + for my $i (keys(%WEBOBS)) { + if (!exists($keysWO{$i})) { $keysWO{$i}{cgibin} = join(" ",REKCGI($i)); + $keysWO{$i}{matlab} = join(" ",REKMAT($i)); + } + } + print "\n"; + $Data::Dumper::Varname = 'WEBOBS'; + print Dumper \%keysWO; + ddxrevcore(\%keysWO, "webobs"); + + # print"\n**************************************************************\n"; + # print"* xrefs might NOT be comprehensive lists. They are built *\n"; + # print"* using naming/coding conventions & also scan comments. *\n"; + # print"* cgi: 'key' looked for in {key} or {'key'} case insensitive.*\n"; + # print"* mat: 'key' looked for in xx.key, xx 1 or 2 uppercase alpha.*\n"; + # print"**************************************************************\n"; } # woc internal helpers functions for dd* commands # ----------------------------------------------- # get number of hash keys and occurences of their keys sub ddcore { - my %GKs; - my ($a1, $a2, $txt) = @_; - my @L = &$a1(); - for my $i (@L) { - my %g = &$a2($i); - for (keys(%{$g{$i}})) { - if (exists($GKs{$_})) { $GKs{$_}++ } - else { $GKs{$_} = 1 } - } - } - print "\n"; - print scalar(@L)." $txt scanned:\n"; - $Data::Dumper::Varname = $txt; - print Dumper \%GKs; - return (scalar(@L), %GKs); + my %GKs; + my ($a1, $a2, $txt) = @_; + my @L = &$a1(); + for my $i (@L) { + my %g = &$a2($i); + for (keys(%{$g{$i}})) { + if (exists($GKs{$_})) { $GKs{$_}++ } + else { $GKs{$_} = 1 } + } + } + print "\n"; + print scalar(@L)." $txt scanned:\n"; + $Data::Dumper::Varname = $txt; + print Dumper \%GKs; + return (scalar(@L), %GKs); } + # get keys occurences in cgi-bins and matlab sub ddxcore { - my %GKs; - my ($a1, $a2, $txt) = @_; - my @L = &$a1(); - for my $i (@L) { - my %g = &$a2($i); - for (keys(%{$g{$i}})) { - if (!exists($GKs{$_})) { $GKs{$_}{cgibin} = join(" ",REKCGI($_)); - $GKs{$_}{matlab} = join(" ",REKMAT($_)); - } - } - } - print "\n"; - print scalar(@L)." $txt scanned:\n"; - $Data::Dumper::Varname = $txt; - print Dumper \%GKs; - return(scalar(@L), %GKs); + my %GKs; + my ($a1, $a2, $txt) = @_; + my @L = &$a1(); + for my $i (@L) { + my %g = &$a2($i); + for (keys(%{$g{$i}})) { + if (!exists($GKs{$_})) { $GKs{$_}{cgibin} = join(" ",REKCGI($_)); + $GKs{$_}{matlab} = join(" ",REKMAT($_)); + } + } + } + print "\n"; + print scalar(@L)." $txt scanned:\n"; + $Data::Dumper::Varname = $txt; + print Dumper \%GKs; + return(scalar(@L), %GKs); } + # get keys reverse xref sub ddxrevcore{ - my $addr = $_[0]; - my %cgi; my %mat; - for my $k (keys(%$addr)) { - for (split(/ /,$$addr{$k}{cgibin})) { - if ($cgi{$_}) {$cgi{$_} .= " ".$k} - else {$cgi{$_} = $k } - } - for (split(/ /,$$addr{$k}{matlab})) { - if ($mat{$_}) {$mat{$_} .= " ".$k} - else {$mat{$_} = $k } - } - } - print "\n"; - print scalar(keys(%cgi))." cgis referencing $_[1]:\n"; - $Data::Dumper::Sortkeys = 1; - $Data::Dumper::Varname = 'CGIs'; - print Dumper \%cgi; - print "\n"; - print scalar(keys(%mat))." matlabs referencing $_[1]:\n"; - $Data::Dumper::Sortkeys = 1; - $Data::Dumper::Varname = 'MATLABs'; - print Dumper \%mat; + my $addr = $_[0]; + my %cgi; my %mat; + for my $k (keys(%$addr)) { + for (split(/ /,$$addr{$k}{cgibin})) { + if ($cgi{$_}) {$cgi{$_} .= " ".$k} + else {$cgi{$_} = $k } + } + for (split(/ /,$$addr{$k}{matlab})) { + if ($mat{$_}) {$mat{$_} .= " ".$k} + else {$mat{$_} = $k } + } + } + print "\n"; + print scalar(keys(%cgi))." cgis referencing $_[1]:\n"; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Varname = 'CGIs'; + print Dumper \%cgi; + print "\n"; + print scalar(keys(%mat))." matlabs referencing $_[1]:\n"; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Varname = 'MATLABs'; + print Dumper \%mat; } + # internal helper to find 'Key' used in CGIs (*.p{l,m}) sub REKCGI { - my $r = '"\{[\'\"]*'; - $r .= $_[0]; - $r .= '[\'\"]*\}"' ; + my $r = '"\{[\'\"]*'; + $r .= $_[0]; + $r .= '[\'\"]*\}"' ; my @qr = qx(grep -P -i -r -l $r $WEBOBS{ROOT_CODE}/cgi-bin/* | grep -v -P "affic|traite|formul|\.svn|\/leg.*\/"); - map {s/$WEBOBS{ROOT_CODE}\/cgi-bin\///} @qr; - chomp(@qr); - return @qr; + map {s/$WEBOBS{ROOT_CODE}\/cgi-bin\///} @qr; + chomp(@qr); + return @qr; } # internal helper to find 'Key' used in matlab (*.m) sub REKMAT { - my $r = '"[A-Z\(\)]{1,2}\.'; - $r .= $_[0]; - $r .= '"' ; + my $r = '"[A-Z\(\)]{1,2}\.'; + $r .= $_[0]; + $r .= '"' ; my @qr = qx(grep -P -r -l $r $WEBOBS{ROOT_CODE}/matlab/*); - map {s/$WEBOBS{ROOT_CODE}\/matlab\///} @qr; - chomp(@qr); - return @qr; + map {s/$WEBOBS{ROOT_CODE}\/matlab\///} @qr; + chomp(@qr); + return @qr; } # ------------------------------------------------------------------------------ @@ -896,113 +912,114 @@ sub REKMAT { # what we look for ... we're after some kind of integrity checking) # ------------------------------------------------------------------------------ sub statnodes { - my @nodes_dir; - my @nodes_nogrid; - my @nodes_noview; - my @nodes_noproc; - opendir(DIR, $NODES{PATH_NODES}); - while (readdir DIR) { push(@nodes_dir, $_) if (substr($_,0,1) ne '.') } - closedir DIR; - foreach (@nodes_dir) { - my %HoA = WebObs::Grids::listNodeGrids(node=>$_); - push(@nodes_nogrid,$_) and next if ( (!%HoA) || scalar(@{$HoA{$_}})==0); - #push(@nodes_noproc,$_) if (! (/^PROC.*/ ~~ @{$HoA{$_}}) ); - push(@nodes_noproc,$_) if (! grep(/^PROC.*/, @{$HoA{$_}}) ); - push(@nodes_noview,$_) if (! grep(/^VIEW.*/, @{$HoA{$_}}) ); - } - printf (" %5u node directories\n",$#nodes_dir+1); - printf (" %5u node%s no grid\n",$#nodes_nogrid+1,($#nodes_nogrid+1>1)?"s have":" has"); - for (my $i=0; $i1)?"s have":" has"); - for (my $i=0; $i1)?"s have":" has"); - for (my $i=0; $i$_); + push(@nodes_nogrid,$_) and next if ( (!%HoA) || scalar(@{$HoA{$_}})==0); + + #push(@nodes_noproc,$_) if (! (/^PROC.*/ ~~ @{$HoA{$_}}) ); + push(@nodes_noproc,$_) if (! grep(/^PROC.*/, @{$HoA{$_}}) ); + push(@nodes_noview,$_) if (! grep(/^VIEW.*/, @{$HoA{$_}}) ); + } + printf (" %5u node directories\n",$#nodes_dir+1); + printf (" %5u node%s no grid\n",$#nodes_nogrid+1,($#nodes_nogrid+1>1)?"s have":" has"); + for (my $i=0; $i1)?"s have":" has"); + for (my $i=0; $i1)?"s have":" has"); + for (my $i=0; $i/dev/null); - if ( $? == 0 ) { - qx(cp $NODES{PATH_NODES}/$_[2]/$_[2].cnf $NODES{PATH_NODES}/$nn/$nn.cnf 2>/dev/null); - if ($? ne 0) { - qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/$gt.$gn.$nn); #rollback - qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback - } else { - qx(sed -i -e 's/\(^NAME.*|\|^ALIAS.*|\|^FDSN.*|\|TRANSMISSI.*|\).*/\1/' $NODES{PATH_NODES}/$nn/$nn.cnf); - } - } else { - qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback - } - } else { - print "couldn't mkdir $NODES{PATH_NODES}/$nn\n"; - } - } - } else { - print "need a 'from node' clause\n"; - } - } - } - else { print "need gridtype.gridname.nodename1 from nodename2\n" } - } + chomp @_; + if (defined($_[0]) && ($_[0] ne "")) { + my ($gt,$gn,$nn) = split(/\.|\//,$_[0]); + if ($nn ne "") { + if (-d "$NODES{PATH_NODES}/$nn") { + print "$nn already exists\n"; + } else { + if ( $_[1] =~ m/as|from/i && defined($_[2]) && $_[2] ne "") { + if ( ! -d "$NODES{PATH_NODES}/$_[2]" ) { + print "$_[2] does not exist\n"; + } else { + qx(mkdir $NODES{PATH_NODES}/$nn ); + if ( $? == 0) { + qx (ln -s $NODES{PATH_NODES}/$nn $WEBOBS{PATH_GRIDS2NODES}/$gt.$gn.$nn 2>/dev/null); + if ( $? == 0 ) { + qx(cp $NODES{PATH_NODES}/$_[2]/$_[2].cnf $NODES{PATH_NODES}/$nn/$nn.cnf 2>/dev/null); + if ($? ne 0) { + qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/$gt.$gn.$nn); #rollback + qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback + } else { + qx(sed -i -e 's/\(^NAME.*|\|^ALIAS.*|\|^FDSN.*|\|TRANSMISSI.*|\).*/\1/' $NODES{PATH_NODES}/$nn/$nn.cnf); + } + } else { + qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback + } + } else { + print "couldn't mkdir $NODES{PATH_NODES}/$nn\n"; + } + } + } else { + print "need a 'from node' clause\n"; + } + } + } + else { print "need gridtype.gridname.nodename1 from nodename2\n" } + } } # ------------------------------------------------------------------------------ # drmnode delete a node ------------------------------------------- # ------------------------------------------------------------------------------ sub drmnode { - chomp @_; - if (defined($_[0]) && ($_[0] ne "")) { - if (-d "$NODES{PATH_NODES}/$_[0]") { - qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/*.*.$_[0]); - qx(rm -rf $NODES{PATH_NODES}/$_[0]); - } - } + chomp @_; + if (defined($_[0]) && ($_[0] ne "")) { + if (-d "$NODES{PATH_NODES}/$_[0]") { + qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/*.*.$_[0]); + qx(rm -rf $NODES{PATH_NODES}/$_[0]); + } + } } # ------------------------------------------------------------------------------ # dbinsert insert a row into a table ------------------------------------------- # ------------------------------------------------------------------------------ sub dbinsert { - my $q; - my ($db, $table, $row) = @_; - my @q = qx(sqlite3 -noheader -list -separator ',' $db "PRAGMA table_info($table)"); - chomp(@q); - my @qt = @q; - foreach (@q) { s/^.*?\,(.*?)\,.*$/$1/g } - foreach (@qt) { s/^.*?\,.*?\,(.*?)\,.*$/$1/g } - for my $i (0..$#q) {if ($qt[$i] eq 'text') {$q[$i] = "'".$q[$i]."'";}} ; - if ($row eq '') { - if ($mode eq 'interactive') { - print "enter new row as: ".join(',',@q)."\n"; - $q = $term->readline("> "); - } - } else { - $q = $row; - } - $q = "insert into $table values($q)"; - print "= $q\n"; - if ($mode eq 'interactive') { - return if (yesno() ne 'Y') - } - @q = qx(sqlite3 $db "$q" 2>&1); - if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } - ood(); + my $q; + my ($db, $table, $row) = @_; + my @q = qx(sqlite3 -noheader -list -separator ',' $db "PRAGMA table_info($table)"); + chomp(@q); + my @qt = @q; + foreach (@q) { s/^.*?\,(.*?)\,.*$/$1/g } + foreach (@qt) { s/^.*?\,.*?\,(.*?)\,.*$/$1/g } + for my $i (0..$#q) {if ($qt[$i] eq 'text') {$q[$i] = "'".$q[$i]."'";}} ; + if ($row eq '') { + if ($mode eq 'interactive') { + print "enter new row as: ".join(',',@q)."\n"; + $q = $term->readline("> "); + } + } else { + $q = $row; + } + $q = "insert into $table values($q)"; + print "= $q\n"; + if ($mode eq 'interactive') { + return if (yesno() ne 'Y') + } + @q = qx(sqlite3 $db "$q" 2>&1); + if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } + ood(); } __END__ diff --git a/CODE/perl/wsudp.pl b/CODE/perl/wsudp.pl index a2695e4a..80d3d8c9 100755 --- a/CODE/perl/wsudp.pl +++ b/CODE/perl/wsudp.pl @@ -72,9 +72,8 @@ =head1 EXIT CODES use WebObs::Scheduler qw(scheduler_client); - sub usage { - print <<"_EOD_"; + print <<"_EOD_"; Usage: perl $0 'msg=>"COMMAND"' ['option=>value' ...] Send a message to a UDP server and print its reply to stdout. @@ -111,57 +110,57 @@ sub usage { } if (not @ARGV) { - usage(); - exit(1); + usage(); + exit(1); } # Options allowed on the command line as => # and the regexp the value must match. my %opts_regexp = ( - 'msg' => '[\w ]+', - 'host' => '[\w.-]+', - 'port' => '\d+', - 'timeout' => '\d+', - 'max_length' => '\d+', -); + 'msg' => '[\w ]+', + 'host' => '[\w.-]+', + 'port' => '\d+', + 'timeout' => '\d+', + 'max_length' => '\d+', + ); # Backward compatibility aliases for options my %compat_aliases = ( - 'to' => 'timeout', - 'll' => 'max_length', -); + 'to' => 'timeout', + 'll' => 'max_length', + ); my %opts = (); # Read and parse arguments from the command line as options foreach my $arg (@ARGV) { - # Read argument as "key => value" - my ($k, $v) = $arg =~ /^\s*([a-z]+)\s*=>\s*(?:'|")?(.+?)(?:'|")?\s*$/; - - if (not $k) { - print STDERR "Error: cannot read arguments, please check their format.\n"; - usage(); - exit(1); - } - - # Apply any option name alias - if ($compat_aliases{$k}) { - $k = $compat_aliases{$k}; - } - - # Make sure option exists and its value has a valid format - if (not $opts_regexp{$k} or $v !~ /$opts_regexp{$k}/) { - print STDERR "Error: invalid argument or format '$arg'\n"; - exit(1); - } - - # Explicitely reject duplicated options - if ($opts{$k}) { - print STDERR "Error: option '$k' defined more than once\n"; - exit(1); - } - $opts{$k} = $v; + # Read argument as "key => value" + my ($k, $v) = $arg =~ /^\s*([a-z]+)\s*=>\s*(?:'|")?(.+?)(?:'|")?\s*$/; + + if (not $k) { + print STDERR "Error: cannot read arguments, please check their format.\n"; + usage(); + exit(1); + } + + # Apply any option name alias + if ($compat_aliases{$k}) { + $k = $compat_aliases{$k}; + } + + # Make sure option exists and its value has a valid format + if (not $opts_regexp{$k} or $v !~ /$opts_regexp{$k}/) { + print STDERR "Error: invalid argument or format '$arg'\n"; + exit(1); + } + + # Explicitely reject duplicated options + if ($opts{$k}) { + print STDERR "Error: option '$k' defined more than once\n"; + exit(1); + } + $opts{$k} = $v; } # Submit the command and read the answer @@ -173,11 +172,11 @@ sub usage { # Use exit code of 1 in case of error, 0 otherwise my $exit_code; if ($error) { - (my $script_name = $0) =~ s|^.*/||; - print STDERR "$script_name error: $error\n"; - $exit_code = 1; + (my $script_name = $0) =~ s|^.*/||; + print STDERR "$script_name error: $error\n"; + $exit_code = 1; } else { - $exit_code = 0; + $exit_code = 0; } exit($exit_code); diff --git a/DOC/devtips/benchcfg.pl b/DOC/devtips/benchcfg.pl index 6640c16e..b311a096 100755 --- a/DOC/devtips/benchcfg.pl +++ b/DOC/devtips/benchcfg.pl @@ -8,21 +8,21 @@ # -10 =approx. 10 seconds cmpthese( -10, { - 'base' => \&cfg, - 'WO' => \&cfg1, - 'WO comp' => \&cfg2, + 'base' => \&cfg, + 'WO' => \&cfg1, + 'WO comp' => \&cfg2, }); sub cfg { - my %X = WebObs::Config::readCfg('/home/didier/wobs/CONF/WEBOBS.rc'); - my %Y = WebObs::Config::readCfg('/home/didier/wobs/CONF/NODES.rc'); + my %X = WebObs::Config::readCfg('/home/didier/wobs/CONF/WEBOBS.rc'); + my %Y = WebObs::Config::readCfg('/home/didier/wobs/CONF/NODES.rc'); } sub cfg1 { - my %X = WebObs::Config::readCfg1('/home/didier/wobs/CONF/WEBOBS.rc'); - my %Y = WebObs::Config::readCfg1('/home/didier/wobs/CONF/NODES.rc'); + my %X = WebObs::Config::readCfg1('/home/didier/wobs/CONF/WEBOBS.rc'); + my %Y = WebObs::Config::readCfg1('/home/didier/wobs/CONF/NODES.rc'); } sub cfg2 { - my %X = WebObs::Config::readCfg2('/home/didier/wobs/CONF/WEBOBS.rc'); - my %Y = WebObs::Config::readCfg2('/home/didier/wobs/CONF/NODES.rc'); + my %X = WebObs::Config::readCfg2('/home/didier/wobs/CONF/WEBOBS.rc'); + my %Y = WebObs::Config::readCfg2('/home/didier/wobs/CONF/NODES.rc'); } diff --git a/DOC/devtips/benchdate.pl b/DOC/devtips/benchdate.pl index 7aae4e6b..d1b1f577 100755 --- a/DOC/devtips/benchdate.pl +++ b/DOC/devtips/benchdate.pl @@ -4,18 +4,18 @@ use Benchmark qw(:all); use POSIX qw(strftime mktime); - # -3 =approx. 3 seconds cmpthese( -3, { - 'date' => \&qxdate, - 'strftime' => \&strf, + 'date' => \&qxdate, + 'strftime' => \&strf, }); sub qxdate { - my $d = qx(date -d "2012-01-01" +"\%B \%Y"); chomp($d); + my $d = qx(date -d "2012-01-01" +"\%B \%Y"); chomp($d); } sub strf { - # mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) - my $t = mktime( 0, 0, 0, 1, 0, 112 ); my $d = strftime("%B %Y", localtime($t)) + + # mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) + my $t = mktime( 0, 0, 0, 1, 0, 112 ); my $d = strftime("%B %Y", localtime($t)) } diff --git a/DOC/devtips/benchfile.pl b/DOC/devtips/benchfile.pl index 97365e65..cf646ecd 100755 --- a/DOC/devtips/benchfile.pl +++ b/DOC/devtips/benchfile.pl @@ -13,68 +13,73 @@ $scalar = slurp( $file ); cmpthese( 1000, { - 'Chas.' => \&chas, - 'Schwern' => \&schwern, - 'brian' => \&brian, - 'Chas. modified' => \&chas_modified, - 'Chas. sane' => \&chas_sane, - 'drewk' => \&drewk, - 'drewk2' => \&drewk2, + 'Chas.' => \&chas, + 'Schwern' => \&schwern, + 'brian' => \&brian, + 'Chas. modified' => \&chas_modified, + 'Chas. sane' => \&chas_sane, + 'drewk' => \&drewk, + 'drewk2' => \&drewk2, }); sub drewk { - my @arr = split(/\n/, $scalar); - my @found; - for(my $i=0; $i<=$#arr; $i+=10){ - # print "drewk[$i] $arr[$i]\n"; - push @found, $arr[$i]; + my @arr = split(/\n/, $scalar); + my @found; + for(my $i=0; $i<=$#arr; $i+=10){ + + # print "drewk[$i] $arr[$i]\n"; + push @found, $arr[$i]; } } sub drewk2 { - my $i=0; - my @found; - foreach(split(/\n/, $scalar)) { - next if $i++ % 10; -# print "drewk2[$i] $_\n"; - push @found, $_; - } + my $i=0; + my @found; + foreach(split(/\n/, $scalar)) { + next if $i++ % 10; + + # print "drewk2[$i] $_\n"; + push @found, $_; + } } sub schwern { my $count = 0; my @found; while($scalar =~ /\G(.*)\n/g) { next if $count++ % 10 != 0; -# print "schwern[$count] $1\n"; + + # print "schwern[$count] $1\n"; push @found, $1; - } } +} sub chas { open my $fh, "<", \$scalar; tie my @lines, "Tie::File", $fh - or die "could not tie in-memory file: $!"; + or die "could not tie in-memory file: $!"; my $i = 0; my @found = (); while (defined $lines[$i]) { + # print "chas[$i]: $lines[$i]\n"; push @found, $lines[$i]; - } continue { - $i += 10; - } + } continue { + $i += 10; } +} sub chas_modified { open my $fh, "<", \$scalar; tie my @lines, "Tie::File", $fh - or die "could not tie in-memory file: $!"; + or die "could not tie in-memory file: $!"; my $highest_multiple = int( $#lines / 10 ) ; - my @found = @lines[ map { $_ * 10 - ($_?1:0) } 0 .. $highest_multiple ]; + my @found = @lines[ map { $_ * 10 - ($_?1:0) } 0 .. $highest_multiple ]; + #print join "\n", @found; - } +} sub chas_sane { open my $fh, "<", \$scalar; @@ -82,18 +87,20 @@ sub chas_sane { my @found; while (my $line = <$fh>) { if ($. == 1 or not $. % 10) { + #print "chas_sane[$.] $line"; push @found, $_; - } } } +} sub brian { open my $fh, '<', \$scalar; my @found = scalar <$fh>; while( <$fh> ) { next if $. % 10; + #print "brian[$.] $_"; push @found, $_; - } } +} diff --git a/DOC/devtips/checkIP.pm b/DOC/devtips/checkIP.pm index 470155a0..ff8e9d15 100755 --- a/DOC/devtips/checkIP.pm +++ b/DOC/devtips/checkIP.pm @@ -5,32 +5,38 @@ use File::Basename; sub checkIP { - my $remoteIP = $_[0]; - my ($id1,$id2,$id3,$id4) = split (/\./,$remoteIP); - my $rangeIP=$id1.".".$id2.".".$id3; - if ( - ( - # Martinique - $rangeIP eq "195.83.190" - || ( - # Guadeloupe - $rangeIP eq "195.83.189" - # sans DHCP ou CDSA - && ($id4 < 150 || $id4 > 230) - ) - ) - # Local - || ($rangeIP eq "127.0.0") - ) { - # Adresse IP interne : OK - return 0 - } else { - # Adresse IP externe : accès refusé ou lecture seule - #return 1 - - # NOUVEAU: checkIP renvoie toujours 0 depuis l'identification par login - return 0 - } + my $remoteIP = $_[0]; + my ($id1,$id2,$id3,$id4) = split (/\./,$remoteIP); + my $rangeIP=$id1.".".$id2.".".$id3; + if ( + ( + + # Martinique + $rangeIP eq "195.83.190" + || ( + + # Guadeloupe + $rangeIP eq "195.83.189" + + # sans DHCP ou CDSA + && ($id4 < 150 || $id4 > 230) + ) + ) + + # Local + || ($rangeIP eq "127.0.0") + ) { + + # Adresse IP interne : OK + return 0 + } else { + + # Adresse IP externe : accès refusé ou lecture seule + #return 1 + + # NOUVEAU: checkIP renvoie toujours 0 depuis l'identification par login + return 0 + } } diff --git a/DOC/devtips/sfork.pl b/DOC/devtips/sfork.pl index c8f6daf6..5c1bcc8e 100755 --- a/DOC/devtips/sfork.pl +++ b/DOC/devtips/sfork.pl @@ -5,7 +5,6 @@ use Time::HiRes qw/time gettimeofday tv_interval usleep/; use POSIX qw/strftime :signal_h :errno_h :sys_wait_h/; - my $kidcmd; my $dcd; my $dcdRC; my $dcdmsg; my $drc; my $redir = ">"; open (MYLOG, '>>/home/lafon/sandbox/sfork.log'); @@ -21,40 +20,42 @@ #$kidcmd="matlab -nodisplay -r 'quit'"; $kidcmd="matlab -nodisplay <<< 'disp(datestr(now));exit(16)'"; -my $kid = fork(); -if (!defined($kid)) { - print MYLOG "$$ couldn't fork [ $kidcmd ] !\n"; +my $kid = fork(); +if (!defined($kid)) { + print MYLOG "$$ couldn't fork [ $kidcmd ] !\n"; } if ($kid == 0) { # kid's code - $drc = qx(lsof -a -p $$ -d0,1,2); - print MYLOG "$drc\n"; - #open STDOUT, $redir, "/home/lafon/sandbox/sfork.out"; - #open STDERR, $redir, "/home/lafon/sandbox/sfork.err"; - open(STDOUT, $redir, "/home/lafon/sandbox/sfork.out") or die "Can't redirect STDOUT: $!"; - open(STDERR, $redir, "/home/lafon/sandbox/sfork.err") or die "Can't redirect STDERR: $!"; - exec "$kidcmd" or logit("$$ couldn't exec [ $kidcmd ]: $!"); -} else { # parent's code continued - print MYLOG "forked $kid [ $kidcmd ]\n"; - my $done=0; - while (!$done) { - usleep(int(300000)); - my $t0 = [gettimeofday]; - while (($dcd = waitpid(-1, &WNOHANG)) > 0) { - my $dcdRC = $?; # default, see below each case - my $dcdmsg = ''; - if ($? == -1) { $dcdmsg = sprintf (" failed to execute: $!"); } - elsif ($? & 127) { - $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); - } - else { - $dcdRC = $? >> 8; - $dcdmsg = sprintf (" %s %d","$dcd exited with ", $dcdRC); - } - #print "reaper: kid($dcd) ?=$?, dcdRC=$dcdRC\n" ; - $done=1; - } - } - print MYLOG "reaper done.\n"; + $drc = qx(lsof -a -p $$ -d0,1,2); + print MYLOG "$drc\n"; + + #open STDOUT, $redir, "/home/lafon/sandbox/sfork.out"; + #open STDERR, $redir, "/home/lafon/sandbox/sfork.err"; + open(STDOUT, $redir, "/home/lafon/sandbox/sfork.out") or die "Can't redirect STDOUT: $!"; + open(STDERR, $redir, "/home/lafon/sandbox/sfork.err") or die "Can't redirect STDERR: $!"; + exec "$kidcmd" or logit("$$ couldn't exec [ $kidcmd ]: $!"); +} else { # parent's code continued + print MYLOG "forked $kid [ $kidcmd ]\n"; + my $done=0; + while (!$done) { + usleep(int(300000)); + my $t0 = [gettimeofday]; + while (($dcd = waitpid(-1, &WNOHANG)) > 0) { + my $dcdRC = $?; # default, see below each case + my $dcdmsg = ''; + if ($? == -1) { $dcdmsg = sprintf (" failed to execute: $!"); } + elsif ($? & 127) { + $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); + } + else { + $dcdRC = $? >> 8; + $dcdmsg = sprintf (" %s %d","$dcd exited with ", $dcdRC); + } + + #print "reaper: kid($dcd) ?=$?, dcdRC=$dcdRC\n" ; + $done=1; + } + } + print MYLOG "reaper done.\n"; } close MYLOG; diff --git a/SETUP/IMP.pm b/SETUP/IMP.pm index 908a4927..605c6960 100644 --- a/SETUP/IMP.pm +++ b/SETUP/IMP.pm @@ -37,534 +37,542 @@ print " FROM 'reseaux' : $LEG_RESEAUX\n"; print " FROM NODES : $LEG_NODES\n"; print "now logging to console AND IMP.stdout\n\n"; -open (STDOUT, "| tee -ai IMP.stdout"); +open (STDOUT, "| tee -ai IMP.stdout"); print( strftime("\n%F %R ",localtime(time())).$sep."\n"); printf ("dryrun now %s\n",($dry==1)?"ON":"OFF - at your own risk"); # call this to toggle 'dry-run' mode # sub dryrun { - $dry ^= 1; - print( "\n".strftime("%F %R ",localtime(time()))); - printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); + $dry ^= 1; + print( "\n".strftime("%F %R ",localtime(time()))); + printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); } # guess what ... -sub IMPORT0 { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> IMP::MIGRATE0\n"; - $t0 = time; - my (@liste, $i); - $graphFile = $LEG_RESEAUX; - printf("%+6d IMP.0 from %s\n", time-$t0, $graphFile); - - open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; - while() { push(@infoGenerales,$_); } - close(FILE); - - chomp(@infoGenerales); - @infoGenerales = grep(!/^#/, @infoGenerales); - @infoGenerales = grep(!/^$/, @infoGenerales); - - # "DISCIPLINE" --> DISCIPLINES.conf - # - printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); - my @listeMrkD = getTag("DISCIPLINE","mrk"); - my @listeCodesD = getTag("DISCIPLINE","cod"); - my @listeKeyD = getTag("DISCIPLINE","key"); - my @listeOrdD = getTag("DISCIPLINE","ord"); - my @listeNomsD = getTag("DISCIPLINE","nom"); - - my @tlcodes = @listeCodesD; - for $i (0..scalar(@tlcodes)) { - if (exists($DISCP{$tlcodes[$i]})) { - print "imported discipline $tlcodes[$i] already exists...ignored\n"; - splice(@listeCodesD, $i, 1); - } - } - - if (!$dry) { - open(WRT, ">>$FILE_DISCIPLINES"); - $i = 0; - for (@listeCodesD) { - printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); - $i += 1; - } - close(WRT); - } else { print "would update $FILE_DISCIPLINES with codes @listeCodesD\n" }; - - # "OBSERVATOIRE" --> OWNERS.conf - # - printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); - my @listeCodesO = getTag("OBSERVATOIRE","cod"); - my @listeNomsO = getTag("OBSERVATOIRE","nom"); - - my @tlcodes = @listeCodesO; - for $i (0..scalar(@tlcodes)) { - if (exists($OWNRS{$tlcodes[$i]})) { - print "imported owner $tlcodes[$i] already exists...ignored\n"; - splice(@listeCodesO, $i, 1); - } - } - if (!$dry) { - open(WRT, ">>$FILE_OWNERS"); - $i = 0; - for (@listeCodesO) { - printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); - $i += 1; - } - close(WRT); - } else { print "would update $FILE_OWNERS with codes @listeCodesO\n" }; - - # For the migration process, each FORM is identified by an existing - # "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. - # Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and - # a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to - # this FORM. - # Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and - # PROCS definitions of their 'frm' attribute - # +sub IMPORT0 { + print( "\n".strftime("%F %R ",localtime(time()))); + print "> IMP::MIGRATE0\n"; + $t0 = time; + my (@liste, $i); + $graphFile = $LEG_RESEAUX; + printf("%+6d IMP.0 from %s\n", time-$t0, $graphFile); + + open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; + while() { push(@infoGenerales,$_); } + close(FILE); + + chomp(@infoGenerales); + @infoGenerales = grep(!/^#/, @infoGenerales); + @infoGenerales = grep(!/^$/, @infoGenerales); + + # "DISCIPLINE" --> DISCIPLINES.conf + # + printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); + my @listeMrkD = getTag("DISCIPLINE","mrk"); + my @listeCodesD = getTag("DISCIPLINE","cod"); + my @listeKeyD = getTag("DISCIPLINE","key"); + my @listeOrdD = getTag("DISCIPLINE","ord"); + my @listeNomsD = getTag("DISCIPLINE","nom"); + + my @tlcodes = @listeCodesD; + for $i (0..scalar(@tlcodes)) { + if (exists($DISCP{$tlcodes[$i]})) { + print "imported discipline $tlcodes[$i] already exists...ignored\n"; + splice(@listeCodesD, $i, 1); + } + } + + if (!$dry) { + open(WRT, ">>$FILE_DISCIPLINES"); + $i = 0; + for (@listeCodesD) { + printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); + $i += 1; + } + close(WRT); + } else { print "would update $FILE_DISCIPLINES with codes @listeCodesD\n" }; + + # "OBSERVATOIRE" --> OWNERS.conf + # + printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); + my @listeCodesO = getTag("OBSERVATOIRE","cod"); + my @listeNomsO = getTag("OBSERVATOIRE","nom"); + + my @tlcodes = @listeCodesO; + for $i (0..scalar(@tlcodes)) { + if (exists($OWNRS{$tlcodes[$i]})) { + print "imported owner $tlcodes[$i] already exists...ignored\n"; + splice(@listeCodesO, $i, 1); + } + } + if (!$dry) { + open(WRT, ">>$FILE_OWNERS"); + $i = 0; + for (@listeCodesO) { + printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); + $i += 1; + } + close(WRT); + } else { print "would update $FILE_OWNERS with codes @listeCodesO\n" }; + +# For the migration process, each FORM is identified by an existing +# "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. +# Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and +# a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to +# this FORM. +# Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and +# PROCS definitions of their 'frm' attribute +# my %F; - my @formsconfs = qx(ls $LEG_PATH/reseaux*.conf); - for my $f (@formsconfs) { - chomp($f); - # following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) - #my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); - my $ucf = uc($f); - $ucf =~ s!$LEG_PATH/reseaux(.*).conf!$1!gi; - - # ID3 => FORM hash - open(RDR, "<$f") or die "open $f failed: $!\n"; - while() { - chomp; - if (! /^#/) { $F{$_} = $ucf; } - } - close(RDR); - - # FORMNAME directory - printf("%+6d creating %s\n", time-$t0, "$WEBOBS{PATH_FORMS}/$ucf"); - if ($dry) {print "would mkdir -p $WEBOBS{PATH_FORMS}/$ucf\n"} else { qx(mkdir -p $WEBOBS{PATH_FORMS}/$ucf) }; - # build the FORMNAME.conf from WEBOBS.conf related statements - my $pgrep = " \"^$ucf"."_|_"."$ucf\" $LEG_PATH/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; - qx(grep -P $pgrep); - # move the FORM associated files to the brand new FORM/FORMNAME directory - $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $LEG_PATH/WEBOBS.conf"; - my @l = qx(grep -P $pgrep); - for (@l) { - chomp; - s/(^.*\|)//g; - if ($dry) {print "would mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/\n"} else { qx(mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/) }; - } - } - - # NETWORKS --> VIEWS/xxx and PROCS/xxx - # - for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { - my ($res,$code,$value) = split (/\|/,$_); - $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### - $G{$res}{$code} = $value; - } - printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); - for $g (keys (%G)) { - # - # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined - # - if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2 ) { - my @Existing = WebObs::Grids::listProcNames; - if ( ! ($g ~~ @Existing)) { - my $r; - if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; - my $path = "$PATH_PROCS/$g/$g.conf"; - printf("%+6d created %s \n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"NAME|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"RAWDATA|$G{$g}{ftp}\n"); - push(@out,"TZ|$G{$g}{utc}\n"); - push(@out,"TIMESCALELIST|$G{$g}{ext}\n"); - push(@out,"DECIMATELIST|$G{$g}{dec}\n"); - push(@out,"CUMULATELIST|$G{$g}{cum}\n"); - push(@out,"DATESTRLIST|$G{$g}{fmt}\n"); - push(@out,"MARKERSIZELIST|$G{$g}{mks}\n"); - push(@out,"THUMBNAIL|$G{$g}{ico}\n"); - $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); - push(@out,"cro|TBD\n"); - push(@out,"URL|$G{$g}{lnk}\n"); - push(@out,"ddb|$G{$g}{ddb}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - foreach my $k (keys %F) { - if ($o.$c eq $k) { - $formslist .= $F{$k}." " ; - if ($dry) { print "would ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}\n"} else { qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}) }; - } - } - migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); - } - } - } - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"FORM|$formslist\n");} - if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - } - # - # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' - # - if (defined($G{$g}{net}) and $G{$g}{net} != 0) { - my @Existing = WebObs::Grids::lisViewNames; - if ( ! ($g ~~ @Existing)) { - if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { - print "No ID3 (missing obs and/or cod) for $g "; - # my $in = ; - # chomp($in); - # if (length($in) != 3) { - print " - $g skipped, NOT migrated\n"; - next; - # } - # $G{$g}{obs} = substr($in,0,1); - # $G{$g}{cod} = substr($in,1,2); - } - if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; - my $path = "$PATH_VIEWS/$g/$g.conf"; - printf("%+6d created %s\n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"NAME|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"OWNCODE|$G{$g}{obs}\n"); - push(@out,"NODENAME|$G{$g}{snm}\n"); - push(@out,"NODESIZE|$G{$g}{ssz}\n"); - push(@out,"NODERGB|$G{$g}{rvb}\n"); - push(@out,"MAPLIST|$G{$g}{map}\n"); - push(@out,"URL|$G{$g}{htm}\n"); - push(@out,"DISPLAY|$G{$g}{web}\n"); - push(@out,"TYPE|$G{$g}{typ}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # + handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - #foreach my $k (keys %F) { - # if ($o.$c eq $k) { - # $formslist .= $F{$k}." "; - # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); - # } - #} - migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); - } - } - } - my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"FORM|$formslist\n");} - if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - } - } # end for $g (keys (%G)) - - printf("\n\n%+6d M2G.0 summary:\n", time-$t0); - printf(" ------------------\n"); - if (!$dry) { - printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); - printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); - printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); - printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); - print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); - print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); - print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); - for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; - for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; - print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; - } - - printf("\n%+6d M2G.0 done.\n", time-$t0); - #close(STDOUT); - -} + my @formsconfs = qx(ls $LEG_PATH/reseaux*.conf); + for my $f (@formsconfs) { + chomp($f); + +# following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) +#my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); + my $ucf = uc($f); + $ucf =~ s!$LEG_PATH/reseaux(.*).conf!$1!gi; + + # ID3 => FORM hash + open(RDR, "<$f") or die "open $f failed: $!\n"; + while() { + chomp; + if (! /^#/) { $F{$_} = $ucf; } + } + close(RDR); + + # FORMNAME directory + printf("%+6d creating %s\n", time-$t0, "$WEBOBS{PATH_FORMS}/$ucf"); + if ($dry) {print "would mkdir -p $WEBOBS{PATH_FORMS}/$ucf\n"} else { qx(mkdir -p $WEBOBS{PATH_FORMS}/$ucf) }; + + # build the FORMNAME.conf from WEBOBS.conf related statements + my $pgrep = " \"^$ucf"."_|_"."$ucf\" $LEG_PATH/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; + qx(grep -P $pgrep); + + # move the FORM associated files to the brand new FORM/FORMNAME directory + $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $LEG_PATH/WEBOBS.conf"; + my @l = qx(grep -P $pgrep); + for (@l) { + chomp; + s/(^.*\|)//g; + if ($dry) {print "would mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/\n"} else { qx(mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/) }; + } + } + + # NETWORKS --> VIEWS/xxx and PROCS/xxx + # + for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { + my ($res,$code,$value) = split (/\|/,$_); + $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### + $G{$res}{$code} = $value; + } + printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); + for $g (keys (%G)) { + # + # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined + # + if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2 ) { + my @Existing = WebObs::Grids::listProcNames; + if ( ! ($g ~~ @Existing)) { + my $r; + if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; + my $path = "$PATH_PROCS/$g/$g.conf"; + printf("%+6d created %s \n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"NAME|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"RAWDATA|$G{$g}{ftp}\n"); + push(@out,"TZ|$G{$g}{utc}\n"); + push(@out,"TIMESCALELIST|$G{$g}{ext}\n"); + push(@out,"DECIMATELIST|$G{$g}{dec}\n"); + push(@out,"CUMULATELIST|$G{$g}{cum}\n"); + push(@out,"DATESTRLIST|$G{$g}{fmt}\n"); + push(@out,"MARKERSIZELIST|$G{$g}{mks}\n"); + push(@out,"THUMBNAIL|$G{$g}{ico}\n"); + $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); + push(@out,"cro|TBD\n"); + push(@out,"URL|$G{$g}{lnk}\n"); + push(@out,"ddb|$G{$g}{ddb}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + foreach my $k (keys %F) { + if ($o.$c eq $k) { + $formslist .= $F{$k}." " ; + if ($dry) { print "would ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}\n"} else { qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}) }; + } + } + migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); + } + } + } + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"FORM|$formslist\n");} + if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + } + # + # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' + # + if (defined($G{$g}{net}) and $G{$g}{net} != 0) { + my @Existing = WebObs::Grids::lisViewNames; + if ( ! ($g ~~ @Existing)) { + if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { + print "No ID3 (missing obs and/or cod) for $g "; + + # my $in = ; + # chomp($in); + # if (length($in) != 3) { + print " - $g skipped, NOT migrated\n"; + next; + + # } + # $G{$g}{obs} = substr($in,0,1); + # $G{$g}{cod} = substr($in,1,2); + } + if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; + my $path = "$PATH_VIEWS/$g/$g.conf"; + printf("%+6d created %s\n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"NAME|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"OWNCODE|$G{$g}{obs}\n"); + push(@out,"NODENAME|$G{$g}{snm}\n"); + push(@out,"NODESIZE|$G{$g}{ssz}\n"); + push(@out,"NODERGB|$G{$g}{rvb}\n"); + push(@out,"MAPLIST|$G{$g}{map}\n"); + push(@out,"URL|$G{$g}{htm}\n"); + push(@out,"DISPLAY|$G{$g}{web}\n"); + push(@out,"TYPE|$G{$g}{typ}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # + handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + + #foreach my $k (keys %F) { + # if ($o.$c eq $k) { + # $formslist .= $F{$k}." "; + # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); + # } + #} + migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); + } + } + } + my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"FORM|$formslist\n");} + if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + } + } # end for $g (keys (%G)) + + printf("\n\n%+6d M2G.0 summary:\n", time-$t0); + printf(" ------------------\n"); + if (!$dry) { + printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); + printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); + printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); + printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); + print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); + print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); + print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); + for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; + for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; + print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; + } + + printf("\n%+6d M2G.0 done.\n", time-$t0); + + #close(STDOUT); + +} sub MIGRATE_1_NODESXLATE { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_NODESXLATE\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^NOM\|/NAME|/; - s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; - s/^VALIDE\|/VALID\|/; - # next 3 to change | to \| except first one - s/^(.*?)\|/$1¤/; - s/\|/\\\|/g; - s/^(.*?)¤/$1\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_NODESXLATE\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^NOM\|/NAME|/; + s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; + s/^VALIDE\|/VALID\|/; + + # next 3 to change | to \| except first one + s/^(.*?)\|/$1¤/; + s/\|/\\\|/g; + s/^(.*?)¤/$1\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_1_FORMSCONF { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_FORMSCONF\n"; - $t0 = time; - my (@liste, $i); - my @lsd = qx(ls -d $PATH_FORMS/*); - chomp(@lsd); - foreach (@lsd) { - s/.*FORMS\///g; - my $form = $_; - my $prefix = $form."_"; - open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; - my @f = ; - close RDR; - for (@f) { - s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; - s/$prefix//; - } - unshift(@f, "=key|value\n"); # add the new readCfg format-specification - if (!$dry) { - open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; - for (@f) { - print WRT $_; - } - close WRT; - } else { print "would set [\n @f \n] "} - print "$PATH_FORMS/$form/$form.conf done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_FORMSCONF\n"; + $t0 = time; + my (@liste, $i); + my @lsd = qx(ls -d $PATH_FORMS/*); + chomp(@lsd); + foreach (@lsd) { + s/.*FORMS\///g; + my $form = $_; + my $prefix = $form."_"; + open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; + my @f = ; + close RDR; + for (@f) { + s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; + s/$prefix//; + } + unshift(@f, "=key|value\n"); # add the new readCfg format-specification + if (!$dry) { + open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; + for (@f) { + print WRT $_; + } + close WRT; + } else { print "would set [\n @f \n] "} + print "$PATH_FORMS/$form/$form.conf done\n"; + } } sub MIGRATE_2_NODESFEATURES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_2_NODESFEATURES\n"; - $t0 = time; - my @nodes = <$PATH_NODES/*>; - chomp(@nodes); - for my $n (@nodes) { - if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} - die "Couldn't create $n/FEATURES; $!" if ($?); - my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); - die "Couldn't find txt's; $!" if ($?); - chomp(@files); - for my $f (@files) { - if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv $f $n/FEATURES/);} - die "Couldn't move $f to $n/FEATURES; $? " if ($?); - } - print "$n done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_2_NODESFEATURES\n"; + $t0 = time; + my @nodes = <$PATH_NODES/*>; + chomp(@nodes); + for my $n (@nodes) { + if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} + die "Couldn't create $n/FEATURES; $!" if ($?); + my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); + die "Couldn't find txt's; $!" if ($?); + chomp(@files); + for my $f (@files) { + if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv $f $n/FEATURES/);} + die "Couldn't move $f to $n/FEATURES; $? " if ($?); + } + print "$n done\n"; + } } sub MIGRATE_3_FORMSNET2GRIDS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; - my @forms= <$PATH_FORMS/*> ; - foreach (@forms) { - if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } - else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$_.conf") } - my @file = <$_/reseaux*.conf> ; - for my $fn (@file) { - open RDR, "<$fn" or die "Couldn't open $fn : $!"; - my @f = ; - close RDR; - for (@f) { - next if m/^#/ ; - next if m/^$/; - chomp(); - my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); - if (scalar(@res) > 0) { - $res[0] = basename($res[0]); - $res[0] =~ s/\.conf//; - $res[0] =~ s/:.*$//g; - chomp($res[0]); - if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } - else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } - } - } - print "$fn done.\n"; - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; + my @forms= <$PATH_FORMS/*> ; + foreach (@forms) { + if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } + else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$_.conf") } + my @file = <$_/reseaux*.conf> ; + for my $fn (@file) { + open RDR, "<$fn" or die "Couldn't open $fn : $!"; + my @f = ; + close RDR; + for (@f) { + next if m/^#/ ; + next if m/^$/; + chomp(); + my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); + if (scalar(@res) > 0) { + $res[0] = basename($res[0]); + $res[0] =~ s/\.conf//; + $res[0] =~ s/:.*$//g; + chomp($res[0]); + if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } + else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } + } + } + print "$fn done.\n"; + } + } } sub MIGRATE_3_NORMNODES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_NORMNODES\n"; - print "> NOP\n"; + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_NORMNODES\n"; + print "> NOP\n"; } sub MIGRATE_4_ALIASDASH { + # late request: NODEs having their 'ALIAS' or 'DATA_FILE' set to '-' should NOT be included in PROC(s) - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_4_ALIASDASH\n"; - $t0 = time; - my @files = <$PATH_NODES/*/*.cnf>; #/ - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { - my $p = ''; - for (@f) { if (/PROC\|/) { $p = $_ } } ; - chomp($p); - if ($dry) { - print "would sed -ie \'/PROC|/d\' $_" ; - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; - } - else { - qx( sed -ie \'/PROC|/d\' $_ ); - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); - } - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_4_ALIASDASH\n"; + $t0 = time; + my @files = <$PATH_NODES/*/*.cnf>; #/ + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { + my $p = ''; + for (@f) { if (/PROC\|/) { $p = $_ } } ; + chomp($p); + if ($dry) { + print "would sed -ie \'/PROC|/d\' $_" ; + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; + } + else { + qx( sed -ie \'/PROC|/d\' $_ ); + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); + } + } + } } sub MIGRATE_5_FID { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_5_FID\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^DATA_FILE\|/FID|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_5_FID\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^DATA_FILE\|/FID|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } - - # helper function to extract DISCIPLINE & OBSERVATOIRE definitions # sub getTag { - my($stanza, $tag) = @_; - my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); - $l[0] =~ s/^\w\*|\w*\|//gi; - $l[0] =~ s/\'|{|}//gi; - return split(/,/,$l[0]); + my($stanza, $tag) = @_; + my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); + $l[0] =~ s/^\w\*|\w*\|//gi; + $l[0] =~ s/\'|{|}//gi; + return split(/,/,$l[0]); } - # STATIONS (called from main process, for each grid/proc, for which # stations are identified by the 3 digits legacy code 'obs+cod' # 3 arguments: PROC or VIEW ($type) # name of PROC or VIEW ($name) # id 3 digits to identify stations ($id3) sub migID3Stations { - my ($type, $name, $id3, $s1, $s2) = @_; - opendir(DIR, $$WEBOBS{PATH_NODES}) or die "couldn't opendir $WEBOBS{PATH_NODES} : $!"; - my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); - closedir(DIR); - my ($dir, $o); - for $dir (@dirs) { - if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { - if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { - printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "=key|value\n"); - print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - while () { # use all existing lines, replacing ... - s/\s/\|/; # ... 1st blank with | delimiter - print(WRT $_); # - } - print(WRT "$type|$name\n"); # new link to PROC or GRID line - print(WRT "$s1\n"); - if (defined($s2)) { print(WRT "$s2\n") }; - close(WRT); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - } else { - printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - my $typefound=0; - do { - local $^I='~'; - local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); - while(<>){ - chomp; - if (/^($type)\|(.*)/) { - $_ = "$type|$2,$name\n"; - $typefound++; - } - $_ .= "\n"; - print; - } - }; - if ($typefound == 0) { - if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "$type|$name\n"); - close(WRT); - } - } - qx(rm $PATH_NODES/$dir/$dir.cnf~); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - close(RDR); - } - } + my ($type, $name, $id3, $s1, $s2) = @_; + opendir(DIR, $$WEBOBS{PATH_NODES}) or die "couldn't opendir $WEBOBS{PATH_NODES} : $!"; + my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); + closedir(DIR); + my ($dir, $o); + for $dir (@dirs) { + if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { + if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { + printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "=key|value\n"); + print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + while () { # use all existing lines, replacing ... + s/\s/\|/; # ... 1st blank with | delimiter + print(WRT $_); # + } + print(WRT "$type|$name\n"); # new link to PROC or GRID line + print(WRT "$s1\n"); + if (defined($s2)) { print(WRT "$s2\n") }; + close(WRT); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + } else { + printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + my $typefound=0; + do { + local $^I='~'; + local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); + while(<>){ + chomp; + if (/^($type)\|(.*)/) { + $_ = "$type|$2,$name\n"; + $typefound++; + } + $_ .= "\n"; + print; + } + }; + if ($typefound == 0) { + if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "$type|$name\n"); + close(WRT); + } + } + qx(rm $PATH_NODES/$dir/$dir.cnf~); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + close(RDR); + } + } } 1; diff --git a/SETUP/M2G.pm b/SETUP/M2G.pm index e010fedb..ac7a42d6 100644 --- a/SETUP/M2G.pm +++ b/SETUP/M2G.pm @@ -199,25 +199,25 @@ our (@ol, @cl); # batch if arguments on command line --------------------------------------- if (@ARGV) { - my ($op1,$op2) = @ARGV; - $dry = 1; - if ($op1 eq 'do') { $op1 = $op2; $dry = 0 } - my %act = (REAPER => \&REAPER, - MIGRATE0 => \&MIGRATE0, - MIGRATE_1_FORMSCONF => \&MIGRATE_1_FORMSCONF, - MIGRATE_1_NODESXLATE => \&MIGRATE_1_NODESXLATE, - MIGRATE_2_NODESFEATURES => \&MIGRATE_2_NODESFEATURES, - MIGRATE_3_FORMSNET2GRIDS => \&MIGRATE_3_FORMSNET2GRIDS, - MIGRATE_4_ALIASDASH => \&MIGRATE_4_ALIASDASH, - MIGRATE_5_FID => \&MIGRATE_5_FID, - MIGRATE_6_PROCKEYS => \&MIGRATE_6_PROCKEYS, - MIGRATE_6_VIEWKEYS => \&MIGRATE_6_VIEWKEYS); - if ( defined($act{$op1}) ) { - print "dry = $dry , command = $op1\n"; - $act{$op1}->(); - warn() if $@; - } - exit; + my ($op1,$op2) = @ARGV; + $dry = 1; + if ($op1 eq 'do') { $op1 = $op2; $dry = 0 } + my %act = (REAPER => \&REAPER, + MIGRATE0 => \&MIGRATE0, + MIGRATE_1_FORMSCONF => \&MIGRATE_1_FORMSCONF, + MIGRATE_1_NODESXLATE => \&MIGRATE_1_NODESXLATE, + MIGRATE_2_NODESFEATURES => \&MIGRATE_2_NODESFEATURES, + MIGRATE_3_FORMSNET2GRIDS => \&MIGRATE_3_FORMSNET2GRIDS, + MIGRATE_4_ALIASDASH => \&MIGRATE_4_ALIASDASH, + MIGRATE_5_FID => \&MIGRATE_5_FID, + MIGRATE_6_PROCKEYS => \&MIGRATE_6_PROCKEYS, + MIGRATE_6_VIEWKEYS => \&MIGRATE_6_VIEWKEYS); + if ( defined($act{$op1}) ) { + print "dry = $dry , command = $op1\n"; + $act{$op1}->(); + warn() if $@; + } + exit; } # woc interactive, system setups ----------------------------------------------- @@ -247,622 +247,632 @@ print " TO 'new' FORMS : $PATH_FORMS\n"; print " FROM/TO DATA : $PATH_NODES\n"; print "now logging to console AND $confpath/M2G.stdout\n\n"; -open (STDOUT, "| tee -ai $confpath/M2G.stdout"); +open (STDOUT, "| tee -ai $confpath/M2G.stdout"); print( strftime("\n%F %R ",localtime(time())).$sep."\n"); printf ("dryrun now %s\n",($dry==1)?"ON":"OFF - at your own risk"); # call this to toggle 'dry-run' mode # sub dryrun { - $dry ^= 1; - print( "\n".strftime("%F %R ",localtime(time()))); - printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); + $dry ^= 1; + print( "\n".strftime("%F %R ",localtime(time()))); + printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); } # cleanup previous M2G generated files if any. # This DOES NOT ERASE the FORMS directory and its contents sub REAPER { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::REAPER\n"; - my $cmd="rm -rf "; - print "purging VIEWS/ PROCS/ GRIDS2*/ ...\n"; - print $dry?"would $cmd $PATH_VIEWS\n":qx($cmd $PATH_VIEWS); - print $dry?"would $cmd $PATH_PROCS\n":qx($cmd $PATH_PROCS); - #print qx($cmd $WEBOBS{PATH_FORMS}); #cannot easily be undone - print $dry?"would $cmd $PATH_GRIDS2NODES\n":qx($cmd $PATH_GRIDS2NODES); - print $dry?"would $cmd $PATH_GRIDS2FORMS\n":qx($cmd $PATH_GRIDS2FORMS); - print "purging NODES *.cnf* ...\n"; - print $dry?"would $cmd $PATH_NODES/*/*.cnf\n":qx($cmd $PATH_NODES/*/*.cnf); - print $dry?"would $cmd $PATH_NODES/*/*.cnf~\n":qx($cmd $PATH_NODES/*/*.cnf~); - print "Reaper done.\n"; + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::REAPER\n"; + my $cmd="rm -rf "; + print "purging VIEWS/ PROCS/ GRIDS2*/ ...\n"; + print $dry?"would $cmd $PATH_VIEWS\n":qx($cmd $PATH_VIEWS); + print $dry?"would $cmd $PATH_PROCS\n":qx($cmd $PATH_PROCS); + + #print qx($cmd $WEBOBS{PATH_FORMS}); #cannot easily be undone + print $dry?"would $cmd $PATH_GRIDS2NODES\n":qx($cmd $PATH_GRIDS2NODES); + print $dry?"would $cmd $PATH_GRIDS2FORMS\n":qx($cmd $PATH_GRIDS2FORMS); + print "purging NODES *.cnf* ...\n"; + print $dry?"would $cmd $PATH_NODES/*/*.cnf\n":qx($cmd $PATH_NODES/*/*.cnf); + print $dry?"would $cmd $PATH_NODES/*/*.cnf~\n":qx($cmd $PATH_NODES/*/*.cnf~); + print "Reaper done.\n"; } # guess what ... -sub MIGRATE0 { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE0\n"; - $t0 = time; - my (@liste, $i); - $graphFile = $LEG_RESEAUX; - printf("%+6d M2G.0 from %s\n", time-$t0, $graphFile); - - open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; - while() { push(@infoGenerales,$_); } - close(FILE); - - chomp(@infoGenerales); - @infoGenerales = grep(!/^#/, @infoGenerales); - @infoGenerales = grep(!/^$/, @infoGenerales); - - print $dry?"would mkdir -p $PATH_VIEWS\n":qx(mkdir -p $PATH_VIEWS); - print $dry?"would mkdir -p $PATH_PROCS\n":qx(mkdir -p $PATH_PROCS); - print $dry?"would mkdir -p $PATH_FORMS\n":qx(mkdir -p $PATH_FORMS); - print $dry?"would mkdir -p $PATH_GRIDS2NODES\n":qx(mkdir -p $PATH_GRIDS2NODES); - print $dry?"would mkdir -p $PATH_GRIDS2FORMS\n":qx(mkdir -p $PATH_GRIDS2FORMS); - - # "DISCIPLINE" --> DISCIPLINES.conf - # - printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); - my @listeMrkD = getTag("DISCIPLINE","mrk"); - my @listeCodesD = getTag("DISCIPLINE","cod"); - my @listeKeyD = getTag("DISCIPLINE","key"); - my @listeOrdD = getTag("DISCIPLINE","ord"); - my @listeNomsD = getTag("DISCIPLINE","nom"); - - if (!$dry) { - open(WRT, ">$FILE_DISCIPLINES"); - printf(WRT "%s\n","=key|ord|keyword|name|marker"); - printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); - $i = 0; - for (@listeCodesD) { - printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); - $i += 1; - } - close(WRT); - } else { print "would build $FILE_DISCIPLINES with codes @listeCodesD\n" }; - - # "OBSERVATOIRE" --> OWNERS.conf - # - printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); - my @listeCodesO = getTag("OBSERVATOIRE","cod"); - my @listeNomsO = getTag("OBSERVATOIRE","nom"); - - if (!$dry) { - open(WRT, ">$FILE_OWNERS"); - printf(WRT "%s\n","=key|value"); - printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); - $i = 0; - for (@listeCodesO) { - printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); - $i += 1; - } - close(WRT); - } else { print "would build $FILE_OWNERS with codes @listeCodesO\n" }; - - # For the migration process, each FORM is identified by an existing - # "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. - # Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and - # a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to - # this FORM. - # Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and - # PROCS definitions of their 'frm' attribute - # +sub MIGRATE0 { + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE0\n"; + $t0 = time; + my (@liste, $i); + $graphFile = $LEG_RESEAUX; + printf("%+6d M2G.0 from %s\n", time-$t0, $graphFile); + + open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; + while() { push(@infoGenerales,$_); } + close(FILE); + + chomp(@infoGenerales); + @infoGenerales = grep(!/^#/, @infoGenerales); + @infoGenerales = grep(!/^$/, @infoGenerales); + + print $dry?"would mkdir -p $PATH_VIEWS\n":qx(mkdir -p $PATH_VIEWS); + print $dry?"would mkdir -p $PATH_PROCS\n":qx(mkdir -p $PATH_PROCS); + print $dry?"would mkdir -p $PATH_FORMS\n":qx(mkdir -p $PATH_FORMS); + print $dry?"would mkdir -p $PATH_GRIDS2NODES\n":qx(mkdir -p $PATH_GRIDS2NODES); + print $dry?"would mkdir -p $PATH_GRIDS2FORMS\n":qx(mkdir -p $PATH_GRIDS2FORMS); + + # "DISCIPLINE" --> DISCIPLINES.conf + # + printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); + my @listeMrkD = getTag("DISCIPLINE","mrk"); + my @listeCodesD = getTag("DISCIPLINE","cod"); + my @listeKeyD = getTag("DISCIPLINE","key"); + my @listeOrdD = getTag("DISCIPLINE","ord"); + my @listeNomsD = getTag("DISCIPLINE","nom"); + + if (!$dry) { + open(WRT, ">$FILE_DISCIPLINES"); + printf(WRT "%s\n","=key|ord|keyword|name|marker"); + printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); + $i = 0; + for (@listeCodesD) { + printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); + $i += 1; + } + close(WRT); + } else { print "would build $FILE_DISCIPLINES with codes @listeCodesD\n" }; + + # "OBSERVATOIRE" --> OWNERS.conf + # + printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); + my @listeCodesO = getTag("OBSERVATOIRE","cod"); + my @listeNomsO = getTag("OBSERVATOIRE","nom"); + + if (!$dry) { + open(WRT, ">$FILE_OWNERS"); + printf(WRT "%s\n","=key|value"); + printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); + $i = 0; + for (@listeCodesO) { + printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); + $i += 1; + } + close(WRT); + } else { print "would build $FILE_OWNERS with codes @listeCodesO\n" }; + +# For the migration process, each FORM is identified by an existing +# "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. +# Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and +# a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to +# this FORM. +# Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and +# PROCS definitions of their 'frm' attribute +# my %F; - my @formsconfs = qx(ls $confpath/reseaux*.conf); - for my $f (@formsconfs) { - chomp($f); - # following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) - #my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); - my $ucf = uc($f); - $ucf =~ s!$confpath/reseaux(.*).conf!$1!gi; - - # ID3 => FORM hash - open(RDR, "<$f") or die "open $f failed: $!\n"; - while() { - chomp; - if (! /^#/) { $F{$_} = $ucf; } - } - close(RDR); - - # FORMNAME directory - printf("%+6d creating %s\n", time-$t0, "$PATH_FORMS/$ucf"); - if ($dry) {print "would mkdir -p $PATH_FORMS/$ucf\n"} else { qx(mkdir -p $PATH_FORMS/$ucf) }; - # build the FORMNAME.conf from WEBOBS.conf related statements - my $pgrep = " \"^$ucf"."_|_"."$ucf\" $confpath/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; - qx(grep -P $pgrep); - # move the FORM associated files to the brand new FORM/FORMNAME directory - $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $confpath/WEBOBS.conf"; - my @l = qx(grep -P $pgrep); - for (@l) { - chomp; - s/(^.*\|)//g; - if ($dry) {print "would mv $confpath/$_ $PATH_FORMS/$ucf/\n"} else { qx(mv $confpath/$_ $PATH_FORMS/$ucf/) }; - } - } - - # NETWORKS --> VIEWS/xxx and PROCS/xxx - # - for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { - my ($res,$code,$value) = split (/\|/,$_); - $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### - $G{$res}{$code} = $value; - } - printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); - for $g (keys (%G)) { - # - # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined - # - if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2) { - my $r; - if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; - my $path = "$PATH_PROCS/$g/$g.conf"; - printf("%+6d created %s \n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"nom|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"ftp|$G{$g}{ftp}\n"); - push(@out,"utc|$G{$g}{utc}\n"); - push(@out,"ext|$G{$g}{ext}\n"); - push(@out,"dec|$G{$g}{dec}\n"); - push(@out,"cum|$G{$g}{cum}\n"); - push(@out,"fmt|$G{$g}{fmt}\n"); - push(@out,"mks|$G{$g}{mks}\n"); - push(@out,"ico|$G{$g}{ico}\n"); - $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); - push(@out,"cro|TBD\n"); - push(@out,"lnk|$G{$g}{lnk}\n"); - push(@out,"ddb|$G{$g}{ddb}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - foreach my $k (keys %F) { - if ($o.$c eq $k) { - $formslist .= $F{$k}." " ; - if ($dry) { print "would ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}\n"} else { qx(ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}) }; - } - } - migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); - } - } - } - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"frm|$formslist\n");} - if ($dislist ne "") { push(@out,"dis|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - # - # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' - # - if (defined($G{$g}{net}) and $G{$g}{net} != 0) { - if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { - print "No ID3 (missing obs and/or cod) for $g "; - # my $in = ; - # chomp($in); - # if (length($in) != 3) { - print " - $g skipped, NOT migrated\n"; - next; - # } - # $G{$g}{obs} = substr($in,0,1); - # $G{$g}{cod} = substr($in,1,2); - } - if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; - my $path = "$PATH_VIEWS/$g/$g.conf"; - printf("%+6d created %s\n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"nom|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"own|$G{$g}{obs}\n"); - push(@out,"snm|$G{$g}{snm}\n"); - push(@out,"ssz|$G{$g}{ssz}\n"); - push(@out,"rvb|$G{$g}{rvb}\n"); - push(@out,"map|$G{$g}{map}\n"); - push(@out,"htm|$G{$g}{htm}\n"); - push(@out,"web|$G{$g}{web}\n"); - push(@out,"typ|$G{$g}{typ}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # + handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - #foreach my $k (keys %F) { - # if ($o.$c eq $k) { - # $formslist .= $F{$k}." "; - # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); - # } - #} - migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); - } - } - } - my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"frm|$formslist\n");} - if ($dislist ne "") { push(@out,"dis|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - } # end for $g (keys (%G)) - - printf("\n\n%+6d M2G.0 summary:\n", time-$t0); - printf(" ------------------\n"); - if (!$dry) { - printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); - printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); - printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); - printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); - print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); - print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); - print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); - for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; - for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; - print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; - } - - printf("\n%+6d M2G.0 done.\n", time-$t0); - #close(STDOUT); - -} + my @formsconfs = qx(ls $confpath/reseaux*.conf); + for my $f (@formsconfs) { + chomp($f); + +# following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) +#my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); + my $ucf = uc($f); + $ucf =~ s!$confpath/reseaux(.*).conf!$1!gi; + + # ID3 => FORM hash + open(RDR, "<$f") or die "open $f failed: $!\n"; + while() { + chomp; + if (! /^#/) { $F{$_} = $ucf; } + } + close(RDR); + + # FORMNAME directory + printf("%+6d creating %s\n", time-$t0, "$PATH_FORMS/$ucf"); + if ($dry) {print "would mkdir -p $PATH_FORMS/$ucf\n"} else { qx(mkdir -p $PATH_FORMS/$ucf) }; + + # build the FORMNAME.conf from WEBOBS.conf related statements + my $pgrep = " \"^$ucf"."_|_"."$ucf\" $confpath/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; + qx(grep -P $pgrep); + + # move the FORM associated files to the brand new FORM/FORMNAME directory + $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $confpath/WEBOBS.conf"; + my @l = qx(grep -P $pgrep); + for (@l) { + chomp; + s/(^.*\|)//g; + if ($dry) {print "would mv $confpath/$_ $PATH_FORMS/$ucf/\n"} else { qx(mv $confpath/$_ $PATH_FORMS/$ucf/) }; + } + } + + # NETWORKS --> VIEWS/xxx and PROCS/xxx + # + for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { + my ($res,$code,$value) = split (/\|/,$_); + $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### + $G{$res}{$code} = $value; + } + printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); + for $g (keys (%G)) { + # + # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined + # + if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2) { + my $r; + if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; + my $path = "$PATH_PROCS/$g/$g.conf"; + printf("%+6d created %s \n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"nom|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"ftp|$G{$g}{ftp}\n"); + push(@out,"utc|$G{$g}{utc}\n"); + push(@out,"ext|$G{$g}{ext}\n"); + push(@out,"dec|$G{$g}{dec}\n"); + push(@out,"cum|$G{$g}{cum}\n"); + push(@out,"fmt|$G{$g}{fmt}\n"); + push(@out,"mks|$G{$g}{mks}\n"); + push(@out,"ico|$G{$g}{ico}\n"); + $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); + push(@out,"cro|TBD\n"); + push(@out,"lnk|$G{$g}{lnk}\n"); + push(@out,"ddb|$G{$g}{ddb}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + foreach my $k (keys %F) { + if ($o.$c eq $k) { + $formslist .= $F{$k}." " ; + if ($dry) { print "would ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}\n"} else { qx(ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}) }; + } + } + migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); + } + } + } + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"frm|$formslist\n");} + if ($dislist ne "") { push(@out,"dis|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + # + # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' + # + if (defined($G{$g}{net}) and $G{$g}{net} != 0) { + if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { + print "No ID3 (missing obs and/or cod) for $g "; + + # my $in = ; + # chomp($in); + # if (length($in) != 3) { + print " - $g skipped, NOT migrated\n"; + next; + + # } + # $G{$g}{obs} = substr($in,0,1); + # $G{$g}{cod} = substr($in,1,2); + } + if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; + my $path = "$PATH_VIEWS/$g/$g.conf"; + printf("%+6d created %s\n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"nom|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"own|$G{$g}{obs}\n"); + push(@out,"snm|$G{$g}{snm}\n"); + push(@out,"ssz|$G{$g}{ssz}\n"); + push(@out,"rvb|$G{$g}{rvb}\n"); + push(@out,"map|$G{$g}{map}\n"); + push(@out,"htm|$G{$g}{htm}\n"); + push(@out,"web|$G{$g}{web}\n"); + push(@out,"typ|$G{$g}{typ}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # + handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + + #foreach my $k (keys %F) { + # if ($o.$c eq $k) { + # $formslist .= $F{$k}." "; + # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); + # } + #} + migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); + } + } + } + my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"frm|$formslist\n");} + if ($dislist ne "") { push(@out,"dis|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + } # end for $g (keys (%G)) + + printf("\n\n%+6d M2G.0 summary:\n", time-$t0); + printf(" ------------------\n"); + if (!$dry) { + printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); + printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); + printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); + printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); + print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); + print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); + print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); + for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; + for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; + print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; + } + + printf("\n%+6d M2G.0 done.\n", time-$t0); + + #close(STDOUT); + +} sub MIGRATE_1_NODESXLATE { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_NODESXLATE\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^NOM\|/NAME|/; - s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; - s/^VALIDE\|/VALID\|/; - # next 3 to change | to \| except first one - s/^(.*?)\|/$1¤/; - s/\|/\\\|/g; - s/^(.*?)¤/$1\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_NODESXLATE\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^NOM\|/NAME|/; + s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; + s/^VALIDE\|/VALID\|/; + + # next 3 to change | to \| except first one + s/^(.*?)\|/$1¤/; + s/\|/\\\|/g; + s/^(.*?)¤/$1\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_1_FORMSCONF { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_FORMSCONF\n"; - $t0 = time; - my (@liste, $i); - my @lsd = qx(ls -d $PATH_FORMS/*); - chomp(@lsd); - foreach (@lsd) { - s/.*FORMS\///g; - my $form = $_; - my $prefix = $form."_"; - open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; - my @f = ; - close RDR; - for (@f) { - s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; - s/$prefix//; - } - unshift(@f, "=key|value\n"); # add the new readCfg format-specification - if (!$dry) { - open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; - for (@f) { - print WRT $_; - } - close WRT; - } else { print "would set [\n @f \n] "} - print "$PATH_FORMS/$form/$form.conf done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_FORMSCONF\n"; + $t0 = time; + my (@liste, $i); + my @lsd = qx(ls -d $PATH_FORMS/*); + chomp(@lsd); + foreach (@lsd) { + s/.*FORMS\///g; + my $form = $_; + my $prefix = $form."_"; + open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; + my @f = ; + close RDR; + for (@f) { + s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; + s/$prefix//; + } + unshift(@f, "=key|value\n"); # add the new readCfg format-specification + if (!$dry) { + open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; + for (@f) { + print WRT $_; + } + close WRT; + } else { print "would set [\n @f \n] "} + print "$PATH_FORMS/$form/$form.conf done\n"; + } } sub MIGRATE_2_NODESFEATURES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_2_NODESFEATURES\n"; - $t0 = time; - my @nodes = <$PATH_NODES/*>; - chomp(@nodes); - for my $n (@nodes) { - if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} - if ($?) { print "Couldn't create $n/FEATURES; $!" ; next } - my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); - die "Couldn't find txt's; $!" if ($?); - chomp(@files); - for my $f (@files) { - if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv "$f" "$n/FEATURES/");} - die "Couldn't move $f to $n/FEATURES; $? " if ($?); - } - print "$n done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_2_NODESFEATURES\n"; + $t0 = time; + my @nodes = <$PATH_NODES/*>; + chomp(@nodes); + for my $n (@nodes) { + if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} + if ($?) { print "Couldn't create $n/FEATURES; $!" ; next } + my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); + die "Couldn't find txt's; $!" if ($?); + chomp(@files); + for my $f (@files) { + if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv "$f" "$n/FEATURES/");} + die "Couldn't move $f to $n/FEATURES; $? " if ($?); + } + print "$n done\n"; + } } sub MIGRATE_3_FORMSNET2GRIDS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; - my @forms= <$PATH_FORMS/*> ; - foreach (@forms) { - my $formname = basename($_); - if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } - else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$formname.conf) } - my @file = <$_/reseaux*.conf> ; - for my $fn (@file) { - open RDR, "<$fn" or die "Couldn't open $fn : $!"; - my @f = ; - close RDR; - for (@f) { - next if m/^#/ ; - next if m/^$/; - chomp(); - my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); - if (scalar(@res) > 0) { - $res[0] = basename($res[0]); - $res[0] =~ s/\.conf//; - $res[0] =~ s/:.*$//g; - chomp($res[0]); - if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } - else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } - } - } - print "$fn done.\n"; - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; + my @forms= <$PATH_FORMS/*> ; + foreach (@forms) { + my $formname = basename($_); + if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } + else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$formname.conf) } + my @file = <$_/reseaux*.conf> ; + for my $fn (@file) { + open RDR, "<$fn" or die "Couldn't open $fn : $!"; + my @f = ; + close RDR; + for (@f) { + next if m/^#/ ; + next if m/^$/; + chomp(); + my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); + if (scalar(@res) > 0) { + $res[0] = basename($res[0]); + $res[0] =~ s/\.conf//; + $res[0] =~ s/:.*$//g; + chomp($res[0]); + if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } + else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } + } + } + print "$fn done.\n"; + } + } } sub MIGRATE_3_NORMNODES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_NORMNODES\n"; - print "> NOP\n"; + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_NORMNODES\n"; + print "> NOP\n"; } sub MIGRATE_4_ALIASDASH { + # late request: NODEs having their 'ALIAS' or 'DATA_FILE' set to '-' should NOT be included in PROC(s) - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_4_ALIASDASH\n"; - $t0 = time; - my @files = <$PATH_NODES/*/*.cnf>; #/ - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { - my $p = ''; - for (@f) { if (/PROC\|/) { $p = $_ } } ; - chomp($p); - if ($dry) { - print "would sed -ie \'/PROC|/d\' $_" ; - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; - } - else { - qx( sed -ie \'/PROC|/d\' $_ ); - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); - } - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_4_ALIASDASH\n"; + $t0 = time; + my @files = <$PATH_NODES/*/*.cnf>; #/ + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { + my $p = ''; + for (@f) { if (/PROC\|/) { $p = $_ } } ; + chomp($p); + if ($dry) { + print "would sed -ie \'/PROC|/d\' $_" ; + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; + } + else { + qx( sed -ie \'/PROC|/d\' $_ ); + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); + } + } + } } sub MIGRATE_5_FID { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_5_FID\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^DATA_FILE\|/FID|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_5_FID\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^DATA_FILE\|/FID|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_6_PROCKEYS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_6_PROCKEYS\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_PROCS/*/*.conf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - my $ixd=0; $ixd++ until($f[$ixd] =~ /^cro/); splice(@f, $ixd, 1); - for (@f) { - s/^cum\|/CUMULATELIST\|/; - s/^dec\|/DECIMATELIST\|/; - s/^dis\|/DOMAIN|/; - s/^ext\|/TIMESCALELIST|/; - s/^fmt\|/DATESTRLIST\|/; - s/^frm\|/FORM\|/; - s/^ftp\|/RAWDATA\|/; - s/^ico\|/THUMBNAIL\|/; - s/^lnk\|/URL\|/; - s/^mks\|/MARKERSIZELIST\|/; - s/^nom\|/NAME\|/; - s/^req\|/REQUEST\|/; - s/^utc\|/TZ\|/; - s/^STA\|/NODESLIST\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_6_PROCKEYS\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_PROCS/*/*.conf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + my $ixd=0; $ixd++ until($f[$ixd] =~ /^cro/); splice(@f, $ixd, 1); + for (@f) { + s/^cum\|/CUMULATELIST\|/; + s/^dec\|/DECIMATELIST\|/; + s/^dis\|/DOMAIN|/; + s/^ext\|/TIMESCALELIST|/; + s/^fmt\|/DATESTRLIST\|/; + s/^frm\|/FORM\|/; + s/^ftp\|/RAWDATA\|/; + s/^ico\|/THUMBNAIL\|/; + s/^lnk\|/URL\|/; + s/^mks\|/MARKERSIZELIST\|/; + s/^nom\|/NAME\|/; + s/^req\|/REQUEST\|/; + s/^utc\|/TZ\|/; + s/^STA\|/NODESLIST\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_6_VIEWKEYS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_6_VIEWKEYS\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_VIEWS/*/*.conf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^dis\|/DOMAIN|/; - s/^htm\|/URL|/; - s/^map\|/MAPLIST\|/; - s/^nom\|/NAME\|/; - s/^own\|/OWNCODE\|/; - s/^req\|/REQUEST\|/; - s/^rvb\|/NODERGB\|/; - s/^snm\|/NODENAME\|/; - s/^ssz\|/NODESIZE\|/; - s/^typ\|/TYPE\|/; - s/^web\|/DISPLAY\|/; - s/^STA\|/NODESLIST\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_6_VIEWKEYS\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_VIEWS/*/*.conf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^dis\|/DOMAIN|/; + s/^htm\|/URL|/; + s/^map\|/MAPLIST\|/; + s/^nom\|/NAME\|/; + s/^own\|/OWNCODE\|/; + s/^req\|/REQUEST\|/; + s/^rvb\|/NODERGB\|/; + s/^snm\|/NODENAME\|/; + s/^ssz\|/NODESIZE\|/; + s/^typ\|/TYPE\|/; + s/^web\|/DISPLAY\|/; + s/^STA\|/NODESLIST\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } - # helper function to extract DISCIPLINE & OBSERVATOIRE definitions # sub getTag { - my($stanza, $tag) = @_; - my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); - $l[0] =~ s/^\w\*|\w*\|//gi; - $l[0] =~ s/\'|{|}//gi; - return split(/,/,$l[0]); + my($stanza, $tag) = @_; + my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); + $l[0] =~ s/^\w\*|\w*\|//gi; + $l[0] =~ s/\'|{|}//gi; + return split(/,/,$l[0]); } - # STATIONS (called from main process, for each grid/proc, for which # stations are identified by the 3 digits legacy code 'obs+cod' # 3 arguments: PROC or VIEW ($type) # name of PROC or VIEW ($name) # id 3 digits to identify stations ($id3) sub migID3Stations { - my ($type, $name, $id3, $s1, $s2) = @_; - opendir(DIR, $PATH_NODES) or die "couldn't opendir $PATH_NODES : $!"; - my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); - closedir(DIR); - my ($dir, $o); - for $dir (@dirs) { - if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { - if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { - printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "=key|value\n"); - print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - while () { # use all existing lines, replacing ... - s/\s/\|/; # ... 1st blank with | delimiter - print(WRT $_); # - } - print(WRT "$type|$name\n"); # new link to PROC or GRID line - print(WRT "$s1\n"); - if (defined($s2)) { print(WRT "$s2\n") }; - close(WRT); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - } else { - printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - my $typefound=0; - do { - local $^I='~'; - local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); - while(<>){ - chomp; - if (/^($type)\|(.*)/) { - $_ = "$type|$2,$name\n"; - $typefound++; - } - $_ .= "\n"; - print; - } - }; - if ($typefound == 0) { - if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "$type|$name\n"); - close(WRT); - } - } - qx(rm $PATH_NODES/$dir/$dir.cnf~); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - close(RDR); - } - } + my ($type, $name, $id3, $s1, $s2) = @_; + opendir(DIR, $PATH_NODES) or die "couldn't opendir $PATH_NODES : $!"; + my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); + closedir(DIR); + my ($dir, $o); + for $dir (@dirs) { + if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { + if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { + printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "=key|value\n"); + print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + while () { # use all existing lines, replacing ... + s/\s/\|/; # ... 1st blank with | delimiter + print(WRT $_); # + } + print(WRT "$type|$name\n"); # new link to PROC or GRID line + print(WRT "$s1\n"); + if (defined($s2)) { print(WRT "$s2\n") }; + close(WRT); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + } else { + printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + my $typefound=0; + do { + local $^I='~'; + local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); + while(<>){ + chomp; + if (/^($type)\|(.*)/) { + $_ = "$type|$2,$name\n"; + $typefound++; + } + $_ .= "\n"; + print; + } + }; + if ($typefound == 0) { + if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "$type|$name\n"); + close(WRT); + } + } + qx(rm $PATH_NODES/$dir/$dir.cnf~); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + close(RDR); + } + } } 1; diff --git a/SETUP/ddump.pm b/SETUP/ddump.pm index f0cd809c..64a99b6b 100755 --- a/SETUP/ddump.pm +++ b/SETUP/ddump.pm @@ -1,33 +1,32 @@ #!/usr/bin/perl sub ddumpSyms { - foreach my $entry ( keys %main:: ) { - print "Name: $entry\n"; - print "\t"; - print "scalar ".\${$entry}." ${$entry}" if defined ${$entry}; - print ",array " if defined @{$entry}; - print ",hash " if defined %{$entry}; - print ",sub " if defined &{$entry}; - print "\n"; - } + foreach my $entry ( keys %main:: ) { + print "Name: $entry\n"; + print "\t"; + print "scalar ".\${$entry}." ${$entry}" if defined ${$entry}; + print ",array " if defined @{$entry}; + print ",hash " if defined %{$entry}; + print ",sub " if defined &{$entry}; + print "\n"; + } } sub Syms { - my ($pkgName) = @_; - *stash = *{"${pkgName}::"}; - foreach my $entry ( keys %stash ) { - print "Name: $entry\n"; - print "\t".\${$entry}." \n" if defined ${$entry}; - print "\t".\@{$entry}." \n" if defined @{$entry}; - print "\t".\%{$entry}." \n" if defined %{$entry}; - print "\t".\&{$entry}." \n" if defined &{$entry}; - $entry =~ s/^_ Date: Wed, 5 Feb 2025 11:39:49 +0100 Subject: [PATCH 06/68] reindent perl code --- CODE/cgi-bin/Gazette.pl | 265 +- CODE/cgi-bin/OSM.pl | 74 +- CODE/cgi-bin/Welcome.pl | 167 +- CODE/cgi-bin/cedit.pl | 108 +- CODE/cgi-bin/cgiwoc.pl | 8 +- CODE/cgi-bin/changepassword.pl | 113 +- CODE/cgi-bin/deleteB3.pl | 78 +- CODE/cgi-bin/editMC3.pl | 414 ++-- CODE/cgi-bin/fedit.pl | 366 +-- CODE/cgi-bin/formBOJAP.pl | 251 +- CODE/cgi-bin/formCLB.pl | 177 +- CODE/cgi-bin/formDISTANCE.pl | 228 +- CODE/cgi-bin/formEAUX.pl | 218 +- CODE/cgi-bin/formEXTENSO.pl | 337 +-- CODE/cgi-bin/formGAZ.pl | 260 +- CODE/cgi-bin/formGENFORM.pl | 467 ++-- CODE/cgi-bin/formGRID.pl | 206 +- CODE/cgi-bin/formGRIDMAPS.pl | 184 +- CODE/cgi-bin/formNODE.pl | 1017 ++++---- CODE/cgi-bin/formNOVAC.pl | 181 +- CODE/cgi-bin/formPLUVIO.pl | 134 +- CODE/cgi-bin/formRAINWATER.pl | 294 ++- CODE/cgi-bin/formREQ.pl | 333 +-- CODE/cgi-bin/formRIVERS.pl | 309 ++- CODE/cgi-bin/formSOILSOLUTION.pl | 330 ++- CODE/cgi-bin/formUPLOAD.pl | 90 +- CODE/cgi-bin/formVEHICLES.pl | 169 +- CODE/cgi-bin/gedit.pl | 105 +- CODE/cgi-bin/geomNODE.pl | 9 +- CODE/cgi-bin/get_gml_m3g.pl | 78 +- CODE/cgi-bin/gridsMgr.pl | 350 +-- CODE/cgi-bin/gvTransit.pl | 242 +- CODE/cgi-bin/index.pl | 118 +- CODE/cgi-bin/listGRIDS.pl | 692 +++--- CODE/cgi-bin/mailB3.pl | 130 +- CODE/cgi-bin/mailInfo_OVPF.pl | 534 +++-- CODE/cgi-bin/mailInfo_REVOSIMA.pl | 486 ++-- CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl | 395 +-- CODE/cgi-bin/mc3.pl | 2264 +++++++++--------- CODE/cgi-bin/mseedreq.pl | 348 +-- CODE/cgi-bin/nedit.pl | 105 +- CODE/cgi-bin/nloc.pl | 131 +- CODE/cgi-bin/nsearch.pl | 466 ++-- CODE/cgi-bin/postBOJAP.pl | 92 +- CODE/cgi-bin/postCLB.pl | 371 +-- CODE/cgi-bin/postDISTANCE.pl | 100 +- CODE/cgi-bin/postEAUX.pl | 108 +- CODE/cgi-bin/postEVENTNODE.pl | 241 +- CODE/cgi-bin/postEXTENSO.pl | 108 +- CODE/cgi-bin/postGAZ.pl | 108 +- CODE/cgi-bin/postGRID.pl | 269 ++- CODE/cgi-bin/postGRIDMAPS.pl | 114 +- CODE/cgi-bin/postNODE.pl | 501 ++-- CODE/cgi-bin/postNOVAC.pl | 123 +- CODE/cgi-bin/postPLUVIO.pl | 111 +- CODE/cgi-bin/postRAINWATER.pl | 108 +- CODE/cgi-bin/postREQ.pl | 152 +- CODE/cgi-bin/postRIVERS.pl | 108 +- CODE/cgi-bin/postSOILSOLUTION.pl | 108 +- CODE/cgi-bin/postTHEIA.pl | 43 +- CODE/cgi-bin/postUPLOAD.pl | 118 +- CODE/cgi-bin/postVEHICLES.pl | 108 +- CODE/cgi-bin/predict.pl | 6 +- CODE/cgi-bin/register.pl | 276 ++- CODE/cgi-bin/relayMgr.pl | 167 +- CODE/cgi-bin/schedulerLogs.pl | 20 +- CODE/cgi-bin/schedulerMgr.pl | 270 ++- CODE/cgi-bin/schedulerRuns.pl | 420 ++-- CODE/cgi-bin/sefran3.pl | 1586 ++++++------ CODE/cgi-bin/showBOJAP.pl | 342 +-- CODE/cgi-bin/showDISTANCE.pl | 307 +-- CODE/cgi-bin/showEAUX.pl | 539 ++--- CODE/cgi-bin/showEXTENSO.pl | 502 ++-- CODE/cgi-bin/showFISSURO.pl | 552 ++--- CODE/cgi-bin/showGAZ.pl | 330 +-- CODE/cgi-bin/showGENFORM.pl | 593 +++-- CODE/cgi-bin/showGRID.pl | 1046 ++++---- CODE/cgi-bin/showNODE.pl | 973 ++++---- CODE/cgi-bin/showNODES.pl | 72 +- CODE/cgi-bin/showNOVAC.pl | 197 +- CODE/cgi-bin/showOUTG.pl | 730 +++--- CODE/cgi-bin/showOUTR.pl | 183 +- CODE/cgi-bin/showPLUVIO.pl | 274 +-- CODE/cgi-bin/showQRcode.pl | 4 +- CODE/cgi-bin/showRAINWATER.pl | 450 ++-- CODE/cgi-bin/showREQ.pl | 118 +- CODE/cgi-bin/showRIVERS.pl | 533 +++-- CODE/cgi-bin/showSISMOBUL.pl | 263 +- CODE/cgi-bin/showSOILSOLUTION.pl | 436 ++-- CODE/cgi-bin/showTHEIA.pl | 306 +-- CODE/cgi-bin/showVEHICLES.pl | 231 +- CODE/cgi-bin/training.pl | 5 +- CODE/cgi-bin/usersMgr.pl | 728 +++--- CODE/cgi-bin/vedit.pl | 657 ++--- CODE/cgi-bin/viewMAN.pl | 17 +- CODE/cgi-bin/viewMFILE.pl | 14 +- CODE/cgi-bin/viewPOD.pl | 21 +- CODE/cgi-bin/vsearch.pl | 689 +++--- CODE/cgi-bin/wdir.pl | 95 +- CODE/cgi-bin/wedit.pl | 109 +- CODE/cgi-bin/wikiPage.pl | 38 +- CODE/cgi-bin/wow.pl | 366 +-- CODE/cgi-bin/wpage.pl | 61 +- CODE/cgi-bin/xedit.pl | 120 +- CODE/perl/exposerc.pl | 25 +- CODE/perl/fbgstd.pl | 22 +- CODE/perl/fdsnws-event2mc3.pl | 724 +++--- CODE/perl/jobq.pl | 31 +- CODE/perl/lib/Config.pm | 298 +-- CODE/perl/lib/DBForm.pm | 298 +-- CODE/perl/lib/Dates.pm | 389 +-- CODE/perl/lib/Events.pm | 555 ++--- CODE/perl/lib/Form.pm | 214 +- CODE/perl/lib/GML.pm | 449 ++-- CODE/perl/lib/Gazette.pm | 1217 +++++----- CODE/perl/lib/Grids.pm | 704 +++--- CODE/perl/lib/Mapping.pm | 592 +++-- CODE/perl/lib/QML.pm | 127 +- CODE/perl/lib/Scheduler.pm | 127 +- CODE/perl/lib/Search.pm | 245 +- CODE/perl/lib/Suds.pm | 291 +-- CODE/perl/lib/Users.pm | 606 ++--- CODE/perl/lib/Utils.pm | 397 +-- CODE/perl/lib/VolcAuto.pm | 67 +- CODE/perl/lib/Wiki.pm | 349 +-- CODE/perl/lib/XML2.pm | 139 +- CODE/perl/lib/i18n.pm | 34 +- CODE/perl/navrc2html.pl | 35 +- CODE/perl/notify.pl | 15 +- CODE/perl/postboard.pl | 576 ++--- CODE/perl/scheduler.pl | 1449 +++++------ CODE/perl/seiscomp2mc3.pl | 767 +++--- CODE/perl/sendTHEIA.pl | 621 ++--- CODE/perl/volcauto2mc.pl | 6 +- CODE/perl/wiki2mmd.pl | 23 +- CODE/perl/woc.pl | 1329 +++++----- CODE/perl/wsudp.pl | 85 +- DOC/devtips/benchcfg.pl | 18 +- DOC/devtips/benchdate.pl | 12 +- DOC/devtips/benchfile.pl | 67 +- DOC/devtips/checkIP.pm | 58 +- DOC/devtips/sfork.pl | 67 +- SETUP/IMP.pm | 976 ++++---- SETUP/M2G.pm | 1170 ++++----- SETUP/ddump.pm | 43 +- 145 files changed, 23347 insertions(+), 22738 deletions(-) diff --git a/CODE/cgi-bin/Gazette.pl b/CODE/cgi-bin/Gazette.pl index 4e1f7380..665feeca 100755 --- a/CODE/cgi-bin/Gazette.pl +++ b/CODE/cgi-bin/Gazette.pl @@ -103,12 +103,16 @@ =head1 LOCALIZATION # ---- special requests before querying/displaying gazette rows # ------------------------------------------------------------------ my $setmsg = ""; + # ---- download an iCal file; will not return here getical($QryParm->{'getical'}) if defined($QryParm->{'getical'}); + # ---- getId() doesn't format results; will not return here getId($QryParm->{'getid'}) if ($QryParm->{'getid'} ne "") ; + # ---- DB update 'setid' (article row $setmsg = setId($QryParm->{'setid'}) if ($QryParm->{'setid'} ne ""); + # ---- DB delete 'delid' (article) row $setmsg = delId($QryParm->{'delid'}) if ($QryParm->{'delid'} ne ""); ### ---- if no select/display parms, special requests return DB update message only @@ -120,6 +124,7 @@ =head1 LOCALIZATION ## } ##} $setmsg = "".$today->strftime('%Y-%m-%d %H:%M:%S')." $__{'last DB update'}: $setmsg" if ($setmsg ne ""); + # ---- end of special requests # ------------------------------------------------------------------ @@ -135,21 +140,21 @@ =head1 LOCALIZATION # ---- keywords are a subset of those handled by Gazette.js function shortcuts() # ---- (only for coherence/documentation ... ie. could differ) if ($QryParm->{'gdate'} =~ /today/i) { - $QryParm->{'gdate'} = $today->strftime('%Y-%m-%d'); + $QryParm->{'gdate'} = $today->strftime('%Y-%m-%d'); } elsif ($QryParm->{'gdate'} =~ /tomorrow/i) { - $QryParm->{'gdate'} = ($today+86400)->strftime('%Y-%m-%d'); + $QryParm->{'gdate'} = ($today+86400)->strftime('%Y-%m-%d'); } elsif ($QryParm->{'gdate'} =~ /yesterday/i) { - $QryParm->{'gdate'} = ($today-86400)->strftime('%Y-%m-%d'); + $QryParm->{'gdate'} = ($today-86400)->strftime('%Y-%m-%d'); } elsif ($QryParm->{'gdate'} =~ /allyear/i) { - $QryParm->{'gdate'} = $today->year."-01-01,".$today->year."-12-31"; + $QryParm->{'gdate'} = $today->year."-01-01,".$today->year."-12-31"; } elsif ($QryParm->{'gdate'} =~ /currWeek|thisweek/i) { - my $monday = $today-(($today->_wday+6)%7)*86400; - my $sunday = $today+(6-($today->_wday+6)%7)*86400; - $QryParm->{'gdate'} = $monday->strftime("%Y-%m-%d").",".$sunday->strftime("%Y-%m-%d"); + my $monday = $today-(($today->_wday+6)%7)*86400; + my $sunday = $today+(6-($today->_wday+6)%7)*86400; + $QryParm->{'gdate'} = $monday->strftime("%Y-%m-%d").",".$sunday->strftime("%Y-%m-%d"); } # ---- some defaults if needed for Gazette configuration @@ -168,12 +173,12 @@ =head1 LOCALIZATION my $monthnames = join(',',map { l2u((Time::Piece->strptime("$_",'%m'))->strftime('%B')) } (1..12)) ; my %prez = ('calendar' => $__{'Calendar'}, - 'dateList' => $__{'List by dates'}, - 'categoryList' => $__{'List by categories'}, - 'dump' => 'dump', - 'stats' => 'stats', - 'ical' => 'iCalendar', - ) ; + 'dateList' => $__{'List by dates'}, + 'categoryList' => $__{'List by categories'}, + 'dump' => 'dump', + 'stats' => 'stats', + 'ical' => 'iCalendar', + ) ; # ---- ... for wodp javascript my $wodp_d2 = "[".join(',',map { "'".substr($_,0,2)."'" } split(/,/,$daynames))."]"; @@ -183,6 +188,7 @@ =head1 LOCALIZATION open(FILE, "<$WEBOBS{FILE_DAYSOFF}") || die "$__{'failed opening holidays definitions'}\n"; while() { push(@holidaysdef,l2u($_)) if ($_ !~/^(#|$)/); }; close(FILE); chomp(@holidaysdef); + # check/translate holidaysdef quote and accents ? my $wodp_holidays = "[".join(',',map { my ($d,$t)=split(/\|/,$_); "{d: \"$d\", t:\"$t\"}" } @holidaysdef)."]"; @@ -196,20 +202,20 @@ =head1 LOCALIZATION my ($d1, $d2) = split(/,/,$QryParm->{'gdate'}); my ($d1dt, $d2dt) = ''; if (!$d1) { - $d1 = $today->strftime('%Y-%m-%d'); - $d1dt = Time::Piece->strptime($d1,'%Y-%m-%d'); - $d2 = $d1; - $d2dt = Time::Piece->strptime($d2,'%Y-%m-%d'); - $reqdate = l2u($d1dt->strftime($fmt_long_date)); + $d1 = $today->strftime('%Y-%m-%d'); + $d1dt = Time::Piece->strptime($d1,'%Y-%m-%d'); + $d2 = $d1; + $d2dt = Time::Piece->strptime($d2,'%Y-%m-%d'); + $reqdate = l2u($d1dt->strftime($fmt_long_date)); } else { - $d1dt = Time::Piece->strptime($d1,'%Y-%m-%d'); - if (!$d2) { - $d2 = $d1; - $reqdate = l2u($d1dt->strftime($fmt_long_date)); - } else { - $d2dt = Time::Piece->strptime($d2,'%Y-%m-%d'); - $reqdate = "$__{'from'} ".l2u($d1dt->strftime($fmt_date))." $__{'to'} ". l2u($d2dt->strftime($fmt_date)); - } + $d1dt = Time::Piece->strptime($d1,'%Y-%m-%d'); + if (!$d2) { + $d2 = $d1; + $reqdate = l2u($d1dt->strftime($fmt_long_date)); + } else { + $d2dt = Time::Piece->strptime($d2,'%Y-%m-%d'); + $reqdate = "$__{'from'} ".l2u($d1dt->strftime($fmt_date))." $__{'to'} ". l2u($d2dt->strftime($fmt_date)); + } } # ---- change the default "verbose" date expression based on wodpdesc if it exists @@ -219,13 +225,14 @@ =head1 LOCALIZATION # ---- now build the article's page ! if (grep /\Q$QryParm->{'gview'}/i , keys(%prez)) { - #@gazette = WebObs::Gazette::Show(view=>$QryParm->{'gview'},from=>$d1,to=>$d2,categories=>$QryParm->{'gcategory'},textfilter=>$QryParm->{'gfilter'},jseditor=>'openPopup'); - @gazette = WebObs::Gazette::Show(view=>$QryParm->{'gview'}, - from=>$d1,to=>$d2, - categories=>$QryParm->{'gcategory'}, - textfilter=>$QryParm->{'gfilter'}, - jseditor=>'openPopup',jsevent=>'showobject'); - @gazette = ("

          $empty

          ") if (!@gazette); + +#@gazette = WebObs::Gazette::Show(view=>$QryParm->{'gview'},from=>$d1,to=>$d2,categories=>$QryParm->{'gcategory'},textfilter=>$QryParm->{'gfilter'},jseditor=>'openPopup'); + @gazette = WebObs::Gazette::Show(view=>$QryParm->{'gview'}, + from=>$d1,to=>$d2, + categories=>$QryParm->{'gcategory'}, + textfilter=>$QryParm->{'gfilter'}, + jseditor=>'openPopup',jsevent=>'showobject'); + @gazette = ("

          $empty

          ") if (!@gazette); } # ---- Start HTML page output @@ -233,14 +240,14 @@ =head1 LOCALIZATION print $cgi->header(-type=>'text/html',-charset=>'utf-8'); print '', "\n"; print "$GAZETTE{TITLE}\n", - "", - "", - "", - "", - "", - "", - "\n", - "" ; + "", + "", + "", + "", + "", + "", + "\n", + "" ; print "\n"; # ---- articles management form @@ -251,14 +258,15 @@ =head1 LOCALIZATION my %VUSERNAMES; my %IUSERNAMES; foreach (keys(%USERS)) { - my @grp = WebObs::Users::userListGroup($_); - my %gid = map { $_ => 1 } split(/,/,$GAZETTE{ACTIVE_GID}); - if ((%gid && grep { $gid{$_} } @grp) || (!%gid && isok($USERS{$_}{VALIDITY}))) { - $VUSERNAMES{$USERS{$_}{UID}} = $USERS{$_}{FULLNAME} - } else { - $IUSERNAMES{$USERS{$_}{UID}} = $USERS{$_}{FULLNAME} - } + my @grp = WebObs::Users::userListGroup($_); + my %gid = map { $_ => 1 } split(/,/,$GAZETTE{ACTIVE_GID}); + if ((%gid && grep { $gid{$_} } @grp) || (!%gid && isok($USERS{$_}{VALIDITY}))) { + $VUSERNAMES{$USERS{$_}{UID}} = $USERS{$_}{FULLNAME} + } else { + $IUSERNAMES{$USERS{$_}{UID}} = $USERS{$_}{FULLNAME} + } } + #DL-was:my $selusers = ""; map { $selusers .= "" } sort keys(%VUSERNAMES); my $selusers = ""; @@ -296,6 +304,7 @@ =head1 LOCALIZATION # ---- JavaScript inits my $jscat = "{".join(',',map { " \"$_\": \"$QCAT{$_}\"" } keys(%QCAT))."}"; + #DL-was:my $jsnames = "{".join(',',map { " \"$_\": \"$USERNAMES{$_}\"" } keys(%USERNAMES))."}"; my $jsnames = "{".join(',',map { " \"$_\": \"$VUSERNAMES{$_} ($_)\"" } sort keys(%VUSERNAMES))."}"; my $jsnamesI = "{".join(',',map { " \"$_\": \"$IUSERNAMES{$_} ($_)\"" } sort keys(%IUSERNAMES))."}"; @@ -324,55 +333,55 @@ =head1 LOCALIZATION print ""; print "
          \n"; - print "
        "; - print ""; - print "\n"; - print "\n"; - print "\n"; - print "
        "; - print "
        "; - print " {'gdate'}\" name=\"gdate\" id=\"gdate\"/>

        "; - # following 'shortcuts' values MUST MATCH those used/processed in Gazette.js,function shortcuts() - print "

        		"; - print " "; - print " "; - print " {'gfilter'}\">"; - print "\n"; - - if ($createOK) { - print ""; - print ""; - } - - print "
        "; -print ""; +print ""; +print ""; +print "\n"; +print "\n"; +print "\n"; +print "
        "; +print "
        "; +print " {'gdate'}\" name=\"gdate\" id=\"gdate\"/>

        "; + +# following 'shortcuts' values MUST MATCH those used/processed in Gazette.js,function shortcuts() +print "

        		"; +print " "; +print " "; +print " {'gfilter'}\">"; +print "\n"; + +if ($createOK) { + print ""; + print ""; +} +print "
        "; +print ""; # ---- display Gazette page # @@ -391,53 +400,53 @@ =head1 LOCALIZATION # ---- cleaned up some other housekeeping process # sub getical { - if (@_ == 1 && -f $_[0]) { - if (open(IN, "<$_[0]")) { - my @in = ; - close(IN); - print $cgi->header(-type=>'text/calendar', -attachment=>"$_[0]",-charset=>'utf-8'); - print @in; - } else { die "$__{'Could not open'} $_[0]" } - } else { die "$__{'invalid'} $_[0]" } - exit; + if (@_ == 1 && -f $_[0]) { + if (open(IN, "<$_[0]")) { + my @in = ; + close(IN); + print $cgi->header(-type=>'text/calendar', -attachment=>"$_[0]",-charset=>'utf-8'); + print @in; + } else { die "$__{'Could not open'} $_[0]" } + } else { die "$__{'invalid'} $_[0]" } + exit; } # ---- process a 'getid' query: simply return article #id row as json # sub getId { - print $cgi->header(-type=>'application/json',-charset=>'utf-8'); - print getArticle($_[0]); - exit; + print $cgi->header(-type=>'application/json',-charset=>'utf-8'); + print getArticle($_[0]); + exit; } # ---- process a 'setid' query: do the DB update, then back to normal page build processing # sub setId { - my $id = ($_[0] eq "-1") ? "null" : "$_[0]"; - (my $others = $QryParm->{'OTHERS'}) =~ s/\Q'\E/''/g; - (my $place = $QryParm->{'PLACE'}) =~ s/\Q'\E/''/g; - (my $subject = $QryParm->{'SUBJECT'}) =~ s/\Q'\E/''/g; - my $values = sprintf("%s,'%s','%s','%s','%s','%s','%s','%s','%s','%s'", - $id, - $QryParm->{'STARTDATE'}, - $QryParm->{'STARTTIME'}, - $QryParm->{'ENDDATE'}, - $QryParm->{'ENDTIME'}, - $QryParm->{'CATEGORY'}, - $QryParm->{'UID'}, - $others,#$QryParm->{'OTHERS'}, - $place,#$QryParm->{'PLACE'}, - $subject);#$QryParm->{'SUBJECT'}); - my $row = setArticle($values); - return $row; + my $id = ($_[0] eq "-1") ? "null" : "$_[0]"; + (my $others = $QryParm->{'OTHERS'}) =~ s/\Q'\E/''/g; + (my $place = $QryParm->{'PLACE'}) =~ s/\Q'\E/''/g; + (my $subject = $QryParm->{'SUBJECT'}) =~ s/\Q'\E/''/g; + my $values = sprintf("%s,'%s','%s','%s','%s','%s','%s','%s','%s','%s'", + $id, + $QryParm->{'STARTDATE'}, + $QryParm->{'STARTTIME'}, + $QryParm->{'ENDDATE'}, + $QryParm->{'ENDTIME'}, + $QryParm->{'CATEGORY'}, + $QryParm->{'UID'}, + $others,#$QryParm->{'OTHERS'}, + $place,#$QryParm->{'PLACE'}, + $subject);#$QryParm->{'SUBJECT'}); + my $row = setArticle($values); + return $row; } # ---- process a 'delid' query: delete in DB , then back to normal page build processing # sub delId { - my $id = ($_[0] eq "-1") ? "null" : "$_[0]"; - my $row = delArticle($id); - return $row; + my $id = ($_[0] eq "-1") ? "null" : "$_[0]"; + my $row = delArticle($id); + return $row; } =pod diff --git a/CODE/cgi-bin/OSM.pl b/CODE/cgi-bin/OSM.pl index 3145a207..5fadb2aa 100755 --- a/CODE/cgi-bin/OSM.pl +++ b/CODE/cgi-bin/OSM.pl @@ -52,37 +52,38 @@ =head1 Query string parameters my $GRIDName = my $GRIDType = my $NODEName = my $msk = ""; my @NID = split(/[\.\/]/, trim($grid)); if (scalar(@NID) < 2) { - die "No valid grid requested (NOT= gridtype.gridname[.node])." ; + die "No valid grid requested (NOT= gridtype.gridname[.node])." ; } ($GRIDType, $GRIDName, $NODEName) = @NID; # ---- get all nodenames of grid (only VALID) and fullfill a HoH my %N = listGridNodes(grid=>"$GRIDType.$GRIDName"); + # lat/lon to center the map my $lat = my $lon = ""; my $latsum = my $lonsum = my $n = 0; for (keys(%N)) { - my $sta = $_; - my %NODE = readNode($sta); - $N{$sta}{LAT_WGS84} = $NODE{$sta}{LAT_WGS84}; - $N{$sta}{LON_WGS84} = $NODE{$sta}{LON_WGS84}; - $N{$sta}{ALTITUDE} = $NODE{$sta}{ALTITUDE}; - $N{$sta}{INSTALL_DATE} = $NODE{$sta}{INSTALL_DATE}; - $N{$sta}{END_DATE} = $NODE{$sta}{END_DATE}; - $N{$sta}{TYPE} = $NODE{$sta}{TYPE}; - if ($sta eq $NODEName) { - $lat = $N{$sta}{LAT_WGS84}; - $lon = $N{$sta}{LON_WGS84}; - $titre = "$NODE{$sta}{ALIAS}: $NODE{$sta}{NAME}"; - } - $latsum += $N{$sta}{LAT_WGS84}; - $lonsum += $N{$sta}{LON_WGS84}; - $n++; + my $sta = $_; + my %NODE = readNode($sta); + $N{$sta}{LAT_WGS84} = $NODE{$sta}{LAT_WGS84}; + $N{$sta}{LON_WGS84} = $NODE{$sta}{LON_WGS84}; + $N{$sta}{ALTITUDE} = $NODE{$sta}{ALTITUDE}; + $N{$sta}{INSTALL_DATE} = $NODE{$sta}{INSTALL_DATE}; + $N{$sta}{END_DATE} = $NODE{$sta}{END_DATE}; + $N{$sta}{TYPE} = $NODE{$sta}{TYPE}; + if ($sta eq $NODEName) { + $lat = $N{$sta}{LAT_WGS84}; + $lon = $N{$sta}{LON_WGS84}; + $titre = "$NODE{$sta}{ALIAS}: $NODE{$sta}{NAME}"; + } + $latsum += $N{$sta}{LAT_WGS84}; + $lonsum += $N{$sta}{LON_WGS84}; + $n++; } if (scalar(@NID) == 2) { - $lat = $latsum/$n; - $lon = $lonsum/$n; - $titre = $grid; + $lat = $latsum/$n; + $lon = $lonsum/$n; + $titre = $grid; } # ---- build the HTML page calling OSM API once loaded ---- @@ -292,26 +293,27 @@ END END for (keys(%N)) { - if (!($N{$_}{LAT_WGS84} eq "" && $N{$_}{LON_WGS84} eq "") - && ( ($opt ne "active" || (($N{$_}{END_DATE} ge $today || $N{$_}{END_DATE} eq "NA") - && ($N{$_}{INSTALL_DATE} le $today || $N{$_}{INSTALL_DATE} eq "NA"))))) { - my $text = "$N{$_}{ALIAS}: $N{$_}{NAME}
        " - .($N{$_}{TYPE} ne "" ? "($N{$_}{TYPE})
        ":"") - ." from $N{$_}{INSTALL_DATE}".($N{$_}{END_DATE} ne "NA" ? " to $N{$_}{END_DATE}":"")."
        " - ." $N{$_}{LAT_WGS84}°, $N{$_}{LON_WGS84}°, $N{$_}{ALTITUDE} m"; - $text =~ s/\"//g; # fix ticket #166 - print "var marker = L.marker([$N{$_}{LAT_WGS84}, $N{$_}{LON_WGS84}]).addTo(map);\n"; - print "marker.bindPopup(\"$text\").openPopup();\n"; - print "markers.push(marker);\n"; - } + if (!($N{$_}{LAT_WGS84} eq "" && $N{$_}{LON_WGS84} eq "") + && ( ($opt ne "active" || (($N{$_}{END_DATE} ge $today || $N{$_}{END_DATE} eq "NA") + && ($N{$_}{INSTALL_DATE} le $today || $N{$_}{INSTALL_DATE} eq "NA"))))) { + my $text = "$N{$_}{ALIAS}: $N{$_}{NAME}
        " + .($N{$_}{TYPE} ne "" ? "($N{$_}{TYPE})
        ":"") + ." from $N{$_}{INSTALL_DATE}".($N{$_}{END_DATE} ne "NA" ? " to $N{$_}{END_DATE}":"")."
        " + ." $N{$_}{LAT_WGS84}°, $N{$_}{LON_WGS84}°, $N{$_}{ALTITUDE} m"; + $text =~ s/\"//g; # fix ticket #166 + print "var marker = L.marker([$N{$_}{LAT_WGS84}, $N{$_}{LON_WGS84}]).addTo(map);\n"; + print "marker.bindPopup(\"$text\").openPopup();\n"; + print "markers.push(marker);\n"; + } } + # ---- if no node requested => map fits all nodes of grid if (scalar(@NID) == 2) { - print "var group = new L.featureGroup(markers);\n"; - print "map.fitBounds(group.getBounds().pad(0.1));\n"; - print "map.addLayer(markerClusters);\n"; + print "var group = new L.featureGroup(markers);\n"; + print "map.fitBounds(group.getBounds().pad(0.1));\n"; + print "map.addLayer(markerClusters);\n"; } else { - print "map.setView([$lat, $lon], $WEBOBS{OSM_ZOOM_VALUE});\n"; + print "map.setView([$lat, $lon], $WEBOBS{OSM_ZOOM_VALUE});\n"; } print "\n"; diff --git a/CODE/cgi-bin/Welcome.pl b/CODE/cgi-bin/Welcome.pl index 82702bb7..154fc317 100755 --- a/CODE/cgi-bin/Welcome.pl +++ b/CODE/cgi-bin/Welcome.pl @@ -68,7 +68,7 @@ =head1 {WELCOME_CONF} format # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $today = new Time::Piece; @@ -78,8 +78,8 @@ =head1 {WELCOME_CONF} format # ---- our configuration my %APARMS; if (defined($WEBOBS{WELCOME_CONF})) { - %APARMS = readCfg("$WEBOBS{WELCOME_CONF}"); - if (!%APARMS) { die "Couldn't read $WEBOBS{WELCOME_CONF}" } + %APARMS = readCfg("$WEBOBS{WELCOME_CONF}"); + if (!%APARMS) { die "Couldn't read $WEBOBS{WELCOME_CONF}" } } else { die "No WELCOME-PAGE configuration defined $WEBOBS{WELCOME_CONF}" } my $DN = $APARMS{DAYNIGHT} // "NO"; my $HW = $APARMS{HELLOWORLD} // $__{'Hello World'}; @@ -91,33 +91,33 @@ =head1 {WELCOME_CONF} format my @DNcolors = ( "#FF0000", "#00FF00" , "#0000FF", "#FFFF00" ,"#00FFFF", "#FF00FF"); my $DNc = 0; for (sort keys(%fuseaux_horaires)) { - $ENV{TZ} = $_; - my $bullet = "• "; - if (isok($DN)) { - push(@liste_heures,sprintf("
        %s%s,
            %s
        ", - ($DNc%2)?"#EAE4CE":"transparent", - $bullet, - $fuseaux_horaires{$_}, - l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); - } else { - push(@liste_heures,sprintf("%s, %s
        ",$fuseaux_horaires{$_},l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); - } - my @ztab = split(/\t/, qx(grep $_ /usr/share/zoneinfo/zone.tab)); # code \t LatLon \t TZname - if (@ztab) { - my ($junk,$lats,$lat,$longs,$long) = split(/([+-])/, $ztab[1]); # either +-DDMM+-DDDMM or +-DDMMSS+-DDDMMSS - if (length($lat) == 4) { - $lat = substr($lat,0,2)+substr($lat,2,2)/60; - $long = substr($long,0,3)+substr($long,3,2)/60; - } else { - $lat = substr($lat,0,2)+substr($lat,2,2)/60+substr($lat,4,2)/3600; - $long = substr($long,0,3)+substr($long,3,2)/60+substr($long,5,2)/3600; - } - $lat =~ s/,/./; $long =~ s/,/./; - push(@liste_coords,"[".$lats.$lat.",".$longs.$long.",'".$DNcolors[$DNc]."']"); - $DNc++; $DNc = 0 if ($DNc > $#DNcolors); - } - $DNcoords = "[".join(",",@liste_coords)."]"; - $ENV{TZ} = $tz_old; + $ENV{TZ} = $_; + my $bullet = "• "; + if (isok($DN)) { + push(@liste_heures,sprintf("
        %s%s,
            %s
        ", + ($DNc%2)?"#EAE4CE":"transparent", + $bullet, + $fuseaux_horaires{$_}, + l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); + } else { + push(@liste_heures,sprintf("%s, %s
        ",$fuseaux_horaires{$_},l2u(qx(date -d "$today" +"\%A \%-d \%B \%Y - \%H:\%M")))); + } + my @ztab = split(/\t/, qx(grep $_ /usr/share/zoneinfo/zone.tab)); # code \t LatLon \t TZname + if (@ztab) { + my ($junk,$lats,$lat,$longs,$long) = split(/([+-])/, $ztab[1]); # either +-DDMM+-DDDMM or +-DDMMSS+-DDDMMSS + if (length($lat) == 4) { + $lat = substr($lat,0,2)+substr($lat,2,2)/60; + $long = substr($long,0,3)+substr($long,3,2)/60; + } else { + $lat = substr($lat,0,2)+substr($lat,2,2)/60+substr($lat,4,2)/3600; + $long = substr($long,0,3)+substr($long,3,2)/60+substr($long,5,2)/3600; + } + $lat =~ s/,/./; $long =~ s/,/./; + push(@liste_coords,"[".$lats.$lat.",".$longs.$long.",'".$DNcolors[$DNc]."']"); + $DNc++; $DNc = 0 if ($DNc > $#DNcolors); + } + $DNcoords = "[".join(",",@liste_coords)."]"; + $ENV{TZ} = $tz_old; } my $displayListeHeures = ""; $displayListeHeures .= ""; @@ -136,9 +136,9 @@ =head1 {WELCOME_CONF} format my @holidaysdef; my $wodp_holidays = "[]"; if (open(FILE, "<$WEBOBS{FILE_DAYSOFF}")) { - while() { push(@holidaysdef,l2u($_)) if ($_ !~/^(#|$)/); }; close(FILE); - chomp(@holidaysdef); - $wodp_holidays = "[".join(',',map { my ($d,$t)=split(/\|/,$_); "{d: \"$d\", t:\"$t\"}" } @holidaysdef)."]"; + while() { push(@holidaysdef,l2u($_)) if ($_ !~/^(#|$)/); }; close(FILE); + chomp(@holidaysdef); + $wodp_holidays = "[".join(',',map { my ($d,$t)=split(/\|/,$_); "{d: \"$d\", t:\"$t\"}" } @holidaysdef)."]"; } my $calendar = ""; @@ -159,19 +159,19 @@ =head1 {WELCOME_CONF} format print "Content-type: text/html\n\n"; print '', "\n"; print "$titrePage\n", - "", - "", - ""; + "", + "", + ""; if ($APARMS{AUTOREFRESH_SECONDS} gt 0) { - print ""; + print ""; } print "\n\n\n", - "
        ", - "", - "", - "", - "", - ""; + "
        ", + "", + "", + "", + "", + ""; if (isok($DN)) { print ""; } print <<"FIN"; \n"; + print "\n"; } else { - print $cgi->h3("Error occured !"); + print $cgi->h3("Error occured !"); } print $cgi->end_html(); - # --- Send the new event to TCP socket print STDERR "** newSC3 = $newSC3 **\n"; print STDERR "** PeerHost => $MC3{WO2SC3_HOSTNAME}, PeerPort => $MC3{WO2SC3_PORT} **\n"; if ($newSC3 > 0) { - # flush after every write - $| = 1; - - my ($socket,$client_socket); - - # creating object interface of IO::Socket::INET modules which internally creates - # socket, binds and connects to the TCP server running on the specific port. - $socket = new IO::Socket::INET ( - PeerHost => $MC3{WO2SC3_HOSTNAME}, - PeerPort => $MC3{WO2SC3_PORT}, - Proto => 'tcp', - ) or print STDERR "ERROR in Socket Creation : $!\n"; - - #print "TCP Connection Success.\n"; - - # read the socket data sent by server. - #$data = <$socket>; - # we can also read from socket through recv() in IO::Socket::INET - # $socket->recv($data,1024); - #print "Received from Server : $data\n"; - - # write on the socket to server. - #print $socket "$newQML\n"; - # we can also send the data through IO::Socket::INET module, - if ($socket) { - $socket->send($newQML); - #sleep (10); - $socket->close(); - } + + # flush after every write + $| = 1; + + my ($socket,$client_socket); + +# creating object interface of IO::Socket::INET modules which internally creates +# socket, binds and connects to the TCP server running on the specific port. + $socket = new IO::Socket::INET ( + PeerHost => $MC3{WO2SC3_HOSTNAME}, + PeerPort => $MC3{WO2SC3_PORT}, + Proto => 'tcp', + ) or print STDERR "ERROR in Socket Creation : $!\n"; + + #print "TCP Connection Success.\n"; + + # read the socket data sent by server. + #$data = <$socket>; + # we can also read from socket through recv() in IO::Socket::INET + # $socket->recv($data,1024); + #print "Received from Server : $data\n"; + + # write on the socket to server. + #print $socket "$newQML\n"; + # we can also send the data through IO::Socket::INET module, + if ($socket) { + $socket->send($newQML); + + #sleep (10); + $socket->close(); + } } # --------------------------------------------------------------------- sub Quit { - if (-e $_[0]) { - unlink $_[0]; - } - die "WEBOBS: $_[1]"; + if (-e $_[0]) { + unlink $_[0]; + } + die "WEBOBS: $_[1]"; } __END__ diff --git a/CODE/cgi-bin/fedit.pl b/CODE/cgi-bin/fedit.pl index ad402955..39a7a918 100755 --- a/CODE/cgi-bin/fedit.pl +++ b/CODE/cgi-bin/fedit.pl @@ -88,24 +88,24 @@ =head1 CONFIGURATION VARIABLES # Return information when OK # (Reminder: we use text/plain as this is an ajax action) sub htmlMsgOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "$_[0] successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "$_[0] successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); } # Return information when not OK # (Reminder: we use text/plain as this is an ajax action) sub htmlMsgNotOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "Update FAILED !\n $_[0] \n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "Update FAILED !\n $_[0] \n"; } # Open an SQLite connection to the forms database sub connectDbForms { - return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; + return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; } sub count_inputs { @@ -145,11 +145,11 @@ sub count_inputs { # Read the list of all nodes opendir my $nodeDH, $NODES{PATH_NODES} - or die "Problem opening node list from '$NODES{PATH_NODES}': $!\n"; + or die "Problem opening node list from '$NODES{PATH_NODES}': $!\n"; my @ALL_NODES = sort grep(!/^\./ && -d "$NODES{PATH_NODES}/$_", - readdir($nodeDH)); + readdir($nodeDH)); closedir($nodeDH) - or die "Problem closing node list from '$NODES{PATH_NODES}': $!\n"; + or die "Problem closing node list from '$NODES{PATH_NODES}': $!\n"; # codemirror configuration my $CM_edit_theme = $WEBOBS{JS_EDITOR_EDIT_THEME} // "default"; @@ -169,165 +169,171 @@ sub count_inputs { $formConfFile = "$formdir$FORMName.conf"; my @db_columns0 = ("id integer PRIMARY KEY AUTOINCREMENT", "trash boolean DEFAULT FALSE", "node text NOT NULL", - "edate datetime", "edate_min datetime", - "sdate datetime NOT NULL", "sdate_min datetime", - "operators text NOT NULL"); + "edate datetime", "edate_min datetime", + "sdate datetime NOT NULL", "sdate_min datetime", + "operators text NOT NULL"); my @db_columns1 = ("comment text", "tsupd text NOT NULL", "userupd text NOT NULL"); # ---- action is 'save' # if ($action eq 'save') { - if (! -e $formConfFile) { - # --- Form creation (config file does not exist) - - if (! -d $formdir and !mkdir($formdir)) { - htmlMsgNotOK("fedit: error while creating directory $formdir: $!"); - exit; - } - if (open(FILE,">", $formConfFile) ) { - print FILE u2l($text); - close(FILE); - } else { - htmlMsgNotOK("fedit: error creating $formConfFile: $!"); - exit; - } - - # --- connecting to the database in order to create a table with the name of the FORM - my $dbh = connectDbForms(); - - # --- checking if the table we want to edit exists - my $tbl = lc($FORMName); - - my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - - if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB - # --- creation of the DB table - my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); - - my @db_columns = @db_columns0; - push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); - push(@db_columns, @db_columns1); - - my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; - #htmlMsgOK($stmt); - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - } else { - htmlMsgNotOK("Can't create the table !"); - exit; - } - - htmlMsgOK("fedit: $FORMName created."); - exit; - } else { - # --- Form delete or update (config file already exists) - - # --- Delete the form! - if ($delete == 1) { - # delete the dir/file first - my $rmtree_errors; - rmtree($formdir, {'safe' => 1, 'error' => \$rmtree_errors}); - if ($rmtree_errors && @$rmtree_errors) { - htmlMsgNotOK("fedit couldn't delete directory $formdir"); - print STDERR "fedit.pl: unable to delete directory $formdir: " - .join(", ", @$rmtree_errors)."\n"; - exit; - } - htmlMsgOK("$FORMName deleted"); - exit; - } - - # --- connecting to the database in order to create a table with the name of the FORM - my $dbh = connectDbForms(); - - # --- checking if the table we want to edit exists - my $tbl = lc($FORMName); - - my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - - if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB - # --- creation of the DB table - my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); - - my @db_columns = @db_columns0; - push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); - push(@db_columns, @db_columns1); - - my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - } - - # now we know if the table exists - # we want to look at the modification of $text - my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); - my $newKeys = $#inputs; - my $oldKeys = count_inputs(readCfg($formConfFile)); - - my $msg; - if ($newKeys + 1 > $oldKeys) { - $msg = "A new INPUT has been added to the FORM !"; - - # --- connecting to the database in order to add the new INPUT to the DB - my @db_columns = @db_columns0; - push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); - push(@db_columns, @db_columns1); - - my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; - my $sth = $dbh->prepare( $stmt ); - my $rv = $sth->execute() or die $DBI::errstr; - } elsif ($newKeys + 1 < $oldKeys) { - $msg = "You can't remove an INPUT !"; - htmlMsgNotOK($msg); - exit; - } - - if ($TS0 != (stat("$formConfFile"))[9]) { - htmlMsgNotOK("$FORMName $__{'has been modified while you were editing'}"); - exit; - } - if ( sysopen(FILE, "$formConfFile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $FORMName..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $formConfFile $formConfFile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - $text =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@rawfile,u2l($text)); - print FILE @rawfile ; - close(FILE); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $FORMName"); - } - } else { htmlMsgNotOK("$me opening $FORMName - $!") } - htmlMsgOK($msg); - exit; - } + if (! -e $formConfFile) { + + # --- Form creation (config file does not exist) + + if (! -d $formdir and !mkdir($formdir)) { + htmlMsgNotOK("fedit: error while creating directory $formdir: $!"); + exit; + } + if (open(FILE,">", $formConfFile) ) { + print FILE u2l($text); + close(FILE); + } else { + htmlMsgNotOK("fedit: error creating $formConfFile: $!"); + exit; + } + +# --- connecting to the database in order to create a table with the name of the FORM + my $dbh = connectDbForms(); + + # --- checking if the table we want to edit exists + my $tbl = lc($FORMName); + + my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + + if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB + + # --- creation of the DB table + my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); + + my @db_columns = @db_columns0; + push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); + push(@db_columns, @db_columns1); + + my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; + + #htmlMsgOK($stmt); + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + } else { + htmlMsgNotOK("Can't create the table !"); + exit; + } + + htmlMsgOK("fedit: $FORMName created."); + exit; + } else { + + # --- Form delete or update (config file already exists) + + # --- Delete the form! + if ($delete == 1) { + + # delete the dir/file first + my $rmtree_errors; + rmtree($formdir, {'safe' => 1, 'error' => \$rmtree_errors}); + if ($rmtree_errors && @$rmtree_errors) { + htmlMsgNotOK("fedit couldn't delete directory $formdir"); + print STDERR "fedit.pl: unable to delete directory $formdir: " + .join(", ", @$rmtree_errors)."\n"; + exit; + } + htmlMsgOK("$FORMName deleted"); + exit; + } + +# --- connecting to the database in order to create a table with the name of the FORM + my $dbh = connectDbForms(); + + # --- checking if the table we want to edit exists + my $tbl = lc($FORMName); + + my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + + if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB + + # --- creation of the DB table + my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); + + my @db_columns = @db_columns0; + push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); + push(@db_columns, @db_columns1); + + my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + } + + # now we know if the table exists + # we want to look at the modification of $text + my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); + my $newKeys = $#inputs; + my $oldKeys = count_inputs(readCfg($formConfFile)); + + my $msg; + if ($newKeys + 1 > $oldKeys) { + $msg = "A new INPUT has been added to the FORM !"; + + # --- connecting to the database in order to add the new INPUT to the DB + my @db_columns = @db_columns0; + push(@db_columns, map { lc((split '_', $_)[0])." text" } @inputs); + push(@db_columns, @db_columns1); + + my $stmt = "create table if not exists $tbl (".join(', ', @db_columns).")"; + my $sth = $dbh->prepare( $stmt ); + my $rv = $sth->execute() or die $DBI::errstr; + } elsif ($newKeys + 1 < $oldKeys) { + $msg = "You can't remove an INPUT !"; + htmlMsgNotOK($msg); + exit; + } + + if ($TS0 != (stat("$formConfFile"))[9]) { + htmlMsgNotOK("$FORMName $__{'has been modified while you were editing'}"); + exit; + } + if ( sysopen(FILE, "$formConfFile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $FORMName..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $formConfFile $formConfFile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + $text =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@rawfile,u2l($text)); + print FILE @rawfile ; + close(FILE); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $FORMName"); + } + } else { htmlMsgNotOK("$me opening $FORMName - $!") } + htmlMsgOK($msg); + exit; + } } # ---- action is 'edit' (default) # if ( -e "$formConfFile" ) { # looking if the FORM already exists - if ($editOK) { - @rawfile = readFile($formConfFile); - $TS0 = (stat($formConfFile))[9] ; - } + if ($editOK) { + @rawfile = readFile($formConfFile); + $TS0 = (stat($formConfFile))[9] ; + } } else { # we are creating a new FORM - if ($admOK) { - $formConfFile = "$WEBOBS{ROOT_CODE}/tplates/$template"; - @rawfile = readFile($formConfFile); - $TS0 = (stat($formConfFile))[9] ; - $newF = 1; - } + if ($admOK) { + $formConfFile = "$WEBOBS{ROOT_CODE}/tplates/$template"; + @rawfile = readFile($formConfFile); + $TS0 = (stat($formConfFile))[9] ; + $newF = 1; + } } # start building page @@ -350,10 +356,10 @@ sub count_inputs { _EOD_ if ($CM_edit_theme != "default") { - print " \n"; + print " \n"; } if ($CM_browsing_theme != "default" && $CM_edit_theme != $CM_browsing_theme) { - print " \n"; + print " \n"; } print <<_EOD_; @@ -422,15 +428,17 @@ sub count_inputs { _EOD_ print "

        $titrePage $FORMName"; + # delete an existing form is only for the WO Owner! if ($newF == 0 && $USERS{$CLIENT}{UID} eq "!") { - print " "; + print " "; } print "

        \n"; # ---- Display file contents into a "textarea" so that it can be edited print "
        \n"; print ""; print ""; print ""; print "); + } + print qq(); + if (clientHasAdm(type=>"authforms",name=>"SOILSOLUTION")) { + print qq(); + } + print qq(
        ); } print qq(
        \n"; + #print "
        \n"; print "\n"; print "
        $FORMName
        \n"; @@ -439,26 +447,28 @@ sub count_inputs { # ---- Lists my @lists = grep {/_TYPE\|list:/} split(/\n/, $txt); -@lists = uniq(map {s/^.*\|list:\s*(.*)$/$1/g; $_} @lists); +@lists = uniq(map {s/^.*\|list:\s*(.*)$/$1/g; $_} @lists); print "
        Lists\n
          "; foreach (@lists) { - $_ = trim($_); - my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; - my $fdir = "$WEBOBS{PATH_FORMS}/$FORMName"; - if (! -d $fdir and !mkdir($fdir)) { - print "fedit: error while creating directory $fdir: $!"; - } - my $file = "$fdir/$_"; - if ((! -e $file) && -e "$tdir/$_") { - # if the file exists only in the template directory, copy it - qx(cp $tdir/$_ $file 2>&1); - } elsif (! -e $file) { - # if the file does not exist anywhere, copy the generic FORM_list - qx(cp $tdir/FORM_list.conf $file 2>&1); - } - print "
        • $_
          • \n"; + $_ = trim($_); + my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; + my $fdir = "$WEBOBS{PATH_FORMS}/$FORMName"; + if (! -d $fdir and !mkdir($fdir)) { + print "fedit: error while creating directory $fdir: $!"; + } + my $file = "$fdir/$_"; + if ((! -e $file) && -e "$tdir/$_") { + + # if the file exists only in the template directory, copy it + qx(cp $tdir/$_ $file 2>&1); + } elsif (! -e $file) { + + # if the file does not exist anywhere, copy the generic FORM_list + qx(cp $tdir/FORM_list.conf $file 2>&1); + } + print "
        • $_
          • \n"; } print "
        \n"; diff --git a/CODE/cgi-bin/formBOJAP.pl b/CODE/cgi-bin/formBOJAP.pl index c64911a7..a0060e8d 100755 --- a/CODE/cgi-bin/formBOJAP.pl +++ b/CODE/cgi-bin/formBOJAP.pl @@ -58,11 +58,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -87,6 +87,7 @@ =head1 Query string parameter my $affiche; my $s; my @codesListe; + #my @types = readCfgFile("$FORMPATH/$FORM{FILE_TYPE}"); my @rapports = readCfgFile($FORM->path."/".$FORM->conf('FILE_RAPPORTS')); @@ -209,31 +210,31 @@ =head1 Query string parameter my ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val); $id=$date1=$hr1=$date2=$hr2=$site=$cCl=$cCO2=$cSO4=$m1=$m2=$m3=$m4=$h2o=$koh=$rem=$val=""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee1,$sel_mois1,$sel_jour1) = split (/-/,$date1); - ($sel_hr1,$sel_mn1) = split (/:/,$hr1); - ($sel_annee2,$sel_mois2,$sel_jour2) = split (/-/,$date2); - ($sel_hr2,$sel_mn2) = split (/:/,$hr2); - $sel_site = $site; - $sel_cCl = $cCl; - $sel_cCO2 = $cCO2; - $sel_cSO4 = $cSO4; - $sel_h2o = $h2o; - $sel_koh = $koh; - $sel_m1 = $m1; - $sel_m2 = $m2; - $sel_m3 = $m3; - $sel_m4 = $m4; - $sel_rem = $rem; - $sel_rem =~ s/"/"/g; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = ""; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee1,$sel_mois1,$sel_jour1) = split (/-/,$date1); + ($sel_hr1,$sel_mn1) = split (/:/,$hr1); + ($sel_annee2,$sel_mois2,$sel_jour2) = split (/-/,$date2); + ($sel_hr2,$sel_mn2) = split (/:/,$hr2); + $sel_site = $site; + $sel_cCl = $cCl; + $sel_cCO2 = $cCO2; + $sel_cSO4 = $cSO4; + $sel_h2o = $h2o; + $sel_koh = $koh; + $sel_m1 = $m1; + $sel_m2 = $m2; + $sel_m3 = $m3; + $sel_m4 = $m4; + $sel_rem = $rem; + $sel_rem =~ s/"/"/g; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = ""; } + } else { $QryParm->{id} = ""; $val = "" ;} } print "\n"; if ($QryParm->{id} ne "") { - print "{id}\">"; - print ""; + } + print ""; + if (clientHasAdm(type=>"authforms",name=>"RIVERS")) { + print ""; + } + print "
        "; } print "
        @@ -243,7 +244,7 @@ =head1 Query string parameter print "
        "; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; @@ -251,119 +252,119 @@ =head1 Query string parameter print ""; print ""; print ""; print ""; print ""; print ""; print "); + } + print qq(); + if (clientHasAdm(type=>"authforms",name=>"RAINWATER")) { + print qq(); + } + print qq(
        ); } print qq(
        "; print "
        Date et lieu du prélèvement"; - print "

        +print "

        Date début: "; - print " "; - print " "; - print "  Heure: "; - print "
        "; +for (@anneeListe) { + if ($_ == $sel_annee1) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; +print "  Heure: "; +print "
        "; - print "Date fin: "; - print " "; - print " "; - print "  Heure: "; - print "
        "; - - print "Site:

        "; +print "Date fin: "; +print " "; +print " "; +print "  Heure: "; +print "
        "; + +print "Site:

        "; print "
        \n"; print "
        Solution initiale"; - print "

        "; - print "Volume H2O (en ml) =
        \n +print "

        "; +print "Volume H2O (en ml) =
        \n Concentration KOH (en mol/l) =
        \n"; - print "

        "; +print "

        "; print "
        \n"; print "        		"; print "
        Masse recueillie\n"; - print ""; - print ""; - print "
        "; - print "

        "; - print "M1 (en g) =
        \n"; - print "M2 (en g) =
        \n"; - print "M3 (en g) =
        \n"; - print "M4 (en g) =
        \n"; - print "
        "; - print "Masse totale (g) =

        "; +print ""; +print ""; +print "
        "; +print "

        "; +print "M1 (en g) =
        \n"; +print "M2 (en g) =
        \n"; +print "M3 (en g) =
        \n"; +print "M4 (en g) =
        \n"; +print "
        "; +print "Masse totale (g) =

        "; print "
        \n"; print "
        Concentrations\n"; - print "
        "; - print "

        Attention: valeurs en ppm = mg/l

        \n"; - print "

        "; - print "Cl (mg/l) =
        \n"; - print "CO2 (mg/l) =
        \n"; - print "SO4 mg/l) =
        \n"; - print "

        "; +print "
        "; +print "

        Attention: valeurs en ppm = mg/l

        \n"; +print "

        "; +print "Cl (mg/l) =
        \n"; +print "CO2 (mg/l) =
        \n"; +print "SO4 mg/l) =
        \n"; +print "

        "; print "
        \n"; print "
        "; - print "

        ", - "Observations :

        "; - if ($val ne "") { - print "Information de saisie: $val +print "

        ", + "Observations :

        "; +if ($val ne "") { + print "Information de saisie: $val

        "; - } +} print "
        "; print "

        "; diff --git a/CODE/cgi-bin/formCLB.pl b/CODE/cgi-bin/formCLB.pl index 6463b64b..b195364e 100755 --- a/CODE/cgi-bin/formCLB.pl +++ b/CODE/cgi-bin/formCLB.pl @@ -47,13 +47,14 @@ =head1 Query string parameters # --- subroutine sub sort_clb_lines { - my %data = shift(@_); - # Sort the list of lines of the calibration file by date, time, - # and channel number, using a numerical sort for the latter. - $data{$a}{'DATE'} cmp $data{$b}{'DATE'} or - $data{$a}{'TIME'} cmp $data{$b}{'TIME'} or - $data{$a}{'nv'} <=> $data{$b}{'nv'} or - $a cmp $b; # final comparison to make sure the ordering is always well defined + my %data = shift(@_); + + # Sort the list of lines of the calibration file by date, time, + # and channel number, using a numerical sort for the latter. + $data{$a}{'DATE'} cmp $data{$b}{'DATE'} or + $data{$a}{'TIME'} cmp $data{$b}{'TIME'} or + $data{$a}{'nv'} <=> $data{$b}{'nv'} or + $a cmp $b; # final comparison to make sure the ordering is always well defined } # ---- inits and checkings @@ -74,28 +75,27 @@ sub sort_clb_lines { ($GRIDType, $GRIDName, $NODEName) = split(/[\.\/]/, trim($QryParm->{'node'})); if ( $GRIDType eq "PROC" && $GRIDName ne "" ) { - if ( !clientHasEdit(type=>"authprocs",name=>"$GRIDName")) { - die "$__{'Not authorized'} (edit) $GRIDType.$GRIDName.$NODEName"; - } - if ($NODEName ne "") { - my %S = readNode($NODEName); - %NODE = %{$S{$NODEName}}; - if (%NODE) { - %CLBS = readCfg("$WEBOBS{ROOT_CODE}/etc/clb.conf"); - @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); - %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); - %data = readCLB("$GRIDType.$GRIDName.$NODEName"); - } else { - die "$__{'Could not read'} $QryParm->{'node'} $__{'node configuration'}"; - } - } else { - die "$__{'No node requested'}"; - } + if ( !clientHasEdit(type=>"authprocs",name=>"$GRIDName")) { + die "$__{'Not authorized'} (edit) $GRIDType.$GRIDName.$NODEName"; + } + if ($NODEName ne "") { + my %S = readNode($NODEName); + %NODE = %{$S{$NODEName}}; + if (%NODE) { + %CLBS = readCfg("$WEBOBS{ROOT_CODE}/etc/clb.conf"); + @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); + %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); + %data = readCLB("$GRIDType.$GRIDName.$NODEName"); + } else { + die "$__{'Could not read'} $QryParm->{'node'} $__{'node configuration'}"; + } + } else { + die "$__{'No node requested'}"; + } } else { - die ("$__{'You cannot edit a NODE calibration file outside of PROC context'}"); + die ("$__{'You cannot edit a NODE calibration file outside of PROC context'}"); } - # ---- OK, passed all above checks my $titre2 = "$NODE{ALIAS}: $NODE{NAME} [$QryParm->{'node'}]"; @@ -106,7 +106,7 @@ sub sort_clb_lines { my $today = strftime('%F',@tod); my $firstyear = $WEBOBS{BIG_BANG}; if ($NODE{INSTALL_DATE} and $NODE{INSTALL_DATE} =~ /\d{4}-\d{2}-\d{2}/) { - $firstyear = substr($NODE{INSTALL_DATE},0,4); + $firstyear = substr($NODE{INSTALL_DATE},0,4); } my @yearList = ($firstyear..$todayyear); @@ -140,7 +140,7 @@ sub sort_clb_lines { my @params; foreach my $k (sort { $fieldCLB{$a}{'_SO_'} <=> $fieldCLB{$b}{'_SO_'} } keys %fieldCLB) { - push(@params, $k); + push(@params, $k); } #foreach my $k (keys %{$fieldCLB{"DATE"}}) { @@ -233,16 +233,17 @@ sub sort_clb_lines { my $c = ""; print "

        @clbNote

        \n"; + #djl-was: print ""; print ""; print "{'node'}\">", - "\n\n", - "", - ""; - foreach my $k ( @params ) { - if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } - print "",$fieldCLB{$k}{'Name'}.""; - } + "\n\n", + "
        ", + ""; +foreach my $k ( @params ) { + if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } + print "",$fieldCLB{$k}{'Name'}.""; +} print "\n"; my $i = 0; @@ -250,64 +251,64 @@ sub sort_clb_lines { my $line; foreach my $id (sort sort_clb_lines keys %data) { - $i++; - my %line = %{$data{$id}}; - print ""; - - my @date = split(/-/, $line{'DATE'}); - my @heure = split(/:/, $line{'TIME'}); - print "\n"; - print "\n"; - print ""; + + my @date = split(/-/, $line{'DATE'}); + my @heure = split(/:/, $line{'TIME'}); + print "\n"; + print "\n"; + print "\n"; - } - } + if ($line{'nv'} > $nbc) { + $nbc = $line{'nv'}; + } + my $ki = 2; + foreach my $k ( @params ) { + if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } + if (not $k ~~ ["DATE", "TIME", "nv"]) { + print "\n"; + } + } } print " \n"; my $txt = "Number of channels for the node:
          " - ."
        • increase to add channels;" - ."
        • decrease to remove all lines of channels with a greater number." - ."
        "; + ."
      • increase to add channels;" + ."
      • decrease to remove all lines of channels with a greater number." + .""; print "
        • "; print "
        + $i++; + my %line = %{$data{$id}}; + print "
        "; - if ($line{'nv'} > $nbc) { - $nbc = $line{'nv'}; - } - my $ki = 2; - foreach my $k ( @params ) { - if ($k ~~ @hiden_params) { $c = ' class="CLBshowhide"' } else { $c = '' } - if (not $k ~~ ["DATE", "TIME", "nv"]) { - print "

        Fix number of channels = procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -69,8 +69,8 @@ =head1 Query string parameter # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = strftime('%H',@tod); @@ -155,9 +155,9 @@ =head1 Query string parameter var n = 0; var v = 0; var dd;"; - + for ('01'..'20') { - print "if (formulaire.d$_.value != \"\") { + print "if (formulaire.d$_.value != \"\") { dd = 0; v = formulaire.D0.value*1 + formulaire.d$_.value/1000; if ((formulaire.d$_.value - formulaire.d01.value) < -500) { v += 1; } @@ -213,33 +213,33 @@ =head1 Query string parameter my ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$D0,$d01,$d02,$d03,$d04,$d05,$d06,$d07,$d08,$d09,$d10,$d11,$d12,$d13,$d14,$d15,$d16,$d17,$d18,$d19,$d20,$rem,$val); $id=$date=$heure=$site=$aemd=$pAtm=$tAir=$HR=$nebul=$vitre=$D0=$d01=$d02=$d03=$d04=$d05=$d06=$d07=$d08=$d09=$d10=$d11=$d12=$d13=$d14=$d15=$d16=$d17=$d18=$d19=$d20=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$D0,$d01,$d02,$d03,$d04,$d05,$d06,$d07,$d08,$d09,$d10,$d11,$d12,$d13,$d14,$d15,$d16,$d17,$d18,$d19,$d20,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - $sel_annee = substr($date,0,4); - $sel_mois = substr($date,5,2); - $sel_jour = substr($date,8,2); - $sel_hr = substr($heure,0,2); - $sel_mn = substr($heure,3,2); - $sel_site = $site; - $sel_aemd = $aemd; - $sel_pAtm = $pAtm; - $sel_tAir = $tAir; - $sel_HR = $HR; - $sel_nebul = $nebul; - $sel_vitre = $vitre; - $sel_D0 = $D0; - for (@donneeListe) { - eval("\$sel_d$_ = \$d$_;"); - } - $sel_rem = $rem; - $sel_rem =~ s/"/"/g; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date,$heure,$site,$aemd,$pAtm,$tAir,$HR,$nebul,$vitre,$D0,$d01,$d02,$d03,$d04,$d05,$d06,$d07,$d08,$d09,$d10,$d11,$d12,$d13,$d14,$d15,$d16,$d17,$d18,$d19,$d20,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + $sel_annee = substr($date,0,4); + $sel_mois = substr($date,5,2); + $sel_jour = substr($date,8,2); + $sel_hr = substr($heure,0,2); + $sel_mn = substr($heure,3,2); + $sel_site = $site; + $sel_aemd = $aemd; + $sel_pAtm = $pAtm; + $sel_tAir = $tAir; + $sel_HR = $HR; + $sel_nebul = $nebul; + $sel_vitre = $vitre; + $sel_D0 = $D0; + for (@donneeListe) { + eval("\$sel_d$_ = \$d$_;"); + } + $sel_rem = $rem; + $sel_rem =~ s/"/"/g; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print "\n"; # end left column - print "\n"; # end left column +print "
        @@ -249,113 +249,113 @@ =head1 Query string parameter print ""; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; print "\n"; print "\n"; +print "\n"; +print "\n"; print "\n"; -print "\n"; print "); + } + print qq(); + if (clientHasAdm(type=>"authforms",name=>"EAUX")) { + print qq(); + } + print qq(
        ); } print qq(
        "; - print "
        Date et site visé +print "
        Date et site visé

        Date: "; - print " "; - print " "; - - print "  Heure: "; - print "
        "; - print "Site:

        \n"; - print "
        "; - - print "
        Mesures et paramètres météo +for (@anneeListe) { + if ($_ == $sel_annee) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; + +print "  Heure: "; +print "
        "; +print "Site:

        \n"; +print "
        "; + +print "
        Mesures et paramètres météo

        Pression atmosphérique (en mmHg) =
        \n Température de l'air (en °C) =
        \n H.R. (en %) =
        Nébulosité sur le trajet:

        \n"; - print "
        \n"; +for (@meteo) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($cle[0] eq $sel_nebul) { $sel = "selected"; } + print "\n"; +} +print "

        \n"; +print "
        \n"; print "        		"; print "
        Mesures de distance (m)

        Type d'appareil:
        +for (@types) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($cle[0] eq $sel_aemd) { $sel = "selected"; } + print "\n"; +} +print "
        Vitre:

        "; - print "

        +for (@vitres) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($_ eq $sel_vitre) { $sel = "checked"; } + print ""; +} +print "

        "; +print "

        Distance initiale: (en m)

        \n"; - print "

        Fractions: (en mm)
        "; - for (@donneeListe) { - print "Fractions: (en mm)
        "; +for (@donneeListe) { + print ""; - } - print "

        \n"; +} +print "

        \n"; - print "

        Moyenne (m) = +print "

        Moyenne (m) = 2 × Écart-type (m) =

        \n"; - print "
        \n"; - print "
        "; +print "
        "; print "
        Observations"; - print "

        "; - print "
        +print "

        "; +print "
        Information de saisie: $val -

        "; - print "
        \n"; +

        "; +print "\n"; print "
        "; diff --git a/CODE/cgi-bin/formEAUX.pl b/CODE/cgi-bin/formEAUX.pl index 8d726cf4..cbed5779 100755 --- a/CODE/cgi-bin/formEAUX.pl +++ b/CODE/cgi-bin/formEAUX.pl @@ -56,11 +56,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -229,8 +229,6 @@ =head1 Query string parameter ]; - - # ---- read data file # my $message = "Saisie de nouvelles données"; @@ -240,42 +238,42 @@ =head1 Query string parameter my ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val); $id=$date=$heure=$site=$type=$tAir=$tSource=$pH=$debit=$cond=$niveau=$cLi=$cNa=$cK=$cMg=$cCa=$cF=$cCl=$cBr=$cNO3=$cSO4=$cHCO3=$cI=$cSiO2=$d13C=$d18O=$dD=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) >= 1) { - chomp(@ligne); - ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - ($sel_hr,$sel_mn) = split (/:/,$heure); - $sel_site = $site; - $sel_type = $type; - $sel_tAir = $tAir; - $sel_tSource = $tSource; - $sel_pH = $pH; - $sel_debit = $debit; - $sel_cond = $cond; - $sel_niveau = $niveau; - $sel_cLi = $cLi; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cF = $cF; - $sel_cCl = $cCl; - $sel_cBr = $cBr; - $sel_cNO3 = $cNO3; - $sel_cSO4 = $cSO4; - $sel_cHCO3 = $cHCO3; - $sel_cI = $cI; - $sel_cSiO2 = $cSiO2; - $sel_d13C = $d13C; - $sel_d18O = $d18O; - $sel_dD = $dD; - $sel_rem = $rem; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) >= 1) { + chomp(@ligne); + ($id,$date,$heure,$site,$type,$tAir,$tSource,$pH,$debit,$cond,$niveau,$cLi,$cNa,$cK,$cMg,$cCa,$cF,$cCl,$cBr,$cNO3,$cSO4,$cHCO3,$cI,$cSiO2,$d13C,$d18O,$dD,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + ($sel_hr,$sel_mn) = split (/:/,$heure); + $sel_site = $site; + $sel_type = $type; + $sel_tAir = $tAir; + $sel_tSource = $tSource; + $sel_pH = $pH; + $sel_debit = $debit; + $sel_cond = $cond; + $sel_niveau = $niveau; + $sel_cLi = $cLi; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cF = $cF; + $sel_cCl = $cCl; + $sel_cBr = $cBr; + $sel_cNO3 = $cNO3; + $sel_cSO4 = $cSO4; + $sel_cHCO3 = $cHCO3; + $sel_cI = $cI; + $sel_cSiO2 = $cSiO2; + $sel_d13C = $d13C; + $sel_d18O = $d18O; + $sel_dD = $dD; + $sel_rem = $rem; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print qq( @@ -292,17 +290,17 @@ =head1 Query string parameter ); if ($QryParm->{id} ne "") { - print qq(); - print qq(
        ); - if ($val ne "") { - print qq(

        Information de saisie: $val + print qq(); + print qq(

        ); + if ($val ne "") { + print qq(

        Information de saisie: $val

        ); - } - print qq(); - if (clientHasAdm(type=>"authforms",name=>"EAUX")) { - print qq(); - } - print qq(
        @@ -316,73 +314,73 @@ =head1 Query string parameter ); - print qq(); - print qq( "; - - print qq(  Heure: ); - print qq(
        +for (@anneeListe) { + if ($_ == $sel_annee) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  Heure: ); +print qq(
        Site:
        +for (@NODESSelList) { + my @cle = split(/\|/,$_); + if ($cle[0] eq $sel_site) { + print qq(); + } else { + print qq(); + } +} +print qq(
        Type:

        diff --git a/CODE/cgi-bin/formEXTENSO.pl b/CODE/cgi-bin/formEXTENSO.pl index d84740fd..b0c3fd94 100755 --- a/CODE/cgi-bin/formEXTENSO.pl +++ b/CODE/cgi-bin/formEXTENSO.pl @@ -56,19 +56,19 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits defaults --------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = strftime('%H',@tod); @@ -97,31 +97,33 @@ =head1 Query string parameter my @heureListe = ('','00'..'23'); my @minuteListe= ('','00'..'59'); - # ---- Read the data file to retrieve most recent measurements # my ($lignes, $dataTS) = $FORM->data; @$lignes = reverse sort tri_date_avec_id @$lignes; + # most recent measurements from last data line in file my (@lastData) = split(/\|/, @$lignes[$#$lignes -1 ]); # -1 because of header after reverse + # last measurements for each site (stations) my @lastMeasure; my $i = 0; for my $st (keys(%Ns)) { - #djl-was: my @tmp = grep(/\|$stations[$i]\|/,@$lignes); - my @tmp = grep(/\|$st\|/,@$lignes); - my @ddd = split(/\|/,$tmp[$#tmp]); - my $moy = 0; - my $n = 0; - for (@donneeListe) { - if ($ddd[($_-1)*3+8] ne "") { - $moy += $ddd[($_-1)*3+9] + $ddd[($_-1)*3+10]; - $n++; - } - } - if ($n != 0) { $moy /= $n; } - $lastMeasure[$i] = sprintf("%1.2f mm (%s)",$ddd[7]+$ddd[8]+$moy,$ddd[1]); - $i++; + + #djl-was: my @tmp = grep(/\|$stations[$i]\|/,@$lignes); + my @tmp = grep(/\|$st\|/,@$lignes); + my @ddd = split(/\|/,$tmp[$#tmp]); + my $moy = 0; + my $n = 0; + for (@donneeListe) { + if ($ddd[($_-1)*3+8] ne "") { + $moy += $ddd[($_-1)*3+9] + $ddd[($_-1)*3+10]; + $n++; + } + } + if ($n != 0) { $moy /= $n; } + $lastMeasure[$i] = sprintf("%1.2f mm (%s)",$ddd[7]+$ddd[8]+$moy,$ddd[1]); + $i++; } # ---- init some other defaults --------------------------- @@ -129,53 +131,54 @@ =head1 Query string parameter my $sel_offset = $lastData[8]; my @sel_oper = $USERS{$CLIENT}{UID}; my $sel_site = my $sel_temp = my $sel_ruban = ""; -my @sel_d = my @sel_v ="" ; +my @sel_d = my @sel_v ="" ; my $sel_rem = my $sel = ""; my ($id,$date,$heure,$site,$ope,$temp,$meteo,$ruban,$offset,$rem,$val); - $id=$date=$heure=$site=$ope=$temp=$meteo=$ruban=$offset=$rem=$val = ""; +$id=$date=$heure=$site=$ope=$temp=$meteo=$ruban=$offset=$rem=$val = ""; my @d; # ---- date and staff (oper) in querystring may override defaults (resp. today & client) if ( defined($QryParm->{date}) && length($QryParm->{date}) == 10 ) { - $sel_annee = substr($QryParm->{date},0,4); - $sel_mois = substr($QryParm->{date},5,2); - $sel_jour = substr($QryParm->{date},8,2); + $sel_annee = substr($QryParm->{date},0,4); + $sel_mois = substr($QryParm->{date},5,2); + $sel_jour = substr($QryParm->{date},8,2); } if (defined($QryParm->{oper})) { - @sel_oper = split(/\ /,$QryParm->{oper}); # note: GET replaces '+' with a space + @sel_oper = split(/\ /,$QryParm->{oper}); # note: GET replaces '+' with a space } # ---- if an id is passed in querystring, override defaults with data file for this id if (defined($QryParm->{id})) { - my @ligneId = grep(/^$QryParm->{id}\|/,@$lignes); - if (@ligneId ne "") { - ($id,$date,$heure,$site,$ope,$temp,$meteo,$ruban,$offset,$d[0][0],$d[0][1],$d[0][2],$d[1][0],$d[1][1],$d[1][2],$d[2][0],$d[2][1],$d[2][2],$d[3][0],$d[3][1],$d[3][2],$d[4][0],$d[4][1],$d[4][2],$d[5][0],$d[5][1],$d[5][2],$d[6][0],$d[6][1],$d[6][2],$d[7][0],$d[7][1],$d[7][2],$d[8][0],$d[8][1],$d[8][2],$rem,$val) = split (/\|/,$ligneId[0]); - $sel_annee = substr($date,0,4); - $sel_mois = substr($date,5,2); - $sel_jour = substr($date,8,2); - $sel_hr = substr($heure,0,2); - $sel_mn = substr($heure,3,2); - $sel_site = $site; - $sel_meteo = lc($meteo); - $sel_temp = $temp; - $sel_ruban = $ruban; - $sel_offset= $offset; - @sel_oper = split(/\+/,$ope); - # each of the 9 measurements in file is a 3-tuple (fenetre,cadran,vent). - # for input (& matching new equipments) we show/accept the 2-tuple (fenetre,cadran) - # as a single input field (representing fenetre+cadran). - # following loop builds input fields from these 3-tuples, - # ATT: null 2-tuple ARE null input (not zero) - for ($i = 0; $i<9; $i++) { - if (!($d[$i][0] eq "" && $d[$i][1] eq "")) { - $sel_d[$i] = $d[$i][0] + $d[$i][1]; - $sel_d[$i] =~ tr/,/./; - } else { $sel_d[$i] = "" } - $sel_v[$i] = $d[$i][2]; - } - $sel_rem = l2u($rem); - chomp($val); - } + my @ligneId = grep(/^$QryParm->{id}\|/,@$lignes); + if (@ligneId ne "") { + ($id,$date,$heure,$site,$ope,$temp,$meteo,$ruban,$offset,$d[0][0],$d[0][1],$d[0][2],$d[1][0],$d[1][1],$d[1][2],$d[2][0],$d[2][1],$d[2][2],$d[3][0],$d[3][1],$d[3][2],$d[4][0],$d[4][1],$d[4][2],$d[5][0],$d[5][1],$d[5][2],$d[6][0],$d[6][1],$d[6][2],$d[7][0],$d[7][1],$d[7][2],$d[8][0],$d[8][1],$d[8][2],$rem,$val) = split (/\|/,$ligneId[0]); + $sel_annee = substr($date,0,4); + $sel_mois = substr($date,5,2); + $sel_jour = substr($date,8,2); + $sel_hr = substr($heure,0,2); + $sel_mn = substr($heure,3,2); + $sel_site = $site; + $sel_meteo = lc($meteo); + $sel_temp = $temp; + $sel_ruban = $ruban; + $sel_offset= $offset; + @sel_oper = split(/\+/,$ope); + +# each of the 9 measurements in file is a 3-tuple (fenetre,cadran,vent). +# for input (& matching new equipments) we show/accept the 2-tuple (fenetre,cadran) +# as a single input field (representing fenetre+cadran). +# following loop builds input fields from these 3-tuples, +# ATT: null 2-tuple ARE null input (not zero) + for ($i = 0; $i<9; $i++) { + if (!($d[$i][0] eq "" && $d[$i][1] eq "")) { + $sel_d[$i] = $d[$i][0] + $d[$i][1]; + $sel_d[$i] =~ tr/,/./; + } else { $sel_d[$i] = "" } + $sel_v[$i] = $d[$i][2]; + } + $sel_rem = l2u($rem); + chomp($val); + } } # ---- Begin HTML display @@ -205,8 +208,8 @@ =head1 Query string parameter \n"; - -print "

        ".$FORM->conf('TITLE')."

        \n

        $titre2

        "; + +print "

        ".$FORM->conf('TITLE')."

        \n

        $titre2

        "; print " "; - print "  "; - print "  "; - print "  "; - print "  
        "; - print ""; - } - print "
        "; - # --- INSPIRE THEME - print ""; - print "
        "; - # --- TOPIC CATEGORIES - print ""; - #print ""; - print "
        "; - # --- Lineage - print ""; - print "  
        "; - print ""; - print ""; - - print "        		"; # right column - - # --- 'node' position (latitude, longitude & altitude) - print "
        $__{'Geographic location'}"; - print ""; - print ""; - print ""; - print < "auth".lc($GRIDType)."s", name => "*")) { +# print "

        $__{'Edit the node-features-nodes associations list'}

        "; +#} +print ""; + +# --- Grids +print "
        $__{'Associated Grids'}\n"; + +# --- (additional) GRIDS: VIEWs and PROCs +# --- list only PROCs and VIEWs that client has AUTHEDIT to ... +my @GL; + +# ... all views and procs +#FB-was: my @Lprocs = map("PROC.".basename($_), qx(ls -d $WEBOBS{PATH_PROCS}/*)); chomp(@Lprocs); +#FB-was: my @Lviews = map("VIEW.".basename($_), qx(ls -d $WEBOBS{PATH_VIEWS}/*)); chomp(@Lviews); +my @Lprocs = map("PROC.".basename($_), qx(find $WEBOBS{PATH_PROCS}/* -type d)); chomp(@Lprocs); +my @Lviews = map("VIEW.".basename($_), qx(find $WEBOBS{PATH_VIEWS}/* -type d)); chomp(@Lviews); + +# ... set client-and-its-groups where clause element, then query DB +my $cid = "$USERS{$CLIENT}{UID}"; +my $wc = " uid in (SELECT GID from $WEBOBS{SQL_TABLE_GROUPS} WHERE UID=\"$cid\") OR uid = \"$cid\" "; +my @Aprocs = qx(sqlite3 -separator '.' $WEBOBS{SQL_DB_USERS} 'select "PROC",resource from $WEBOBS{SQL_TABLE_AUTHPROCS} where auth >= 2 and $wc'); +my @Aviews = qx(sqlite3 -separator '.' $WEBOBS{SQL_DB_USERS} 'select "VIEW",resource from $WEBOBS{SQL_TABLE_AUTHVIEWS} where auth >= 2 and $wc'); +chomp(@Aviews); chomp(@Aprocs); + +# ... merge client-allowed-to VIEWS and PROCS into @GL +if ( ('VIEW.*') ~~ @Aviews ) { @GL = @Lviews } +else { map { push(@GL,$_) if (($_) ~~ @Aviews) } @Lviews } +if ( ('PROC.*') ~~ @Aprocs ) { @GL = (@GL,@Lprocs) } +else { map { push(@GL,$_) if (($_) ~~ @Aprocs) } @Lprocs } +print "
        "; - print "
        "; - print "        		"; - print " 
        "; - print ""; - print "° "; - print "' "; - print "\" "; - print "
        \n"; - print ""; - print "° "; - print "' "; - print "\" "; - print "
        \n"; - print ""; - print "
        \n"; - # --- positioning date - print " "; - print " "; - print "
        "; - # --- Positioning type (unknown, map, GPS or auto) - print " " - ."
        "; - print "
        " - ." " - ."
        "; - - # --- Importation of shpfile - # --- First we check if a geojson already exists in the NODE dir +print "        		"; # left column - if (-e $geojsonFile) { - open(FH, '<', $geojsonFile); - while(){ - $json = "$_"; - } - close(FH); - } +print "
        $__{'Name and Description'}"; + +# --- Codes, Name, Alias, Type +print "$GRIDType.$GRIDName."; +if ($newnode) { + print ""; + print ""; + print ""; +} else { + print "
        "; + print ""; + print ""; +} +print ""; +print "{'node'}\">"; +print "{'node'}\">"; +print "
        "; - print ""; - print ""; - print ""; - print " " - ."
        "; +# --- Nom complet/TITLE +print ""; +print "
        "; + +# --- ALIAS +print ""; +print "  
        "; + +# --- TYPE +print ""; +print "  
        "; +print "
        "; + +print "
        $__{'Lifetime and Events Time Zone'}"; + +# --- Dates debut et fin +print ""; +print ""; +print ""; +print ""; +print ""; +print ""; +print "
        "; +print "
        "; +print "$__{'Start date'}: "; +print " "; +print "
        "; +print "$__{'End date'}: "; +print " "; +print " "; +print "
        		"; + +# --- ALIAS +print ""; +print ""; +print "
        \n"; +print "
        "; + +# --- Features +print "
        $__{'Features'}"; +print "" + ." 

        "; +for (@feat) { + print ""; + my $pat = qr/^$NODEName\|$_\|/; + my @fnlist = grep(/$pat/,@n2n); + my $fn = join(',',@fnlist); + $fn =~ s/$NODEName\|$_\|//g; + print "
        "; +} - print "
        "; +print ""; +print ""; +print ""; +print ""; +print "
        "; +print ""; +print ">\" style=\"width:100px\" onClick=\"SelectMoveRows(document.form.INs,document.form.SELs)\">
        "; +print "
        "; +print ""; +print "        		"; +print "
        "; +print "
        "; + +# --- Procs metadata +print "
        $__{'Procs Metadata'}"; + +# --- DESCRIPTION +print ""; +print "  
        "; + +# --- show THEIA fields ? +print "
         

        "; +print "
        "; + +# --- PRODUCER +print ""; +print "  
        "; + +# --- CREATOR +print ""; +print ""; +print ""; +print ""; +print "

        "; +print "
        "; +print "  "; +print "  "; +print "  "; +print "  
        "; +print "
        "; +for (my $i = 1; $i <= $#usrRole; $i++) { + my $cnt = $i+1; + print "
        "; + print ""; + print "  "; + print "  "; + print "  "; + print "  
        "; + print "
        "; +} +print "

        "; + +# --- INSPIRE THEME +print ""; +print "
        "; + +# --- TOPIC CATEGORIES +print ""; + +#print ""; +print "
        "; + +# --- Lineage +print ""; +print "  
        "; +print "
        "; +print "
        "; + +print "        		"; # right column + +# --- 'node' position (latitude, longitude & altitude) +print "
        $__{'Geographic location'}"; +print ""; +print ""; +print ""; +print < const checked = document.getElementById("theiaChecked"); const auth = $theiaAuth; @@ -1226,172 +1256,183 @@ =head1 Query string parameters } FIN - print "
        "; +print "
        "; +print "        		"; +print " 
        "; +print ""; +print "° "; +print "' "; +print "\" "; +print "
        \n"; +print ""; +print "° "; +print "' "; +print "\" "; +print "
        \n"; +print ""; +print "
        \n"; + +# --- positioning date +print " "; +print " "; +print "
        "; + +# --- Positioning type (unknown, map, GPS or auto) +print " " + ."
        "; +print "
        " + ." " + ."
        "; + +# --- Importation of shpfile +# --- First we check if a geojson already exists in the NODE dir + +if (-e $geojsonFile) { + open(FH, '<', $geojsonFile); + while(){ + $json = "$_"; + } + close(FH); +} + +print ""; +print ""; +print ""; +print " " + ."
        "; + +print "
        "; - print "
        \n"; - - # --- GNSS-specific information - - my $m3g_url_edit = $WEBOBS{'M3G_URL'}."/".$usrGnss9char; - print "
        $__{'GNSS-specific information'}"; - print ""; - print ""; - print "
        "; - print ""; - print ""; - print "";# NB: use save button to store this code the first time, before updating metadata "; - print "
        \n"; - print "
        \n"; - ###### get and edit features - #### Edit GeodesyML on M3G - print "Edit sitelog on M3G (requires prior M3G login)"; - print "
        \n"; - #### get geodesyML from M3G - #print "
        \n"; - print "
        \n"; - - print ""; - if ( $m3g_check ) { - print ""; - } else { - print ""; - } - print "
        \n"; - - print "
        "; - print "
        "; - - # --- Transmission - print "
        $__{'Transmission'}"; - print ""; - print ""; - print ""; - print "
        "; - print ""; - print "\n"; - print ""; - # Transmission path (acquisition + repeater list) - print "
        "; - print "
        "; - print "
        "; - print "
        "; - - # --- Procs parameters - if (uc($GRIDType) eq "PROC") { - print "
        $__{'Procs Parameters'}"; - print "\n"; - # --- CHANNEL_LIST - print "\n"; - # --- DATA (FID) - print "\n
        "; - print ""; - print "$GRID{NAME} (".(defined($GRID{NODESLIST}) ? scalar(@{$GRID{NODESLIST}}):"0")." nodes)

        \n"; - # --- RAWFORMAT list - print "
        \n"; - # --- RAWDATA - print "
        "; - # --- FDSN Network Code - print ""; - print "
        \n"; - print "        		"; - print ""; - my %carCLB = readCfg("$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"); - if (%carCLB) { - my @select = split(/,/,$usrCHAN); - # make a list of available channels and label them with last Chan. + Loc. codes - my %chan; - foreach my $k (keys %carCLB) { - $chan{$k} = "$carCLB{$k}{'nm'} ($carCLB{$k}{'cd'} $carCLB{$k}{'lc'})"; - } - print ""; - } else { - print "no calibration file."; - } - print "
        "; - print ""; - print "
        \n"; - # --- DATA (FID_x) - # first displays any user defined FID_x (that are NOT in the rawformats list) - my @usrFIDshort = map {$_ =~ s/^$GRIDType\.$GRIDName\.//g; $_} @usrFID; - for (sort @usrFID) { - my $short = $_; - $short =~ s/^$GRIDType\.$GRIDName\.//g; - if (!grep(/^$short$/,@fmtfid)) { - my $long = "$GRIDType.$GRIDName.$short"; - print "
        \n"; - } - } - # second adds all possible FID_x: visible for active RAWFORMAT, hidden for others - print "
        \n"; - for (keys(%rawFormats)) { - my $key = $_; - for (split(/,/,$rawFormats{$key}{FID})) { - my $fid = "FID_$_"; - my $long = "$GRIDType.$GRIDName.$fid"; - my $disp = ($key eq $usrRAWFORMAT ? "block":"none"); - print "

        \n"; - } - } - print "
        		"; - print "
        "; - print "
        "; - print "
        "; - print "

        \n"; - } - # --- Propagates any other Proc's parameters (hidden) - # PROC.*.* = other proc's parameters - # ^* = list of selected parameters formerly associated with all proc): they have been used at the begining of this script - # to fill the default values in form, but will be also propagated to all other associated procs (see postNODE.pl) - for (keys(%NODE)) { - if ( !($_ =~ /^$GRIDType\.$GRIDName\./) - && $_ =~ /^VIEW\.|^PROC\.|^FDSN_NETWORK_CODE$|^UTC_DATA$|^ACQ_RATE$|^RAWFORMAT$|^RAWDATA$|^CHANNEL_LIST$|^FID/ ) { - print ""; - } - } +print "
        "; +print "\n"; + +# --- GNSS-specific information + +my $m3g_url_edit = $WEBOBS{'M3G_URL'}."/".$usrGnss9char; +print "

        $__{'GNSS-specific information'}"; +print ""; +print ""; +print "
        "; +print ""; +print ""; +print "";# NB: use save button to store this code the first time, before updating metadata "; +print "
        \n"; +print "
        \n"; +###### get and edit features +#### Edit GeodesyML on M3G +print "Edit sitelog on M3G (requires prior M3G login)"; +print "
        \n"; +#### get geodesyML from M3G +#print "
        \n"; +print "
        \n"; + +print ""; +if ( $m3g_check ) { + print ""; +} else { + print ""; +} +print "
        \n"; + +print "
        "; +print "
        "; + +# --- Transmission +print "
        $__{'Transmission'}"; +print ""; +print ""; +print ""; +print "
        "; +print ""; +print "\n"; +print ""; + +# Transmission path (acquisition + repeater list) +print "
        "; +print "
        "; +print "
        "; +print "
        "; + +# --- Procs parameters +if (uc($GRIDType) eq "PROC") { + print "
        $__{'Procs Parameters'}"; + print "\n"; + + # --- CHANNEL_LIST + print "\n"; + + # --- DATA (FID) + print "\n
        "; + print ""; + print "$GRID{NAME} (".(defined($GRID{NODESLIST}) ? scalar(@{$GRID{NODESLIST}}):"0")." nodes)

        \n"; + + # --- RAWFORMAT list + print "
        \n"; - ## # --- "Validity" - ## if ( clientHasAdm(type=>"authmisc",name=>"NODES")) { - ## print "

        " - ## ."$__{'Valid Node'}

        \n"; - ## } else { - ## print ""; - ## } + # --- RAWDATA + print "
        "; + + # --- FDSN Network Code + print ""; + print "
        \n"; + print "        		"; + print ""; + my %carCLB = readCfg("$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"); + if (%carCLB) { + my @select = split(/,/,$usrCHAN); + + # make a list of available channels and label them with last Chan. + Loc. codes + my %chan; + foreach my $k (keys %carCLB) { + $chan{$k} = "$carCLB{$k}{'nm'} ($carCLB{$k}{'cd'} $carCLB{$k}{'lc'})"; + } + print ""; + } else { + print "no calibration file."; + } + print "
        "; + print ""; + print "
        \n"; + + # --- DATA (FID_x) + # first displays any user defined FID_x (that are NOT in the rawformats list) + my @usrFIDshort = map {$_ =~ s/^$GRIDType\.$GRIDName\.//g; $_} @usrFID; + for (sort @usrFID) { + my $short = $_; + $short =~ s/^$GRIDType\.$GRIDName\.//g; + if (!grep(/^$short$/,@fmtfid)) { + my $long = "$GRIDType.$GRIDName.$short"; + print "
        \n"; + } + } + +# second adds all possible FID_x: visible for active RAWFORMAT, hidden for others + print "
        \n"; + for (keys(%rawFormats)) { + my $key = $_; + for (split(/,/,$rawFormats{$key}{FID})) { + my $fid = "FID_$_"; + my $long = "$GRIDType.$GRIDName.$fid"; + my $disp = ($key eq $usrRAWFORMAT ? "block":"none"); + print "

        \n"; + } + } + print "
        		"; + print "
        "; + print "
        "; + print "
        "; + print "

        \n"; +} + +# --- Propagates any other Proc's parameters (hidden) +# PROC.*.* = other proc's parameters +# ^* = list of selected parameters formerly associated with all proc): they have been used at the begining of this script +# to fill the default values in form, but will be also propagated to all other associated procs (see postNODE.pl) +for (keys(%NODE)) { + if ( !($_ =~ /^$GRIDType\.$GRIDName\./) + && $_ =~ /^VIEW\.|^PROC\.|^FDSN_NETWORK_CODE$|^UTC_DATA$|^ACQ_RATE$|^RAWFORMAT$|^RAWDATA$|^CHANNEL_LIST$|^FID/ ) { + print ""; + } +} + +## # --- "Validity" +## if ( clientHasAdm(type=>"authmisc",name=>"NODES")) { +## print "

        " +## ."$__{'Valid Node'}

        \n"; +## } else { +## print ""; +## } print "
        "; + # --- buttons zone if ($newnode==2) { - print "

        $__{'Copy'}: "; - print "$__{'Features content'} "; - print "$__{'Calibration file'} "; - print "$__{'Photos & documents'} "; + print "

        $__{'Copy'}: "; + print "$__{'Features content'} "; + print "$__{'Calibration file'} "; + print "$__{'Photos & documents'} "; } print "

        "; print ""; diff --git a/CODE/cgi-bin/formNOVAC.pl b/CODE/cgi-bin/formNOVAC.pl index afd0f7a0..22306ed3 100755 --- a/CODE/cgi-bin/formNOVAC.pl +++ b/CODE/cgi-bin/formNOVAC.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formNOVAC.pl @@ -57,11 +58,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Edit - ".$FORM->conf('TITLE'); @@ -71,8 +72,8 @@ =head1 Query string parameter # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $today = strftime('%F',@tod); @@ -87,6 +88,7 @@ =head1 Query string parameter # loads the source of a value (user defined, calculated, etc.) my @sources = readCfgFile($FORM->path."/".$FORM->conf('SOURCES')); + # loads the pre-selected cone angles (60 degrees, 90 degrees, etc.) my @coneangles = readCfgFile($FORM->path."/".$FORM->conf('CONEANGLES')); @@ -182,6 +184,7 @@ =head1 Query string parameter \n \n \n"; + # ------------------------------------------------------------ # ---- end of specific NOVAC javascript form validation ------ # ------------------------------------------------------------ @@ -208,44 +211,46 @@ =head1 Query string parameter my @ligne; my $ptr=''; my $fts-1; + # ------------------------------------------------------------ # ---- start of specific NOVAC form code --------------------- # ------------------------------------------------------------ my ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split(/\|/,$_); if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - $sel_site = $site; - $sel_flux1 = $flux1; - $sel_flux2 = $flux2; - $sel_windSpeed = $windSpeed; - $sel_windSpeedSource = $windSpeedSource; - $sel_windDirection = $windDirection; - $sel_windDirectionSource = $windDirectionSource; - $sel_compassDirection = $compassDirection; - $sel_coneAngle = $coneAngle; - $sel_tilt = $tilt; - $sel_plumeHeight = $plumeHeight; - $sel_plumeHeightSource = $plumeHeightSource; - $sel_offset = $offset; - $sel_plumeCentre = $plumeCentre; - $sel_plumeEdge1 = $plumeEdge1; - $sel_plumeEdge2 = $plumeEdge2; - $sel_plumeCompleteness = $plumeCompleteness; - $sel_geomError = $geomError; - $sel_spectrometerError = $spectrometerError; - $sel_scatteringError = $scatteringError; - $sel_windError = $windError; - $sel_nbValidScans = $nbValidScans; - $message = "Changing entry $QryParm->{id}"; + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + $sel_site = $site; + $sel_flux1 = $flux1; + $sel_flux2 = $flux2; + $sel_windSpeed = $windSpeed; + $sel_windSpeedSource = $windSpeedSource; + $sel_windDirection = $windDirection; + $sel_windDirectionSource = $windDirectionSource; + $sel_compassDirection = $compassDirection; + $sel_coneAngle = $coneAngle; + $sel_tilt = $tilt; + $sel_plumeHeight = $plumeHeight; + $sel_plumeHeightSource = $plumeHeightSource; + $sel_offset = $offset; + $sel_plumeCentre = $plumeCentre; + $sel_plumeEdge1 = $plumeEdge1; + $sel_plumeEdge2 = $plumeEdge2; + $sel_plumeCompleteness = $plumeCompleteness; + $sel_geomError = $geomError; + $sel_spectrometerError = $spectrometerError; + $sel_scatteringError = $scatteringError; + $sel_windError = $windError; + $sel_nbValidScans = $nbValidScans; + $message = "Changing entry $QryParm->{id}"; + } else { $QryParm->{id} = ""; } } else { $QryParm->{id} = ""; } - } else { $QryParm->{id} = ""; } } + # ------------------------------------------------------------ # ---- end of specific NOVAC form code ----------------------- # ------------------------------------------------------------ @@ -261,7 +266,7 @@ =head1 Query string parameter

        \n "; if ($QryParm->{id} ne "") { - print "\n + print "\n {id}\"/>"; } print "\n @@ -275,37 +280,37 @@ =head1 Query string parameter Date: \n \n \n
        \n @@ -314,15 +319,16 @@ =head1 Query string parameter "; for (@sources) { - my @cle = split(/\|/,$_); - print "\n + my @cle = split(/\|/,$_); + print "\n $cle[1]"; + if ($cle[0] eq $sel_windSpeedSource) { + print " selected"; + } + print " value=$cle[0]>$cle[1]"; } print "\n
        \n @@ -363,13 +369,13 @@ =head1 Query string parameter Wind direction source: \n
        \n @@ -385,13 +391,13 @@ =head1 Query string parameter Cone angle: \n deg
        \n @@ -410,13 +416,13 @@ =head1 Query string parameter Plume height source: \n
        \n @@ -468,6 +474,7 @@ =head1 Query string parameter \n \n \n"; + # ------------------------------------------------------------ # ---- end of specific NOVAC HTML form code ------------------ # ------------------------------------------------------------ diff --git a/CODE/cgi-bin/formPLUVIO.pl b/CODE/cgi-bin/formPLUVIO.pl index 3e19ac7b..9e5913ea 100755 --- a/CODE/cgi-bin/formPLUVIO.pl +++ b/CODE/cgi-bin/formPLUVIO.pl @@ -57,11 +57,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -124,7 +124,7 @@ =head1 Query string parameter {"; for ("01".."31") { - print "if (formulaire.d$_.value == \"\" && formulaire.d$_.disabled == false) { formulaire.d$_.value = 0; }\n"; + print "if (formulaire.d$_.value == \"\" && formulaire.d$_.disabled == false) { formulaire.d$_.value = 0; }\n"; } print "} @@ -236,22 +236,22 @@ =head1 Query string parameter my ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val); $id=$aa=$mm=$site=$d01=$v01=$d02=$v02=$d03=$v03=$d04=$v04=$d05=$v05=$d06=$v06=$d07=$v07=$d08=$v08=$d09=$v09=$d10=$v10=$d11=$v11=$d12=$v12=$d13=$v13=$d14=$v14=$d15=$v15=$d16=$v16=$d17=$v17=$d18=$v18=$d19=$v19=$d20=$v20=$d21=$v21=$d22=$v22=$d23=$v23=$d24=$v24=$d25=$v25=$d26=$v26=$d27=$v27=$d28=$v28=$d29=$v29=$d30=$v30=$d31=$v31=$val; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - $sel_annee = $aa; - $sel_mois = $mm; - $sel_site = $site; - for (@jourListe) { - eval("\$sel_d$_ = \$d$_;"); - eval("\$sel_v$_ = \$v$_;"); - } - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = ""; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + $sel_annee = $aa; + $sel_mois = $mm; + $sel_site = $site; + for (@jourListe) { + eval("\$sel_d$_ = \$d$_;"); + eval("\$sel_v$_ = \$v$_;"); + } + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = ""; } + } else { $QryParm->{id} = ""; $val = "" ;} } print "\n"; print "\n"; +print "
        @@ -261,7 +261,7 @@ =head1 Query string parameter print "
        "; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; @@ -271,59 +271,59 @@ =head1 Query string parameter
        Mois et Site

        Année: "; - print " Mois: \n"; - print "   +for (@anneeListe) { + $sel = ""; + if ($_ == $sel_annee) { $sel = "selected"; } + print "\n"; +} +print ""; +print " Mois: \n"; +print "   Site: "; - print "

        "; +for (@NODESSelList) { + my @cle = split(/\|/,$_); + $sel = ""; + if ($cle[0] eq $sel_site) { $sel = "selected"; } + print "\n"; +} +print ""; +print ""; print "
        Pluviométrie journalière (mm)\n"; - print ""; - print ""; - print ""; +print "\n"; - print " + print " 
        "; + if (($_ eq "10") || ($_ eq "20")) { print "\n"; +print "\n"; - print "\n"; - print "
        "; - for (@jourListe) { - print "$_. "; +print "
        "; +for (@jourListe) { + print "$_. "; - print " 
        "; - if (($_ eq "10") || ($_ eq "20")) { print "        		"; } - } - print "
        Cumul 1ère décade "; } +} +print "
        Cumul 1ère décade Cumul 2ème décade Cumul 3ème décade
        Cumul mensuel (mm) =

        "; - print "
        "; +print "
        Cumul mensuel (mm) =

        "; +print ""; print "

        Information de saisie: $val diff --git a/CODE/cgi-bin/formRAINWATER.pl b/CODE/cgi-bin/formRAINWATER.pl index ad0f88b5..3aaf178d 100755 --- a/CODE/cgi-bin/formRAINWATER.pl +++ b/CODE/cgi-bin/formRAINWATER.pl @@ -56,11 +56,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -71,9 +71,9 @@ =head1 Query string parameter @$lines = reverse sort tri_date_avec_id @$lines; my %lastData; for my $id (keys(%Ns)) { - my @tmp = grep(/\|$id\|/,@$lines); - chomp(@tmp); - $lastData{$id} = $tmp[$#tmp]; + my @tmp = grep(/\|$id\|/,@$lines); + chomp(@tmp); + $lastData{$id} = $tmp[$#tmp]; } # --- DateTime inits ------------------------------------- @@ -273,8 +273,6 @@ =head1 Query string parameter ]; - - # ---- read data file # my $message = $__{'Enter a new data'}; @@ -284,34 +282,34 @@ =head1 Query string parameter my ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val); $id=$date2=$time2=$site=$date1=$time1=$volume=$diameter=$pH=$cond=$cNa=$cK=$cMg=$cCa=$cHCO3=$cCl=$cSO4=$dD=$d18O=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @line = @$ptr; - if (scalar(@line) >= 1) { - chomp(@line); - ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,l2u($line[0])); - if ($QryParm->{id} eq $id) { - ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); - ($sel_hr1,$sel_mn1) = split (/:/,$time1); - ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); - ($sel_hr2,$sel_mn2) = split (/:/,$time2); - $sel_site = $site; - $sel_volume = $volume; - $sel_diameter = $diameter; - $sel_pH = $pH; - $sel_cond = $cond; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cHCO3 = $cHCO3; - $sel_cCl = $cCl; - $sel_cSO4 = $cSO4; - $sel_dD = $dD; - $sel_d18O = $d18O; - $sel_rem = $rem; - $message = $__{"Edit existing data n° $QryParm->{id}"}; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @line = @$ptr; + if (scalar(@line) >= 1) { + chomp(@line); + ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,l2u($line[0])); + if ($QryParm->{id} eq $id) { + ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); + ($sel_hr1,$sel_mn1) = split (/:/,$time1); + ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); + ($sel_hr2,$sel_mn2) = split (/:/,$time2); + $sel_site = $site; + $sel_volume = $volume; + $sel_diameter = $diameter; + $sel_pH = $pH; + $sel_cond = $cond; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cHCO3 = $cHCO3; + $sel_cCl = $cCl; + $sel_cSO4 = $cSO4; + $sel_dD = $dD; + $sel_d18O = $d18O; + $sel_rem = $rem; + $message = $__{"Edit existing data n° $QryParm->{id}"}; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print qq( @@ -328,17 +326,17 @@ =head1 Query string parameter ); if ($QryParm->{id} ne "") { - print qq(); - print qq(

        ); - if ($val ne "") { - print qq(

        $__{'Input Information'}: $val + print qq(); + print qq(

        ); + if ($val ne "") { + print qq(

        $__{'Input Information'}: $val

        ); - } - print qq(); - if (clientHasAdm(type=>"authforms",name=>"RAINWATER")) { - print qq(); - } - print qq(
        @@ -351,114 +349,114 @@ =head1 Query string parameter $__{'Site'}:
        +print qq() if ($QryParm->{id} eq ""); + +for (@NODESSelList) { + my @cle = split(/\|/,$_); + if ($cle[0] eq $sel_site) { + print qq(); + } elsif ($QryParm->{id} eq "") { + print qq(); + } +} +print qq(
        $__{'Start Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(
        +for (@yearList) { + if ($_ == $sel_y1) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(
        $__{'End Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(

        diff --git a/CODE/cgi-bin/formREQ.pl b/CODE/cgi-bin/formREQ.pl index aaf1d1e3..1b27474e 100755 --- a/CODE/cgi-bin/formREQ.pl +++ b/CODE/cgi-bin/formREQ.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formREQ.pl @@ -135,9 +136,9 @@ =head1 DATE SPAN AND PARAMETERS map (push(@procavailable,basename($_,".conf")), qx(grep -l '^SUBMIT_COMMAND|.*' $WEBOBS{PATH_PROCS}/*/*.conf )); chomp(@procavailable); if (scalar(@procavailable)>0) { - foreach (@procavailable) { - push(@proclist,$_) if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$_")); - } + foreach (@procavailable) { + push(@proclist,$_) if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$_")); + } } else { die "$__{'No PROCS eligible for requests submission.'}" } if (scalar(@proclist)==0) { die "$__{'No PROC eligible for this user. Please ask an administrator.'}" } @@ -146,7 +147,7 @@ =head1 DATE SPAN AND PARAMETERS my @REQEXCL; my $reqexcl = "$WEBOBS{ROOT_CODE}/etc/request-excluded-keylist"; if (-e $reqexcl ) { - @REQEXCL = readFile($reqexcl); + @REQEXCL = readFile($reqexcl); } # ---- read in default values for initializing @@ -154,7 +155,7 @@ =head1 DATE SPAN AND PARAMETERS my %REQDFLT; my $reqdflt = "$WEBOBS{ROOT_CODE}/tplates/request-template"; if (-e $reqdflt ) { - %REQDFLT = readCfg($reqdflt); + %REQDFLT = readCfg($reqdflt); } # ---- retrieve the last requests for current user @@ -163,13 +164,13 @@ =head1 DATE SPAN AND PARAMETERS map (push(@reqlist,$_), qx(find $WEBOBS{ROOT_OUTR} -type d -mindepth 1 -maxdepth 1 -name "*_$CLIENT")); chomp(@reqlist); for (@reqlist) { - my $date1 = qx(grep "^DATE1|" $_/REQUEST.rc | sed -e "s/DATE1|//"); - my $date2 = qx(grep "^DATE2|" $_/REQUEST.rc | sed -e "s/DATE2|//"); - chomp($date1); - chomp($date2); - my $date12 = $date1."_".$date2; - $date12 =~ s/[-: ]//g; - $reqdates{$date12} = "$date1 to $date2"; + my $date1 = qx(grep "^DATE1|" $_/REQUEST.rc | sed -e "s/DATE1|//"); + my $date2 = qx(grep "^DATE2|" $_/REQUEST.rc | sed -e "s/DATE2|//"); + chomp($date1); + chomp($date2); + my $date12 = $date1."_".$date2; + $date12 =~ s/[-: ]//g; + $reqdates{$date12} = "$date1 to $date2"; } # ---- passed all checkings above ... @@ -297,136 +298,150 @@ =head1 DATE SPAN AND PARAMETERS print ""; print ""; - print "\n"; # end left column - - print "\n"; # end right column +print "\n"; # end left column + +print "\n"; # end right column print "
        "; # left column - - # ---- Display list of PROCS that are eligible for requests - print "
        $__{'Available PROCS'}"; - print "
        "; - for my $p (@proclist) { - %P = readProc($p,'novsub','escape'); # reads the proc conf without modifying content (no variable substitution, keep escaped char) - my $nn = scalar(@{$P{$p}{NODESLIST}}); - print " {$p}: $P{$p}{NAME} ($nn node".($nn>1?"s":"").")
        \n"; - print pkeys($p,\%P); - } - print "
        "; - print "
        		"; # right column - - print "
        $__{'Date and time span (UT)'}"; - # DATE1| DATE2| - print ""; - print ""; - print ""; - print ""; - print ""; - print ""; - print "
        "; - print "
        "; - print "$__{'Start date'}: "; - print " "; - print " "; - print "    "; - print "
        "; - print "$__{'End date'}: "; - print " "; - print " "; - print "    "; - print " "; - print "
        		$__{'Preset dates'}
        \n"; - print "
        "; - - my %datestr = readCfg("$WEBOBS{ROOT_CODE}/etc/dateformats.conf"); - my @ppis = split(',',$WEBOBS{REQ_PPI_LIST} //= '75,100,150,300,600'); - my @marks = split(',',$WEBOBS{REQ_MARKERSIZE_LIST} //= '1,2,4,6,10,15,20'); - my @linew = split(',',$WEBOBS{REQ_LINEWIDTH_LIST} //= '0.1,0.25,0.5,1,1.5,2,3'); - - print "
        $__{'Output parameters'}"; - print ""; - print ""; - print ""; - - print ""; - print "
        "; - # TZ| - print ""; - print "
         
        "; - # DATESTR| - print ""; - print "
         
        "; - # CUMULATE| - print ""; - print " $__{'days'}
         
        "; - # DECIMATE| - print ""; - print "1/
         
        "; - # MARKERSIZE| - print ""; - print "
         
        "; - # LINEWIDTH| - print ""; - print "
         
        "; - # PLOTGRID| - print ""; - print "
         
        "; - print "        		"; - # PPI| - print ""; - print "
         
        "; - # PDFOUTPUT| - print ""; - print "
         
        "; - # SVGOUTPUT| - print ""; - print "
         
        "; - # EXPORTS| - print ""; - print "
         
        "; - # ANONYMOUS| - print ""; - print "
         
        "; - # DEBUG| - print ""; - print "
         
        "; - print "
        \n"; - print "
        "; - print "        		"; # left column + +# ---- Display list of PROCS that are eligible for requests +print "
        $__{'Available PROCS'}"; +print "
        "; +for my $p (@proclist) { + %P = readProc($p,'novsub','escape'); # reads the proc conf without modifying content (no variable substitution, keep escaped char) + my $nn = scalar(@{$P{$p}{NODESLIST}}); + print " {$p}: $P{$p}{NAME} ($nn node".($nn>1?"s":"").")
        \n"; + print pkeys($p,\%P); +} +print "
        "; +print "
        		"; # right column + +print "
        $__{'Date and time span (UT)'}"; + +# DATE1| DATE2| +print ""; +print ""; +print ""; +print ""; +print ""; +print ""; +print "
        "; +print "
        "; +print "$__{'Start date'}: "; +print " "; +print " "; +print "    "; +print "
        "; +print "$__{'End date'}: "; +print " "; +print " "; +print "    "; +print " "; +print "
        		$__{'Preset dates'}
        \n"; +print "
        "; + +my %datestr = readCfg("$WEBOBS{ROOT_CODE}/etc/dateformats.conf"); +my @ppis = split(',',$WEBOBS{REQ_PPI_LIST} //= '75,100,150,300,600'); +my @marks = split(',',$WEBOBS{REQ_MARKERSIZE_LIST} //= '1,2,4,6,10,15,20'); +my @linew = split(',',$WEBOBS{REQ_LINEWIDTH_LIST} //= '0.1,0.25,0.5,1,1.5,2,3'); + +print "
        $__{'Output parameters'}"; +print ""; +print ""; +print ""; + +print ""; +print "
        "; + +# TZ| +print ""; +print "
         
        "; + +# DATESTR| +print ""; +print "
         
        "; + +# CUMULATE| +print ""; +print " $__{'days'}
         
        "; + +# DECIMATE| +print ""; +print "1/
         
        "; + +# MARKERSIZE| +print ""; +print "
         
        "; + +# LINEWIDTH| +print ""; +print "
         
        "; + +# PLOTGRID| +print ""; +print "
         
        "; +print "        		"; + +# PPI| +print ""; +print "
         
        "; + +# PDFOUTPUT| +print ""; +print "
         
        "; + +# SVGOUTPUT| +print ""; +print "
         
        "; + +# EXPORTS| +print ""; +print "
         
        "; + +# ANONYMOUS| +print ""; +print "
         
        "; + +# DEBUG| +print ""; +print "
         
        "; +print "
        \n"; +print "
        "; +print "
        \n"; print "

        "; @@ -444,23 +459,23 @@ =head1 DATE SPAN AND PARAMETERS # ---- build a div for a proc's keylist input fields # (args: procName, \%procConf) sub pkeys { - my ($pn,$PP) = @_; - if (defined($pn)) { - my $div = "

        "; - return $div; - } - return "" ; # no request_keylist + my ($pn,$PP) = @_; + if (defined($pn)) { + my $div = ""; + return $div; + } + return "" ; # no request_keylist } __END__ diff --git a/CODE/cgi-bin/formRIVERS.pl b/CODE/cgi-bin/formRIVERS.pl index 21276cc6..f58babe4 100755 --- a/CODE/cgi-bin/formRIVERS.pl +++ b/CODE/cgi-bin/formRIVERS.pl @@ -56,19 +56,19 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = ""; @@ -226,8 +226,6 @@ =head1 Query string parameter FIN - - # ---- read data file # my $message = "Saisie de nouvelles données"; @@ -237,38 +235,38 @@ =head1 Query string parameter my ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val); $id=$date=$heure=$site=$level=$type=$flacon=$tRiver=$suspendedLoad=$pH=$cond25=$cond=$cNa=$cK=$cMg=$cCa=$cHCO3=$cCl=$cSO4=$cSiO2=$cDOC=$cPOC=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) >= 1) { - chomp(@ligne); - ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - ($sel_hr,$sel_mn) = split (/:/,$heure); - $sel_site = $site; - $sel_level = $level; - $sel_type = $type; - $sel_flacon = $flacon; - $sel_tRiver = $tRiver; - $sel_suspendedLoad = $suspendedLoad; - $sel_pH = $pH; - $sel_cond25 = $cond25; - $sel_cond = $cond; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cHCO3 = $cHCO3; - $sel_cCl = $cCl; - $sel_cSO4 = $cSO4; - $sel_cSiO2 = $cSiO2; - $sel_cDOC = $cDOC; - $sel_cPOC = $cPOC; - $sel_rem = $rem; - $sel_rem =~ s/"/"/g; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) >= 1) { + chomp(@ligne); + ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + ($sel_hr,$sel_mn) = split (/:/,$heure); + $sel_site = $site; + $sel_level = $level; + $sel_type = $type; + $sel_flacon = $flacon; + $sel_tRiver = $tRiver; + $sel_suspendedLoad = $suspendedLoad; + $sel_pH = $pH; + $sel_cond25 = $cond25; + $sel_cond = $cond; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cHCO3 = $cHCO3; + $sel_cCl = $cCl; + $sel_cSO4 = $cSO4; + $sel_cSiO2 = $cSiO2; + $sel_cDOC = $cDOC; + $sel_cPOC = $cPOC; + $sel_rem = $rem; + $sel_rem =~ s/"/"/g; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print ""; @@ -280,17 +278,17 @@ =head1 Query string parameter

        $message

        "; - if ($val ne "") { - print "

        Information de saisie: $val + print "{id}\">"; + print "

        "; + if ($val ne "") { + print "

        Information de saisie: $val

        "; - } - print ""; - if (clientHasAdm(type=>"authforms",name=>"RIVERS")) { - print ""; - } - print "
        "; @@ -301,117 +299,118 @@ =head1 Query string parameter
        Date et lieu du prélèvement

        Date: "; - print " "; - print " "; - - print "  Heure: "; - print "
        "; - - print "Site:
        \n"; +for (@anneeListe) { + if ($_ == $sel_annee) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; - print "Type:
        \n"; +print "  Heure: "; +print "
        "; + +print "Site:
        \n"; - print "Flacon:
        \n"; - print "

        "; - print "
        "; - - print "
        Mesures sur site"; - print "

        "; - print "Niveau d'eau (en cm) =
        "; - print "Température du liquide (en °C) =
        "; - print "pH =
        "; - print "Conductivité (en µS/cm) =
        "; - print "

        "; - print "
        "; - - print "
        Concentration en autres éléments"; - print "
        "; - print "

        "; - print "SiO2 (en ppm) =
        \n"; - print "Concentration en suspension solide (en mg/L) =
        "; - print "

        "; - print "
        "; +print "Type:
        \n"; + +print "Flacon:
        \n"; +print "

        "; +print ""; + +print "
        Mesures sur site"; +print "

        "; +print "Niveau d'eau (en cm) =
        "; +print "Température du liquide (en °C) =
        "; +print "pH =
        "; +print "Conductivité (en µS/cm) =
        "; +print "

        "; +print "
        "; + +print "
        Concentration en autres éléments"; +print "
        "; +print "

        "; +print "SiO2 (en ppm) =
        \n"; +print "Concentration en suspension solide (en mg/L) =
        "; +print "

        "; +print "
        "; print "        		"; - print "
        Concentrations en cations et anions\n"; - print "

        Attention: valeurs en ppm = mg/l

        \n"; - #djl-was: print "
        "; - print ""; - print ""; - print "
        "; - print "

        "; - print "Na+ (en ppm) =
        \n"; - print "K+ (en ppm) =
        \n"; - print "Mg++ (en ppm) =
        \n"; - print "Ca++ (en ppm) =
        \n"; - print "H+ (en ppm) =
        \n"; - print "

        		"; - print "

        "; - print "HCO3- (en ppm) =
        \n"; - print "Cl- (en ppm) =
        \n"; - print "SO4-- (en ppm) =
        \n"; - print "

        NICB (%) = "; - print "
        "; - print ""; - - print "
        Concentrations organiques"; - print "
        "; - print "

        "; - print "DOC (en ppm) =
        \n"; - print "POC (en ppm) =
        \n"; - print "

        "; - print "
        "; - - print "
        Mesures en laboratoire"; - print "

        "; - print "Conductivité à 25°C (en µS/cm) =
        "; - print "

        "; - print "
        "; +print "
        Concentrations en cations et anions\n"; +print "

        Attention: valeurs en ppm = mg/l

        \n"; + +#djl-was: print "
        "; +print ""; +print ""; +print "
        "; +print "

        "; +print "Na+ (en ppm) =
        \n"; +print "K+ (en ppm) =
        \n"; +print "Mg++ (en ppm) =
        \n"; +print "Ca++ (en ppm) =
        \n"; +print "H+ (en ppm) =
        \n"; +print "

        		"; +print "

        "; +print "HCO3- (en ppm) =
        \n"; +print "Cl- (en ppm) =
        \n"; +print "SO4-- (en ppm) =
        \n"; +print "

        NICB (%) = "; +print "
        "; +print ""; + +print "
        Concentrations organiques"; +print "
        "; +print "

        "; +print "DOC (en ppm) =
        \n"; +print "POC (en ppm) =
        \n"; +print "

        "; +print "
        "; + +print "
        Mesures en laboratoire"; +print "

        "; +print "Conductivité à 25°C (en µS/cm) =
        "; +print "

        "; +print "
        "; print "
        "; - print "Observations :

        "; +print "Observations :

        "; print "
        "; print "

        "; diff --git a/CODE/cgi-bin/formSOILSOLUTION.pl b/CODE/cgi-bin/formSOILSOLUTION.pl index cbb0a284..82d08d30 100755 --- a/CODE/cgi-bin/formSOILSOLUTION.pl +++ b/CODE/cgi-bin/formSOILSOLUTION.pl @@ -56,11 +56,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -72,11 +72,11 @@ =head1 Query string parameter @$lines = reverse sort tri_date_avec_id @$lines; my %lastData; for my $id (keys(%Ns)) { - for my $d (@depth) { - my @tmp = grep(/\|$id\|$d\|/,@$lines); - chomp(@tmp); - $lastData{$id."_".$d} = $tmp[$#tmp]; - } + for my $d (@depth) { + my @tmp = grep(/\|$id\|$d\|/,@$lines); + chomp(@tmp); + $lastData{$id."_".$d} = $tmp[$#tmp]; + } } # --- DateTime inits ------------------------------------- @@ -136,10 +136,10 @@ =head1 Query string parameter var lastData = {}; ]; foreach my $id (keys(%Ns)) { - foreach my $d (@depth) { - my $key = $id."_".$d; - print qq[ lastData["$key"] = "$lastData{$key}";\n]; - } + foreach my $d (@depth) { + my $key = $id."_".$d; + print qq[ lastData["$key"] = "$lastData{$key}";\n]; + } } print qq[ var form = document.formulaire; @@ -265,8 +265,6 @@ =head1 Query string parameter ]; - - # ---- read data file # my $message = $__{'Enter a new data'}; @@ -276,35 +274,35 @@ =head1 Query string parameter my ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val); $id=$date2=$time2=$site=$date1=$time1=$depth=$level=$pH=$cond=$cNa=$cK=$cMg=$cCa=$cHCO3=$cCl=$cNO3=$cSO4=$cSiO2=$cDOC=$rem=$val = ""; if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @line = @$ptr; - if (scalar(@line) >= 1) { - chomp(@line); - ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,l2u($line[0])); - if ($QryParm->{id} eq $id) { - ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); - ($sel_hr1,$sel_mn1) = split (/:/,$time1); - ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); - ($sel_hr2,$sel_mn2) = split (/:/,$time2); - $sel_site = $site; - $sel_depth = $depth; - $sel_level = $level; - $sel_pH = $pH; - $sel_cond = $cond; - $sel_cNa = $cNa; - $sel_cK = $cK; - $sel_cMg = $cMg; - $sel_cCa = $cCa; - $sel_cHCO3 = $cHCO3; - $sel_cCl = $cCl; - $sel_cNO3 = $cNO3; - $sel_cSO4 = $cSO4; - $sel_cSiO2 = $cSiO2; - $sel_cDOC = $cDOC; - $sel_rem = $rem; - $message = $__{"Edit existing data n° $QryParm->{id}"}; - } else { $QryParm->{id} = ""; $val = "" ; } - } else { $QryParm->{id} = ""; $val = "" ;} + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @line = @$ptr; + if (scalar(@line) >= 1) { + chomp(@line); + ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,l2u($line[0])); + if ($QryParm->{id} eq $id) { + ($sel_y1,$sel_m1,$sel_d1) = split (/-/,$date1); + ($sel_hr1,$sel_mn1) = split (/:/,$time1); + ($sel_y2,$sel_m2,$sel_d2) = split (/-/,$date2); + ($sel_hr2,$sel_mn2) = split (/:/,$time2); + $sel_site = $site; + $sel_depth = $depth; + $sel_level = $level; + $sel_pH = $pH; + $sel_cond = $cond; + $sel_cNa = $cNa; + $sel_cK = $cK; + $sel_cMg = $cMg; + $sel_cCa = $cCa; + $sel_cHCO3 = $cHCO3; + $sel_cCl = $cCl; + $sel_cNO3 = $cNO3; + $sel_cSO4 = $cSO4; + $sel_cSiO2 = $cSiO2; + $sel_cDOC = $cDOC; + $sel_rem = $rem; + $message = $__{"Edit existing data n° $QryParm->{id}"}; + } else { $QryParm->{id} = ""; $val = "" ; } + } else { $QryParm->{id} = ""; $val = "" ;} } print qq( @@ -321,17 +319,17 @@ =head1 Query string parameter ); if ($QryParm->{id} ne "") { - print qq(); - print qq(

        ); - if ($val ne "") { - print qq(

        $__{'Input Information'}: $val + print qq(); + print qq(

        ); + if ($val ne "") { + print qq(

        $__{'Input Information'}: $val

        ); - } - print qq(); - if (clientHasAdm(type=>"authforms",name=>"SOILSOLUTION")) { - print qq(); - } - print qq(
        @@ -344,133 +342,133 @@ =head1 Query string parameter $__{'Site'}:
        +print qq() if ($QryParm->{id} eq ""); + +for (@NODESSelList) { + my @cle = split(/\|/,$_); + if ($cle[0] eq $sel_site) { + print qq(); + } elsif ($QryParm->{id} eq "") { + print qq(); + } +} +print qq(
        $__{'Start Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(
        +for (@yearList) { + if ($_ == $sel_y1) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(
        $__{'End Date'}: ); - print qq(); - print qq( "; - - print qq(  $__{'Time'}: ); - print qq(

        +for (@yearList) { + if ($_ == $sel_y2) { + print qq(); + } else { + print qq(); + } +} +print qq(); +print qq(); +print qq( "; + +print qq(  $__{'Time'}: ); +print qq(

        $__{'Lysimeter'}

        $__{'Sampling Depth'} (cm) =
        $__{'Water Level'} (filled) =
        + .qq( onMouseOut="nd()" onmouseover="overlib('$__{help_soilsolution_level}')">

        diff --git a/CODE/cgi-bin/formUPLOAD.pl b/CODE/cgi-bin/formUPLOAD.pl index 1e7286e3..21edc89b 100755 --- a/CODE/cgi-bin/formUPLOAD.pl +++ b/CODE/cgi-bin/formUPLOAD.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formUPLOAD.pl @@ -55,7 +56,7 @@ =head1 QUERY-STRING # ---- calling stuff # -my @tod = localtime(); +my @tod = localtime(); my $QryParm = $cgi->Vars; my $typeDoc = $QryParm->{'doc'} // ""; my $object = $QryParm->{'object'} // ""; @@ -75,19 +76,19 @@ =head1 QUERY-STRING @NID = split(/[\.\/]/, trim($object)); ($GRIDType, $GRIDName, $NODEName) = @NID; if (defined($GRIDType) || defined($GRIDName)) { - $editOK = 1 if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); - die "$__{'Not authorized'}" if ($editOK == 0); + $editOK = 1 if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); + die "$__{'Not authorized'}" if ($editOK == 0); } else { die "$__{'Invalid object'} '$object'" } # ---- find out wether object is a grid or a node # if (scalar(@NID) == 3) { - $pobj = \%NODES; - $pathTarget = "$pobj->{PATH_NODES}/$NODEName"; + $pobj = \%NODES; + $pathTarget = "$pobj->{PATH_NODES}/$NODEName"; } if (scalar(@NID) == 2) { - $pobj = \%GRIDS; - $pathTarget = "$pobj->{PATH_GRIDS}/$GRIDType/$GRIDName"; + $pobj = \%GRIDS; + $pathTarget = "$pobj->{PATH_GRIDS}/$GRIDType/$GRIDName"; } # ---- more checkings on type of document to be uploaded @@ -96,10 +97,10 @@ =head1 QUERY-STRING die "$__{'Cannot upload to'} $typeDoc" if ( "@allowed" !~ /\b$typeDoc\b/ ); if ($typeDoc ne "SPATH_INTERVENTIONS") { - $pathTarget .= "/$pobj->{$typeDoc}"; + $pathTarget .= "/$pobj->{$typeDoc}"; } else { - die "$__{'intervention event not specified'}" if ($event eq ""); - $pathTarget .= "/$pobj->{$typeDoc}/$event/PHOTOS"; + die "$__{'intervention event not specified'}" if ($event eq ""); + $pathTarget .= "/$pobj->{$typeDoc}/$event/PHOTOS"; } # ---- at that point $pathTarget is where uploaded documents will be sent to @@ -115,7 +116,7 @@ =head1 QUERY-STRING my $titrePage = "Manage $pobj->{$typeDoc}"; print $cgi->header(-charset=>"utf-8"), -$cgi->start_html("$titrePage"); + $cgi->start_html("$titrePage"); print ""; print <<"FIN"; @@ -185,48 +186,49 @@ =head1 QUERY-STRING
        "; - print "\n

        $titrePage

        "; +print "\n

        $titrePage

        "; print "

        $__{'for'} [$object] $event

        \n"; + #was:print "

        [$NODEName] ".getNodeString(node=>$NODEName,style=>'short')."

        "; #debug: print "target= $pathTarget
        "; print ""; - print "
        \n"; - print ""; - my $i = 0; - foreach (@listeTarget) { - $i++; - my ( $name, $path, $extension ) = fileparse ( $_, '\..*' ); - my $urn = "$urnTarget/$name$extension"; - my $turn = "$urnTarget/$thumbnailsPath/$name$extension"; - my $file = "$pathTarget/$name$extension"; - print ""; - } - print "
        "; - print ""; - my $th = makeThumbnail( $file, "x$NODES{THUMBNAILS_PIXV}", "$pathTarget/$thumbnailsPath","$NODES{THUMBNAILS_EXT}"); - if ( $th ne "" ) { - (my $turn = $th) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - print ""; - } - print ""; - print "

        $name$extension
        "; - print " $__{'Delete'}

        "; - print "
        "; - - print "
        $__{'Upload new file(s)'} Note: $__{'Avoid special characters and spaces in filename'} +print "
        \n"; +print ""; +my $i = 0; +foreach (@listeTarget) { + $i++; + my ( $name, $path, $extension ) = fileparse ( $_, '\..*' ); + my $urn = "$urnTarget/$name$extension"; + my $turn = "$urnTarget/$thumbnailsPath/$name$extension"; + my $file = "$pathTarget/$name$extension"; + print ""; +} +print "
        "; + print ""; + my $th = makeThumbnail( $file, "x$NODES{THUMBNAILS_PIXV}", "$pathTarget/$thumbnailsPath","$NODES{THUMBNAILS_EXT}"); + if ( $th ne "" ) { + (my $turn = $th) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + print ""; + } + print ""; + print "

        $name$extension
        "; + print " $__{'Delete'}

        "; +print "
        "; + +print "
        $__{'Upload new file(s)'} Note: $__{'Avoid special characters and spaces in filename'}

        "; - print "
        "; +print "
        "; - print ""; - print ""; - print ""; - print ""; +print ""; +print ""; +print ""; +print ""; - print "

        "; - print ""; - print "

        "; +print "

        "; +print ""; +print "

        "; print "
         
        "; # ---- We're done with the page diff --git a/CODE/cgi-bin/formVEHICLES.pl b/CODE/cgi-bin/formVEHICLES.pl index 73755bf4..981d6cd8 100755 --- a/CODE/cgi-bin/formVEHICLES.pl +++ b/CODE/cgi-bin/formVEHICLES.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME formVEHICLES.pl @@ -57,11 +58,11 @@ =head1 Query string parameter my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $titrePage = "Édition - ".$FORM->conf('TITLE'); @@ -70,8 +71,8 @@ =head1 Query string parameter # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $sel_jour = strftime('%d',@tod); -my $sel_mois = strftime('%m',@tod); +my $sel_jour = strftime('%d',@tod); +my $sel_mois = strftime('%m',@tod); my $sel_annee = strftime('%Y',@tod); my $anneeActuelle = strftime('%Y',@tod); my $sel_hr = ""; @@ -167,23 +168,23 @@ =head1 Query string parameter my $fts-1; my ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split(/\|/,$_); if (defined($QryParm->{id})) { - ($ptr, $fts) = $FORM->data($QryParm->{id}); - @ligne = @$ptr; - if (scalar(@ligne) == 1) { - chomp(@ligne); - ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split (/\|/,l2u($ligne[0])); - if ($QryParm->{id} eq $id) { - ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); - ($sel_hr,$sel_mn) = split (/:/,$heure); - $sel_vehicle = $vehicle; - $sel_mileage = $mileage; - $sel_type = $type; - $sel_site = $site; - $sel_driver = $driver; - $sel_oil = $oil; - $message = "Modification donnée n° $QryParm->{id}"; - } else { $QryParm->{id} = ""; } - } else { $QryParm->{id} = ""; } + ($ptr, $fts) = $FORM->data($QryParm->{id}); + @ligne = @$ptr; + if (scalar(@ligne) == 1) { + chomp(@ligne); + ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split (/\|/,l2u($ligne[0])); + if ($QryParm->{id} eq $id) { + ($sel_annee,$sel_mois,$sel_jour) = split (/-/,$date); + ($sel_hr,$sel_mn) = split (/:/,$heure); + $sel_vehicle = $vehicle; + $sel_mileage = $mileage; + $sel_type = $type; + $sel_site = $site; + $sel_driver = $driver; + $sel_oil = $oil; + $message = "Modification donnée n° $QryParm->{id}"; + } else { $QryParm->{id} = ""; } + } else { $QryParm->{id} = ""; } } print ""; + #print ""; #print ""; if ($displayOnly ne 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."" - ."\n" - ."" - ."" - .""; + ."\n" + ."" + ."" + .""; $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - $i++; - if ($rap[$i] == 1) { - $entete = $entete.""; - } + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + $i++; + if ($rap[$i] == 1) { + $entete = $entete.""; + } } - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split(/\|/,$_); - if ($hr1 ne "") { $date1 = "$date1 $hr1"; } - if ($hr2 ne "") { $date2 = "$date2 $hr2"; } - if ($i eq 0) { - push(@csv,u2l("$date1;$date2;Nb jours;Code Site;$site;$h2o;$koh;Masse;$cCl;$cCO2;$cSO4;\"$rem\";$val")); - } - elsif (($id ne "") - && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date1,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date1 lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date1,5,2)))) { - - my ($cCl_mmol,$cCO2_mmol,$cSO4_mmol) = split(/\|/,""); - if ($cCl ne "") { $cCl_mmol = sprintf($fmt,$cCl/$GMOL{Cl}); }; - if ($cCO2 ne "") { $cCO2_mmol = sprintf($fmt,$cCO2/$GMOL{CO2}); }; - if ($cSO4 ne "") { $cSO4_mmol = sprintf($fmt,$cSO4/$GMOL{SO4}); }; - - my $mtot; - if ($m1 ne "") { $mtot = sprintf("%1.2f",$m1 + $m2 + $m3 + $m4); } - - my $nj = (qx(date -d "$date2" +%s) - qx(date -d "$date1" +%s))/86400; - my $f_H2O; - my $f_Cl; - my $f_C; - my $f_S; - if (($nj != 0) && ($mtot > 0)) { - $f_H2O = sprintf("%1.2f",($mtot - ($h2o + $GMOL{KOH}*$koh*$h2o/1000))/$nj); - if ($cCl > 0) { $f_Cl = sprintf("%1.3f",$f_H2O/1e6*$cCl); } - if ($cCO2 > 0) { $f_C = sprintf("%1.3f",$f_H2O/1e6*$cCO2*12/44); } - if ($cSO4 > 0) { $f_S = sprintf("%1.3f",$f_H2O/1e6*$cSO4*32/96); } - } - my @rapv; - my $iv = 0; - my $rapport = ""; - - for (@rapports) { - my ($num,$den,$nrp) = split(/\|/,$_); - $iv++; - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - if ($rap[$iv] == 1) { - $rapport = $rapport.""; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($displayOnly ne 1) { - $texte = $texte.""; - } - $texte = $texte."" - .""; - $tcsv = "$date1;$date2;$nj;$site;$aliasSite;$h2o;$koh;$mtot;"; - if ($QryParm->{'unite'} eq "mmol") { - $texte = $texte.""; - $tcsv = $tcsv."$cCl_mmol;$cCO2_mmol;$cSO4_mmol;"; - } else { - $texte = $texte.""; - $tcsv = $tcsv."$cCl;$cCO2;$cSO4;"; - } - $texte = $texte."$rapport\n"; - $tcsv = $tcsv."\"$rem\"\n"; - push(@csv,u2l($tcsv)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date1,$hr1,$date2,$hr2,$site,$cCl,$cCO2,$cSO4,$m1,$m2,$m3,$m4,$h2o,$koh,$rem,$val) = split(/\|/,$_); + if ($hr1 ne "") { $date1 = "$date1 $hr1"; } + if ($hr2 ne "") { $date2 = "$date2 $hr2"; } + if ($i eq 0) { + push(@csv,u2l("$date1;$date2;Nb jours;Code Site;$site;$h2o;$koh;Masse;$cCl;$cCO2;$cSO4;\"$rem\";$val")); + } + elsif (($id ne "") + && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date1,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date1 lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date1,5,2)))) { + + my ($cCl_mmol,$cCO2_mmol,$cSO4_mmol) = split(/\|/,""); + if ($cCl ne "") { $cCl_mmol = sprintf($fmt,$cCl/$GMOL{Cl}); }; + if ($cCO2 ne "") { $cCO2_mmol = sprintf($fmt,$cCO2/$GMOL{CO2}); }; + if ($cSO4 ne "") { $cSO4_mmol = sprintf($fmt,$cSO4/$GMOL{SO4}); }; + + my $mtot; + if ($m1 ne "") { $mtot = sprintf("%1.2f",$m1 + $m2 + $m3 + $m4); } + + my $nj = (qx(date -d "$date2" +%s) - qx(date -d "$date1" +%s))/86400; + my $f_H2O; + my $f_Cl; + my $f_C; + my $f_S; + if (($nj != 0) && ($mtot > 0)) { + $f_H2O = sprintf("%1.2f",($mtot - ($h2o + $GMOL{KOH}*$koh*$h2o/1000))/$nj); + if ($cCl > 0) { $f_Cl = sprintf("%1.3f",$f_H2O/1e6*$cCl); } + if ($cCO2 > 0) { $f_C = sprintf("%1.3f",$f_H2O/1e6*$cCO2*12/44); } + if ($cSO4 > 0) { $f_S = sprintf("%1.3f",$f_H2O/1e6*$cSO4*32/96); } + } + my @rapv; + my $iv = 0; + my $rapport = ""; + + for (@rapports) { + my ($num,$den,$nrp) = split(/\|/,$_); + $iv++; + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + if ($rap[$iv] == 1) { + $rapport = $rapport.""; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($displayOnly ne 1) { + $texte = $texte.""; + } + $texte = $texte."" + .""; + $tcsv = "$date1;$date2;$nj;$site;$aliasSite;$h2o;$koh;$mtot;"; + if ($QryParm->{'unite'} eq "mmol") { + $texte = $texte.""; + $tcsv = $tcsv."$cCl_mmol;$cCO2_mmol;$cSO4_mmol;"; + } else { + $texte = $texte.""; + $tcsv = $tcsv."$cCl;$cCO2;$cSO4;"; + } + $texte = $texte."$rapport\n"; + $tcsv = $tcsv."\"$rem\"\n"; + push(@csv,u2l($tcsv)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"

        Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
        ", - "Sites sélectionnés: $afficheSite
        ", - "Unité des concentrations ioniques: $unite
        ", - "Nombre de données affichées = $nbLignesRetenues / $nbData.

        \n", - "

        Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}&unite=$QryParm->{'unite'}\">$fileCSV

        \n"); + "Sites sélectionnés: $afficheSite
        ", + "Unité des concentrations ioniques: $unite
        ", + "Nombre de données affichées = $nbLignesRetenues / $nbData.

        \n", + "

        Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}&unite=$QryParm->{'unite'}\">$fileCSV

        \n"); if ($texte ne "") { - push(@html,"
        @@ -193,7 +194,7 @@ =head1 Query string parameter print "
        "; if ($QryParm->{id} ne "") { - print "{id}\">"; + print "{id}\">"; } print "\n"; @@ -204,70 +205,72 @@ =head1 Query string parameter
        Date et lieu du déplacement

        Date: "; - print " "; - print " "; - - print "  Heure: "; - print "
        "; - - print "Véhicule:
        \n"; - - print "Lieu:
        \n"; - print "

        "; - print "
        "; - - print "
        Informations sur le déplacement\n +for (@anneeListe) { + if ($_ == $sel_annee) { print ""; } else { print ""; } +} +print ""; +print " "; +print " "; + +print "  Heure: "; +print "
        "; + +print "Véhicule:
        \n"; + +print "Lieu:
        \n"; +print "

        "; +print "
        "; + +print "
        Informations sur le déplacement\n

        "; - print "Type de déplacement:
        "; - print " Conducteur:
        \n +print "Type de déplacement:
        "; +print " Conducteur:
        \n Kilomètre au compteur = km
        \n Carburant = €
        \n"; + # print "Débit (qualitatif) = \n"; - print "

        "; +print ""; print "
        "; # print "Observations :

        "; diff --git a/CODE/cgi-bin/gedit.pl b/CODE/cgi-bin/gedit.pl index 34531454..2bd3753d 100755 --- a/CODE/cgi-bin/gedit.pl +++ b/CODE/cgi-bin/gedit.pl @@ -76,7 +76,7 @@ =head1 Markitup customization # my @lignes; -my $me = $ENV{SCRIPT_NAME}; +my $me = $ENV{SCRIPT_NAME}; my $QryParm = $cgi->Vars; my $grid = $QryParm->{'grid'} // ""; my $file = $QryParm->{'file'} // ""; @@ -99,53 +99,53 @@ =head1 Markitup customization # ---- see what file has to be edited, and corresponding authorization for client # ---- new file (create) initialization # -if (scalar(@GID) == 2) { - if ($file ne "") { - $absfile = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDType.$GRIDName$file"; - if ($GRIDType eq 'DOMAIN' || $GRIDType eq 'GRIDS') { - $editOK = (clientHasEdit(type=>"authviews",name=>"*") && clientHasEdit(type=>"authprocs",name=>"*")); - $admOK = (clientHasAdm(type=>"authviews",name=>"*") && clientHasAdm(type=>"authprocs",name=>"*")); - } else { - $editOK = clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); - $admOK = clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); - } - unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } - if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } - if ( (!$editOK) && (!-e $absfile) ) { die "$name $__{'not found'} or $__{'not authorized'}" } - } else { die "$__{'No filename specified'}" } +if (scalar(@GID) == 2) { + if ($file ne "") { + $absfile = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDType.$GRIDName$file"; + if ($GRIDType eq 'DOMAIN' || $GRIDType eq 'GRIDS') { + $editOK = (clientHasEdit(type=>"authviews",name=>"*") && clientHasEdit(type=>"authprocs",name=>"*")); + $admOK = (clientHasAdm(type=>"authviews",name=>"*") && clientHasAdm(type=>"authprocs",name=>"*")); + } else { + $editOK = clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); + $admOK = clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName"); + } + unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } + if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } + if ( (!$editOK) && (!-e $absfile) ) { die "$name $__{'not found'} or $__{'not authorized'}" } + } else { die "$__{'No filename specified'}" } } else { die "$__{'Not a valid GRID requested (NOT gridtype.gridname)'}" } # ---- action is 'save' # if ($action eq 'save') { - if ($TS0 != (stat("$absfile"))[9]) { - htmlMsgNotOK("$name $_{'has been modified while you were editing'}"); - exit; - } - if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $name..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $absfile $absfile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - if ($conv eq "1") { - $txt = WebObs::Wiki::wiki2MMD($txt); - $txt = "WebObs: converted with wiki2MMD\n\n$txt"; - } - $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lignes,$txt); - print FILE @lignes ; - close(FILE); - htmlMsgOK($name); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $name"); - } - } else { htmlMsgNotOK("$me opening $name - $!") } - exit; + if ($TS0 != (stat("$absfile"))[9]) { + htmlMsgNotOK("$name $_{'has been modified while you were editing'}"); + exit; + } + if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $name..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $absfile $absfile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + if ($conv eq "1") { + $txt = WebObs::Wiki::wiki2MMD($txt); + $txt = "WebObs: converted with wiki2MMD\n\n$txt"; + } + $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lignes,$txt); + print FILE @lignes ; + close(FILE); + htmlMsgOK($name); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $name"); + } + } else { htmlMsgNotOK("$me opening $name - $!") } + exit; } # ---- action is 'edit' (default) @@ -154,6 +154,7 @@ =head1 Markitup customization @lignes = readFile($absfile); $TS0 = (stat($absfile))[9] ; chomp(@lignes); + # file contents as a string and determine markup type (WO or MMD) $txt = join("\n",@lignes); ($txt, my $meta) = WebObs::Wiki::stripMDmetadata($txt); @@ -190,12 +191,12 @@ =head1 Markitup customization -"; +"; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print " FIN -if (defined($QryParm->{'iref'})) { print "iref set" } +if (defined($QryParm->{'iref'})) { print "iref set" } if (defined($svg)) { - #djl-TBD: remove all attributes 'style=' so that FF can apply css rules .... - #djl-TBD: fontsize only used here (ie. at svg build time) as it participate in nodes' polygon sizes! - print "

        $GRIDType.$GRIDName

        \n"; - print "
        "; - print "$GRIDType.$GRIDName root nodes are those valid and active today
        "; - print "$legend"; - print "

        \n"; - print "
        "; - print $svg; - print "
        "; + +#djl-TBD: remove all attributes 'style=' so that FF can apply css rules .... +#djl-TBD: fontsize only used here (ie. at svg build time) as it participate in nodes' polygon sizes! + print "

        $GRIDType.$GRIDName

        \n"; + print "
        "; + print "$GRIDType.$GRIDName root nodes are those valid and active today
        "; + print "$legend"; + print "

        \n"; + print "
        "; + print $svg; + print "
        "; } else {die "Unable to create svg for ".$GRIDType.$GRIDName} -if ($dbg) { - open(WRT, ">$WEBOBS{PATH_TMP_APACHE}/gv"); - print(WRT $dbg); - close(WRT); +if ($dbg) { + open(WRT, ">$WEBOBS{PATH_TMP_APACHE}/gv"); + print(WRT $dbg); + close(WRT); } print "
        \n\n\n"; diff --git a/CODE/cgi-bin/index.pl b/CODE/cgi-bin/index.pl index ddc91c44..654ca8a8 100755 --- a/CODE/cgi-bin/index.pl +++ b/CODE/cgi-bin/index.pl @@ -79,13 +79,12 @@ =head1 NAVIGATION FILE .html FORMAT use WebObs::i18n; use Locale::TextDomain('webobs'); - # if the client is not a valid user, ends here !! if (!WebObs::Users::clientIsValid) { - print $cgi->header(-type=>'text/html', -charset=>'utf-8'); - print "

        $WEBOBS{WEBOBS_ID}: $WEBOBS{VERSION}

        " - ."Sorry, user '$USERS{$CLIENT}{LOGIN}' is not valid or is waiting for validation by an administrator..."; - exit(1); + print $cgi->header(-type=>'text/html', -charset=>'utf-8'); + print "

        $WEBOBS{WEBOBS_ID}: $WEBOBS{VERSION}

        " + ."Sorry, user '$USERS{$CLIENT}{LOGIN}' is not valid or is waiting for validation by an administrator..."; + exit(1); } # ---- reads in configuration options ------------------ @@ -93,9 +92,9 @@ =head1 NAVIGATION FILE .html FORMAT my $logout = "login: $USERS{$CLIENT}{FULLNAME}"; my $lo = ""; if ($MENU{CLEAR_AUTHENTICATION_CACHE} ne "") { - $lo = CGI->new->url(); - $lo =~ s/:\/\//:\/\/$MENU{CLEAR_AUTHENTICATION_CACHE}@/; - $logout = "login: $USERS{$CLIENT}{FULLNAME}"; + $lo = CGI->new->url(); + $lo =~ s/:\/\//:\/\/$MENU{CLEAR_AUTHENTICATION_CACHE}@/; + $logout = "login: $USERS{$CLIENT}{FULLNAME}"; } # ---- language cookie management ----------------------- @@ -106,17 +105,17 @@ =head1 NAVIGATION FILE .html FORMAT my $langue_cgi = defined($cgi->param('langue'))?$cgi->param('langue'):""; if ( $langue_cgi =~ /^[a-zA-Z][a-zA-Z]/ && -d "$WEBOBS{ROOT_I18N}/locales/".($langue_cgi)."/LC_MESSAGES" ) { - $langue_utilisee = $langue_cgi; + $langue_utilisee = $langue_cgi; } elsif ( $langue_cookie =~ /^[a-zA-Z][a-zA-Z]/ && -d "$WEBOBS{ROOT_I18N}/locales/".($langue_cookie)."/LC_MESSAGES" ) { - $langue_utilisee = $langue_cookie; + $langue_utilisee = $langue_cookie; } else { - $langue_utilisee = $WEBOBS{LOCALE}; + $langue_utilisee = $WEBOBS{LOCALE}; } if ( $langue_cookie ne $langue_utilisee ) { - my $cookie1 = new CGI::Cookie(-name=>'langue_webobs',-value=>$langue_utilisee); - print $cgi->header(-cookie=>[$cookie1],-charset=>"utf-8",-type=>'text/html'); + my $cookie1 = new CGI::Cookie(-name=>'langue_webobs',-value=>$langue_utilisee); + print $cgi->header(-cookie=>[$cookie1],-charset=>"utf-8",-type=>'text/html'); } else { - print $cgi->header(-charset=>"utf-8",-type=>'text/html'); + print $cgi->header(-charset=>"utf-8",-type=>'text/html'); } cherche_langue($langue_utilisee); @@ -125,13 +124,13 @@ =head1 NAVIGATION FILE .html FORMAT my %nom_langue; my @liste_langues; for my $code_desc (split(/\|/,$WEBOBS{"LANGUAGE_LIST"})) { - my ($code,$desc) = split(/:/,$code_desc); - push(@liste_langues,$code); - $nom_langue{$code}=$desc; + my ($code,$desc) = split(/:/,$code_desc); + push(@liste_langues,$code); + $nom_langue{$code}=$desc; } my $drapeaux=""; for my $la (@liste_langues) { - $drapeaux .= ''.$nom_langue{$la}.''; + $drapeaux .= ''.$nom_langue{$la}.''; } $drapeaux =~ s/'/\\'/g; @@ -142,7 +141,7 @@ =head1 NAVIGATION FILE .html FORMAT my @liste_title = split(/;/,$MENU{"LOGO_TITLES"}); my $logos=""; for my $i (0..$#liste_logos) { -i $logos .= "\"$liste_title[$i]\""; + i $logos .= "\"$liste_title[$i]\""; } $logos =~ s/'/\\'/g; @@ -162,9 +161,9 @@ =head1 NAVIGATION FILE .html FORMAT my @groups = WebObs::Users::userListGroup($CLIENT); my $group; for (@groups) { - $group = $_; - chomp $group; - push(@menu,readCfgFile("$WEBOBS{ROOT_CONF}/MENUS/$group","utf8")); + $group = $_; + chomp $group; + push(@menu,readCfgFile("$WEBOBS{ROOT_CONF}/MENUS/$group","utf8")); } # adds optional additionnal menu for USER @@ -172,45 +171,46 @@ =head1 NAVIGATION FILE .html FORMAT # legacy format .rc if ( $menunav =~ m/.rc$/) { - my $l1 = my $l2 = 0; - $menuhtml = "
          "; - for (@menu) { - my ($titre,$lien)=split(/\|/,$_); - $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; - my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; - if (substr($titre,0,1) eq "+" || (substr($titre,0,1) eq "!" && $admOK)) { - if ($l2==1) { $menuhtml .= "
        "; $l2 = 0; } - if ($l1==1) { $menuhtml .= ""; } - $l1 = 1; - $menuhtml .= "
      • ".substr($titre,1)."\n"; - next; - } - if ( substr($titre,0,1) eq "*" ){ - next if (! $admOK); - $titre = substr($titre,1); - } - if ($l2==0) { $menuhtml .= "
          "; $l2 = 1; } - $menuhtml .= "
        • $titre
          • \n"; - } - if ($l2==1) { $menuhtml .= "
        "; } - if ($l1==1) { $menuhtml .= "
        • "; } - $menuhtml .=""; - $wmcss="wm2.css"; - -# new format .html (CSS) + my $l1 = my $l2 = 0; + $menuhtml = "
          "; + for (@menu) { + my ($titre,$lien)=split(/\|/,$_); + $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; + my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; + if (substr($titre,0,1) eq "+" || (substr($titre,0,1) eq "!" && $admOK)) { + if ($l2==1) { $menuhtml .= "
        "; $l2 = 0; } + if ($l1==1) { $menuhtml .= ""; } + $l1 = 1; + $menuhtml .= "
      • ".substr($titre,1)."\n"; + next; + } + if ( substr($titre,0,1) eq "*" ){ + next if (! $admOK); + $titre = substr($titre,1); + } + if ($l2==0) { $menuhtml .= "
          "; $l2 = 1; } + $menuhtml .= "
        • $titre
          • \n"; + } + if ($l2==1) { $menuhtml .= "
        "; } + if ($l1==1) { $menuhtml .= "
        • "; } + $menuhtml .=""; + $wmcss="wm2.css"; + + # new format .html (CSS) } else { - @menu = grep { $_ !~ /^\*/ } @menu if (! $admOK); - for(@menu) { - s/^\*//; - s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; - my $xtrn = ($_ =~ m/http.?:\/\//) ? " class=\"externe\" ": ""; - s/"); - push(@menu,""); - $menuhtml = join("\n",@menu); - $wmcss="wm2n.css"; + @menu = grep { $_ !~ /^\*/ } @menu if (! $admOK); + for(@menu) { + s/^\*//; + s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; + my $xtrn = ($_ =~ m/http.?:\/\//) ? " class=\"externe\" ": ""; + s/"); + push(@menu,""); + $menuhtml = join("\n",@menu); + $wmcss="wm2n.css"; } + # ---- 'signature' that will show up at bottom # my $year = WebObs::Utils::num2roman(strftime("%Y", localtime)); diff --git a/CODE/cgi-bin/listGRIDS.pl b/CODE/cgi-bin/listGRIDS.pl index 5d7b7f5f..3f98fc87 100755 --- a/CODE/cgi-bin/listGRIDS.pl +++ b/CODE/cgi-bin/listGRIDS.pl @@ -61,7 +61,7 @@ =head1 Query string parameters my $subsetDomain = checkParam(scalar($cgi->param('domain')), qr/^[a-zA-Z0-9_-]*$/, "domain") // ""; my $subsetType = checkParam(scalar($cgi->param('type')), qr/^[a-zA-Z0-9_-]*$/, "type") // "all"; - $subsetType = 'all' if ( $subsetType ne 'proc' && $subsetType ne 'view' && $subsetType ne 'sefran'); +$subsetType = 'all' if ( $subsetType ne 'proc' && $subsetType ne 'view' && $subsetType ne 'sefran'); my $wantViews = ($subsetType eq 'all' || $subsetType eq 'view') ? 1 : 0; my $wantProcs = ($subsetType eq 'all' || $subsetType eq 'proc') ? 1 : 0; my $wantSefrans = ($subsetType eq 'all' || $subsetType eq 'sefran') ? 1 : 0; @@ -77,76 +77,80 @@ =head1 Query string parameters my $admPROCS = 0; my $descGridType = my $descGridName = my $descLegacy = ""; - # Open an SQLite connection to the domains database sub connectDbDomains { - return DBI->connect("dbi:SQLite:$WEBOBS{SQL_DOMAINS}", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $WEBOBS{SQL_DOMAINS}: $DBI::errstr"; + return DBI->connect("dbi:SQLite:$WEBOBS{SQL_DOMAINS}", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $WEBOBS{SQL_DOMAINS}: $DBI::errstr"; } sub getDomains { - # Return the (code, name) tuples from the domains table. - # A domain code can be provided to only fetch this domain. - # Returns a reference to list of array references. - my $dbh = shift; - my $domain = shift // ''; - my $where = ''; - my @bind_values = (); - if ($domain) { - $where = "where CODE = ?"; - push @bind_values, $domain; - } - my $q = "select CODE, NAME from $WEBOBS{SQL_TABLE_DOMAINS} $where order by OOA"; - return $dbh->selectall_arrayref($q, undef, @bind_values); + + # Return the (code, name) tuples from the domains table. + # A domain code can be provided to only fetch this domain. + # Returns a reference to list of array references. + my $dbh = shift; + my $domain = shift // ''; + my $where = ''; + my @bind_values = (); + if ($domain) { + $where = "where CODE = ?"; + push @bind_values, $domain; + } + my $q = "select CODE, NAME from $WEBOBS{SQL_TABLE_DOMAINS} $where order by OOA"; + return $dbh->selectall_arrayref($q, undef, @bind_values); } sub getDomainGrids { - # Return the list of names of grids from the grids2domains table - # for the provided type ('PROC' or 'VIEW') and domain code. - # Returns a reference to a list of grid names. - my $dbh = shift; - my $type = shift; - my $domain_code = shift; - my $q = "select NAME from $WEBOBS{SQL_TABLE_GRIDS} " - ."where TYPE = ? and DCODE = ? order by name"; - return $dbh->selectcol_arrayref($q, { 'Columns' => [1] }, - $type, $domain_code); + + # Return the list of names of grids from the grids2domains table + # for the provided type ('PROC' or 'VIEW') and domain code. + # Returns a reference to a list of grid names. + my $dbh = shift; + my $type = shift; + my $domain_code = shift; + my $q = "select NAME from $WEBOBS{SQL_TABLE_GRIDS} " + ."where TYPE = ? and DCODE = ? order by name"; + return $dbh->selectcol_arrayref($q, { 'Columns' => [1] }, + $type, $domain_code); } sub getDomainProcs { - # Return the list of procs for a domain using getDomainGrids - my $dbh = shift; - my $domain_code = shift; - return getDomainGrids($dbh, 'PROC', $domain_code); + + # Return the list of procs for a domain using getDomainGrids + my $dbh = shift; + my $domain_code = shift; + return getDomainGrids($dbh, 'PROC', $domain_code); } sub getDomainViews { - # Return the list of views for a domain using getDomainGrids - my $dbh = shift; - my $domain_code = shift; - return getDomainGrids($dbh, 'VIEW', $domain_code); + + # Return the list of views for a domain using getDomainGrids + my $dbh = shift; + my $domain_code = shift; + return getDomainGrids($dbh, 'VIEW', $domain_code); } sub getDomainSefrans { - # Return the list of sefrans for a domain using getDomainGrids - my $dbh = shift; - my $domain_code = shift; - return getDomainGrids($dbh, 'SEFRAN', $domain_code); + + # Return the list of sefrans for a domain using getDomainGrids + my $dbh = shift; + my $domain_code = shift; + return getDomainGrids($dbh, 'SEFRAN', $domain_code); } if ($subsetDomain ne '') { - $descGridType = 'DOMAIN'; - $descGridName = $subsetDomain; + $descGridType = 'DOMAIN'; + $descGridName = $subsetDomain; } else { - $descGridType = 'GRIDS'; - switch ($subsetType) { - case 'all' { $descGridName = 'ALL'; } - case 'view' { $descGridName = 'VIEWS'; $descLegacy = 'VIEW.VIEWS'; } - case 'proc' { $descGridName = 'PROCS'; $descLegacy = 'PROC.PROCS'; }; - } + $descGridType = 'GRIDS'; + switch ($subsetType) { + case 'all' { $descGridName = 'ALL'; } + case 'view' { $descGridName = 'VIEWS'; $descLegacy = 'VIEW.VIEWS'; } + case 'proc' { $descGridName = 'PROCS'; $descLegacy = 'PROC.PROCS'; }; + } } # creation of new view or proc is allowed only if the user has admin authorization for ALL grids (views and/or procs) @@ -163,10 +167,10 @@ sub getDomainSefrans { my %domainViews = map(($_->[0] => []), @$domains); my %domainSefrans = map(($_->[0] => []), @$domains); for my $d (@$domains) { - my ($code, $name) = @$d; - push @{$domainProcs{$code}}, @{getDomainProcs($dbh, $code)} if $wantProcs; - push @{$domainViews{$code}}, @{getDomainViews($dbh, $code)} if $wantViews; - push @{$domainSefrans{$code}}, @{getDomainSefrans($dbh, $code)} if $wantSefrans; + my ($code, $name) = @$d; + push @{$domainProcs{$code}}, @{getDomainProcs($dbh, $code)} if $wantProcs; + push @{$domainViews{$code}}, @{getDomainViews($dbh, $code)} if $wantViews; + push @{$domainSefrans{$code}}, @{getDomainSefrans($dbh, $code)} if $wantSefrans; } $dbh->disconnect(); @@ -187,16 +191,15 @@ sub getDomainSefrans {
        "; - # ---- Title is = selected type (aka subsetType) # print "        "; print "

        "; - print "$DOMAINS{$subsetDomain}{NAME} " if ($subsetDomain ne ""); - print "$GRIDS{SHOW_GRIDS_TITLE}\n" if ($subsetType eq 'all'); - print "Views" if ($subsetType eq 'view'); - print "Procs" if ($subsetType eq 'proc'); - print "Sefrans" if ($subsetType eq 'sefran'); +print "$DOMAINS{$subsetDomain}{NAME} " if ($subsetDomain ne ""); +print "$GRIDS{SHOW_GRIDS_TITLE}\n" if ($subsetType eq 'all'); +print "Views" if ($subsetType eq 'view'); +print "Procs" if ($subsetType eq 'proc'); +print "Sefrans" if ($subsetType eq 'sefran'); print "

        \n"; # ---- Subtitle menu to other domains/grids displays @@ -207,14 +210,14 @@ sub getDomainSefrans { print " | ".($subsetType ne 'view' || $subsetDomain ne '' ? "Views":"Views"); print " | ".($subsetType ne 'sefran' || $subsetDomain ne '' ? "Sefrans":"Sefrans"); if ($subsetDomain eq '') { - print " - Domains: "; - print join(" | ", map("[0]&type=$subsetType\">$_->[1]", @$domains)); + print " - Domains: "; + print join(" | ", map("[0]&type=$subsetType\">$_->[1]", @$domains)); } else { - print " - $DOMAINS{$subsetDomain}{NAME}"; - print " ".($subsetType ne 'all' ? "Grids":"Grids"); - print " | ".($subsetType ne 'proc' ? "Procs":"Procs"); - print " | ".($subsetType ne 'view' ? "Views":"Views"); - print " | ".($subsetType ne 'sefran' ? "Sefrans":"Sefrans"); + print " - $DOMAINS{$subsetDomain}{NAME}"; + print " ".($subsetType ne 'all' ? "Grids":"Grids"); + print " | ".($subsetType ne 'proc' ? "Procs":"Procs"); + print " | ".($subsetType ne 'view' ? "Views":"Views"); + print " | ".($subsetType ne 'sefran' ? "Sefrans":"Sefrans"); } print " ]

        "; @@ -222,189 +225,188 @@ sub getDomainSefrans { # printdesc('Purpose','DESCRIPTION',$descGridType,$descGridName,$descLegacy); - # ---- list subsetType grids, grouped by domains # print "
        "; - my $d = my $p = my $v = 0; - if (@$domains) { - - # ---- The invisible-until-triggered-by-js popups ;-) - print ""; - print WebObs::Search::searchpopup(); - print geditpopup(); - print feditpopup(); - - # ---- The GRIDS table - # - print "\n
        \n"; - - print ""; - if ($subsetDomain eq "") { - print ""; - } - print "" if ($subsetType ne ""); - print ""; - print ""; - print "" if ($showType); - print "" if ($showOwnr); - print ""; - if ($wantProcs || $wantSefrans) { - print ""; - } - print "\n"; - for my $d (@$domains) { - my ($dc, $dn) = @$d; - my @procs; - my $ovl; - if ($wantProcs) { - @procs = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), - @{$domainProcs{$dc}}); - } - my $np = scalar(@procs); - my @views; - if ($wantViews) { - @views = grep(WebObs::Users::clientHasRead(type=>"authviews", name=>$_), - @{$domainViews{$dc}}); - } - my $nv = scalar(@views); - my @sefrans; - if ($wantSefrans) { - @sefrans = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), - @{$domainSefrans{$dc}}); - } - my $ns = scalar(@sefrans); - my $domrows = $np+$nv+$ns; - if ( $domrows > 0 ) { - print ""; - print "" if ($vs ne $sefrans[0]); - print "" if ($subsetType ne ""); - $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vs}{DESCRIPTION}."',CAPTION,'SEFRAN.$vs')\""; - print ""; - print ""; - print "" if ($showType); - print "" if ($showOwnr); - if ( -d "$G{$vs}{ROOT}" ) { - print ""; - print ""; - } - print "\n"; - } - } - if ( $np > 0 ) { - for my $vp (@procs) { - my %G = readProc($vp); - if (%G) { - print "" if ($vp ne $procs[0]); - print "" if ($subsetType ne ""); - $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vp}{DESCRIPTION}."',CAPTION,'PROC.$vp')\""; - print ""; - print ""; - print "" if ($showType); - print "" if ($showOwnr); - if ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_GRAPHS}" ) { - print ""; - print ""; - } - print "\n"; - } - } - if ( $nv > 0 ) { - for my $vn (@views) { - my %G = readView($vn); - if (%G) { - print "" if ($np > 0 || $vn ne $views[0]); - print ""; - $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vn}{DESCRIPTION}."',CAPTION,'VIEW.$vn')\""; - print "" - if ($showType); - print "" if ($showOwnr); - if ( -d "$WEBOBS{ROOT_OUTG}/VIEW.$vn/$WEBOBS{PATH_OUTG_MAPS}" ) { - print ""; - if ($wantProcs) { - print ""; - } - } - print "\n"; - } - } - } - } - print "
        "; - if (WebObs::Users::clientHasAdm(type=>"authmisc",name=>"*")) { - print "    "; - } - print "DomainGrid"; - if ($admVIEWS || $admPROCS) { - print " " - } - print "   NameNodesTypeOwnerGraphs"; - if ( $admPROCS ) { - print ""; - } - print "   Raw Data

        $dn

        " if ($subsetDomain eq ""); - if ( $ns > 0 ) { - for my $vs (@sefrans) { - my %G = readSefran($vs); - if (%G) { - print "
        SEFRAN"; - if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$G{$vs}{MC3_NAME})) { print " " } - print "  $G{$vs}{NAME}"; - print "".(split('\|',$G{$vs}{CHANNELLIST}))." channels".(defined($G{$vs}{TYPE}) ? $G{$vs}{TYPE} : "")."".(defined($G{$vs}{OWNCODE}) ? - (defined($OWNRS{$G{$vs}{OWNCODE}}) - ? $OWNRS{$G{$vs}{OWNCODE}} - : $G{$vs}{OWNCODE}) : "") - ."\"$vs\""; - } else { print " " } - print ""; - if (defined($G{$vs}{MC3_NAME}) && $G{$vs}{MC3_NAME} ne '') { - my %MC3 = readCfg("$WEBOBS{ROOT_CONF}/$G{$vs}{MC3_NAME}.conf"); - print "\"$G{$vs}{MC3_NAME}\""; - } - print "
        PROC"; - print ""; - if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$vp)) { print " " } - print "  $G{$vp}{NAME}"; - print "".scalar(@{$G{$vp}{NODESLIST}})." "; - if (defined($G{$vp}{NODE_NAME})) { printf ("%s%s","$G{$vp}{NODE_NAME}",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } - else { printf ("node%s",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } - print "".(defined($G{$vp}{TYPE}) ? $G{$vp}{TYPE} : "") - ."".(defined($G{$vp}{OWNCODE}) ? - (defined($OWNRS{$G{$vp}{OWNCODE}}) - ? $OWNRS{$G{$vp}{OWNCODE}} - : $G{$vp}{OWNCODE}) : "") - ."\"$vp\""; - } elsif ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_EVENTS}" ) { - print "\"$vp\""; - } else { print " " } - print ""; - if (defined($G{$vp}{FORM}) && $G{$vp}{FORM} ne '') { - my %F = readCfg("$WEBOBS{PATH_FORMS}/$G{$vp}{FORM}/$G{$vp}{FORM}.conf"); - print "\"$G{$vp}{FORM}\""; - } else { - if (defined($G{$vp}{URNDATA}) && $G{$vp}{URNDATA} ne '') { - print "\"""; - } - } - print "
        VIEW"; - print ""; - if (WebObs::Users::clientHasEdit(type=>"authviews",name=>$vn)) { print " " } - print "  $G{$vn}{NAME}"; - print "".scalar(@{$G{$vn}{NODESLIST}})." "; - if (defined($G{$vn}{NODE_NAME})) { printf ("%s%s","$G{$vn}{NODE_NAME}",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } - else { printf ("node%s",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } - print "".(defined($G{$vn}{TYPE}) ? $G{$vn}{TYPE} : "")."".(defined($G{$vn}{OWNCODE}) ? - (defined($OWNRS{$G{$vn}{OWNCODE}}) - ? $OWNRS{$G{$vn}{OWNCODE}} - : $G{$vn}{OWNCODE}) : "") - ."\"$vn\""; - } else { print " " } - print "

        "; - } else { - print "

        ** No domain defined or matching '$subsetDomain' **

        "; - } +my $d = my $p = my $v = 0; +if (@$domains) { + + # ---- The invisible-until-triggered-by-js popups ;-) + print ""; + print WebObs::Search::searchpopup(); + print geditpopup(); + print feditpopup(); + + # ---- The GRIDS table + # + print "\n
        \n"; + + print ""; + if ($subsetDomain eq "") { + print ""; + } + print "" if ($subsetType ne ""); + print ""; + print ""; + print "" if ($showType); + print "" if ($showOwnr); + print ""; + if ($wantProcs || $wantSefrans) { + print ""; + } + print "\n"; + for my $d (@$domains) { + my ($dc, $dn) = @$d; + my @procs; + my $ovl; + if ($wantProcs) { + @procs = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), + @{$domainProcs{$dc}}); + } + my $np = scalar(@procs); + my @views; + if ($wantViews) { + @views = grep(WebObs::Users::clientHasRead(type=>"authviews", name=>$_), + @{$domainViews{$dc}}); + } + my $nv = scalar(@views); + my @sefrans; + if ($wantSefrans) { + @sefrans = grep(WebObs::Users::clientHasRead(type=>"authprocs", name=>$_), + @{$domainSefrans{$dc}}); + } + my $ns = scalar(@sefrans); + my $domrows = $np+$nv+$ns; + if ( $domrows > 0 ) { + print ""; + print "" if ($vs ne $sefrans[0]); + print "" if ($subsetType ne ""); + $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vs}{DESCRIPTION}."',CAPTION,'SEFRAN.$vs')\""; + print ""; + print ""; + print "" if ($showType); + print "" if ($showOwnr); + if ( -d "$G{$vs}{ROOT}" ) { + print ""; + print ""; + } + print "\n"; + } + } + if ( $np > 0 ) { + for my $vp (@procs) { + my %G = readProc($vp); + if (%G) { + print "" if ($vp ne $procs[0]); + print "" if ($subsetType ne ""); + $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vp}{DESCRIPTION}."',CAPTION,'PROC.$vp')\""; + print ""; + print ""; + print "" if ($showType); + print "" if ($showOwnr); + if ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_GRAPHS}" ) { + print ""; + print ""; + } + print "\n"; + } + } + if ( $nv > 0 ) { + for my $vn (@views) { + my %G = readView($vn); + if (%G) { + print "" if ($np > 0 || $vn ne $views[0]); + print ""; + $ovl = " onMouseOut=\"nd()\" onMouseOver=\"overlib('".$G{$vn}{DESCRIPTION}."',CAPTION,'VIEW.$vn')\""; + print "" + if ($showType); + print "" if ($showOwnr); + if ( -d "$WEBOBS{ROOT_OUTG}/VIEW.$vn/$WEBOBS{PATH_OUTG_MAPS}" ) { + print ""; + if ($wantProcs) { + print ""; + } + } + print "\n"; + } + } + } + } + print "
        "; + if (WebObs::Users::clientHasAdm(type=>"authmisc",name=>"*")) { + print "    "; + } + print "DomainGrid"; + if ($admVIEWS || $admPROCS) { + print " " + } + print "   NameNodesTypeOwnerGraphs"; + if ( $admPROCS ) { + print ""; + } + print "   Raw Data

        $dn

        " if ($subsetDomain eq ""); + if ( $ns > 0 ) { + for my $vs (@sefrans) { + my %G = readSefran($vs); + if (%G) { + print "
        SEFRAN"; + if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$G{$vs}{MC3_NAME})) { print " " } + print "  $G{$vs}{NAME}"; + print "".(split('\|',$G{$vs}{CHANNELLIST}))." channels".(defined($G{$vs}{TYPE}) ? $G{$vs}{TYPE} : "")."".(defined($G{$vs}{OWNCODE}) ? + (defined($OWNRS{$G{$vs}{OWNCODE}}) + ? $OWNRS{$G{$vs}{OWNCODE}} + : $G{$vs}{OWNCODE}) : "") + ."\"$vs\""; + } else { print " " } + print ""; + if (defined($G{$vs}{MC3_NAME}) && $G{$vs}{MC3_NAME} ne '') { + my %MC3 = readCfg("$WEBOBS{ROOT_CONF}/$G{$vs}{MC3_NAME}.conf"); + print "\"$G{$vs}{MC3_NAME}\""; + } + print "
        PROC"; + print ""; + if (WebObs::Users::clientHasEdit(type=>"authprocs",name=>$vp)) { print " " } + print "  $G{$vp}{NAME}"; + print "".scalar(@{$G{$vp}{NODESLIST}})." "; + if (defined($G{$vp}{NODE_NAME})) { printf ("%s%s","$G{$vp}{NODE_NAME}",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } + else { printf ("node%s",scalar(@{$G{$vp}{NODESLIST}})>1?"s":"") } + print "".(defined($G{$vp}{TYPE}) ? $G{$vp}{TYPE} : "") + ."".(defined($G{$vp}{OWNCODE}) ? + (defined($OWNRS{$G{$vp}{OWNCODE}}) + ? $OWNRS{$G{$vp}{OWNCODE}} + : $G{$vp}{OWNCODE}) : "") + ."\"$vp\""; + } elsif ( -d "$WEBOBS{ROOT_OUTG}/PROC.$vp/$WEBOBS{PATH_OUTG_EVENTS}" ) { + print "\"$vp\""; + } else { print " " } + print ""; + if (defined($G{$vp}{FORM}) && $G{$vp}{FORM} ne '') { + my %F = readCfg("$WEBOBS{PATH_FORMS}/$G{$vp}{FORM}/$G{$vp}{FORM}.conf"); + print "\"$G{$vp}{FORM}\""; + } else { + if (defined($G{$vp}{URNDATA}) && $G{$vp}{URNDATA} ne '') { + print "\"""; + } + } + print "
        VIEW"; + print ""; + if (WebObs::Users::clientHasEdit(type=>"authviews",name=>$vn)) { print " " } + print "  $G{$vn}{NAME}"; + print "".scalar(@{$G{$vn}{NODESLIST}})." "; + if (defined($G{$vn}{NODE_NAME})) { printf ("%s%s","$G{$vn}{NODE_NAME}",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } + else { printf ("node%s",scalar(@{$G{$vn}{NODESLIST}})>1?"s":"") } + print "".(defined($G{$vn}{TYPE}) ? $G{$vn}{TYPE} : "")."".(defined($G{$vn}{OWNCODE}) ? + (defined($OWNRS{$G{$vn}{OWNCODE}}) + ? $OWNRS{$G{$vn}{OWNCODE}} + : $G{$vn}{OWNCODE}) : "") + ."\"$vn\""; + } else { print " " } + print "

        "; +} else { + print "

        ** No domain defined or matching '$subsetDomain' **

        "; +} print "
        \n"; # ---- Protocole (aka 'Informations' of subsetType) @@ -422,116 +424,118 @@ sub getDomainSefrans { # ----------------------------------------------------------------------------- # printdesc (title,suffix,type,name,legacy,[top]) sub printdesc { - my @desc; - my $editCGI = "/cgi-bin/gedit.pl"; - my $go2top = ""; - - my $title = $_[0]; - my $suffix = $GRIDS{"$_[1]_SUFFIX"}; - my $type = $_[2]; - my $name = $_[3]; - my $fileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$type.$name$suffix"; - if ($_[4] ne '' && ! -e $fileDesc) { - my $legacyfileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$_[4]$suffix"; - if (-e $legacyfileDesc) { - copy($legacyfileDesc, $fileDesc); - } - } - if (defined($_[5])) { - $go2top = "  "; - } - - if (-e $fileDesc) { - @desc = readFile($fileDesc); - } - my $htmlcontents = "
           "; - $htmlcontents .= "$__{$title}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= "$go2top

        "; - if ($#desc >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@desc))."

        \n" } - $htmlcontents .= "
        \n"; - - print $htmlcontents; + my @desc; + my $editCGI = "/cgi-bin/gedit.pl"; + my $go2top = ""; + + my $title = $_[0]; + my $suffix = $GRIDS{"$_[1]_SUFFIX"}; + my $type = $_[2]; + my $name = $_[3]; + my $fileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$type.$name$suffix"; + if ($_[4] ne '' && ! -e $fileDesc) { + my $legacyfileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$_[4]$suffix"; + if (-e $legacyfileDesc) { + copy($legacyfileDesc, $fileDesc); + } + } + if (defined($_[5])) { + $go2top = "  "; + } + + if (-e $fileDesc) { + @desc = readFile($fileDesc); + } + my $htmlcontents = "
           "; + $htmlcontents .= "$__{$title}"; + if ($editOK == 1) { $htmlcontents .= "  " } + $htmlcontents .= "$go2top

        "; + if ($#desc >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@desc))."

        \n" } + $htmlcontents .= "
        \n"; + + print $htmlcontents; } # ----------------------------------------------------------------------------- # ---- helper edit grid popup sub geditpopup { - # prepares a list of grid's templates - my @tplates; - my @gt; - push(@gt,"VIEW") if ($admVIEWS); - push(@gt,"PROC,SEFRAN") if ($admPROCS); - my @tmp = glob("$WEBOBS{ROOT_CODE}/tplates/{".join(',',@gt)."}.*"); - foreach my $t (@tmp) { + + # prepares a list of grid's templates + my @tplates; + my @gt; + push(@gt,"VIEW") if ($admVIEWS); + push(@gt,"PROC,SEFRAN") if ($admPROCS); + my @tmp = glob("$WEBOBS{ROOT_CODE}/tplates/{".join(',',@gt)."}.*"); + foreach my $t (@tmp) { if (! -l $t) { - my @conf = readCfg($t); + my @conf = readCfg($t); next if (@conf == 1); # readCfg returns [0] if the file is empty my %G = @conf; - $t =~ s/$WEBOBS{ROOT_CODE}\/tplates\///; - my ($gt,$gn) = split(/\./,$t); - push(@tplates,"$gt|$gn|$G{DESCRIPTION}"); + $t =~ s/$WEBOBS{ROOT_CODE}\/tplates\///; + my ($gt,$gn) = split(/\./,$t); + push(@tplates,"$gt|$gn|$G{DESCRIPTION}"); } - } - - my $SP = ""; - $SP .= "
        "; - $SP .= ""; - $SP .= "

        Create/edit a GRID

        "; - $SP .= ""; - $SP .= " \n"; - $SP .= "

        "; - - $SP .= ""; - $SP .= " \n"; - $SP .= "

        "; - - $SP .= "

        "; - $SP .= ""; - $SP .= ""; - $SP .= "

        "; - $SP .= ""; - return $SP; + } + + my $SP = ""; + $SP .= "
        "; + $SP .= "
        "; + $SP .= "

        Create/edit a GRID

        "; + $SP .= ""; + $SP .= " \n"; + $SP .= "

        "; + + $SP .= ""; + $SP .= " \n"; + $SP .= "

        "; + + $SP .= "

        "; + $SP .= ""; + $SP .= ""; + $SP .= "

        "; + $SP .= "
        "; + return $SP; } # ---- helper edit form popup sub feditpopup { - # prepares a list of form's templates - my $SP = ""; - $SP .= "
        "; - $SP .= "
        "; - $SP .= "

        Create/edit a FORM

        "; - $SP .= ""; - my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; - opendir my $dir, ($tdir) or die "Cannot open directory: $!"; - my @templates = sort grep (/FORM\./, readdir($dir)); - closedir $dir; - $SP .= " "; - $SP .= "

        "; - $SP .= ""; - $SP .= " \n"; - - $SP .= "

        "; - $SP .= ""; - $SP .= ""; - $SP .= "

        "; - $SP .= "
        "; - return $SP; + + # prepares a list of form's templates + my $SP = ""; + $SP .= "
        "; + $SP .= "
        "; + $SP .= "

        Create/edit a FORM

        "; + $SP .= ""; + my $tdir = "$WEBOBS{ROOT_CODE}/tplates"; + opendir my $dir, ($tdir) or die "Cannot open directory: $!"; + my @templates = sort grep (/FORM\./, readdir($dir)); + closedir $dir; + $SP .= " "; + $SP .= "

        "; + $SP .= ""; + $SP .= " \n"; + + $SP .= "

        "; + $SP .= ""; + $SP .= ""; + $SP .= "

        "; + $SP .= "
        "; + return $SP; } __END__ diff --git a/CODE/cgi-bin/mailB3.pl b/CODE/cgi-bin/mailB3.pl index eda7ca85..4dcf7819 100755 --- a/CODE/cgi-bin/mailB3.pl +++ b/CODE/cgi-bin/mailB3.pl @@ -147,53 +147,53 @@ sub print_foot { sub print_form { - my ($y,$m,$d,$id,$evt) = split(/\//,$g); - my ($evt_y,$evt_m,$evt_d,$evt_H,$evt_M,$evt_S,$evt_loc) = unpack("a4a2a2xa2a2a2xa*",$evt); - my $b3_urn = "$WEBOBS{'URN_OUTG'}/$grid/$ts/$g"; - my $evt_email = $P{TRIGGER_EMAIL}; - my $evt_subject = $P{TRIGGER_SUBJECT}; - my $report_email = $P{REPORT_EMAIL}; - my ($evt_latitude,$evt_longitude,$evt_magnitude,$evt_depth,$evt_region,$evt_department,$evt_agency); - my $report_file = "$evt.pdf"; - my $report_subject = "$P{REPORT_SUBJECT}"; - my $report_message; - - # reads needed information from the event - my $triggerOK = 1; - my $trigger_check = 'checked'; - my $evt_origin = "$evt_y/$evt_m/$evt_d $evt_H:$evt_M:$evt_S"; - if (-e "$b3.json") { - my %json = %{decode_json(l2u(join("",readFile("$b3.json"))))}; - $evt_latitude = $json{'latitude'}; - $evt_longitude = $json{'longitude'}; - $evt_depth = $json{'depth'}; - $evt_magnitude = $json{'magnitude'}; - $evt_region = l2u($json{'region'}); - $evt_department = l2u($json{'department'}); - $evt_agency = l2u($json{'agency'}); - - } elsif (-e "$b3.gse") { - my @gse = readFile("$b3.gse"); - $evt_latitude = trim(substr($gse[9],25,9)); - $evt_longitude = trim(substr($gse[9],34,9)); - $evt_depth = trim(substr($gse[9],47,7)); - $evt_magnitude = trim(substr($gse[9],74,4)); - $evt_region = l2u(trim($gse[12]))); - $evt_agency = trim(substr($gse[9],105,8)); - } else { - $triggerOK = 0; - $trigger_check = 'disabled'; - } - $evt_department = $P{TRIGGER_DEPARTMENT} if ($evt_department eq ""); - $evt_agency = $P{TRIGGER_AGENCY} if ($evt_agency eq ""); - my $trigger_content = "Time: $evt_origin\n" - ."Latitude: $evt_latitude\n" - ."Longitude: $evt_longitude\n" - ."Depth: $evt_depth\n" - ."Magnitude: $evt_magnitude\n" - ."Department: $evt_department\n" - ."Region: $evt_region\n" - ."Agency: $trigger_agency\n"; + my ($y,$m,$d,$id,$evt) = split(/\//,$g); + my ($evt_y,$evt_m,$evt_d,$evt_H,$evt_M,$evt_S,$evt_loc) = unpack("a4a2a2xa2a2a2xa*",$evt); + my $b3_urn = "$WEBOBS{'URN_OUTG'}/$grid/$ts/$g"; + my $evt_email = $P{TRIGGER_EMAIL}; + my $evt_subject = $P{TRIGGER_SUBJECT}; + my $report_email = $P{REPORT_EMAIL}; + my ($evt_latitude,$evt_longitude,$evt_magnitude,$evt_depth,$evt_region,$evt_department,$evt_agency); + my $report_file = "$evt.pdf"; + my $report_subject = "$P{REPORT_SUBJECT}"; + my $report_message; + + # reads needed information from the event + my $triggerOK = 1; + my $trigger_check = 'checked'; + my $evt_origin = "$evt_y/$evt_m/$evt_d $evt_H:$evt_M:$evt_S"; + if (-e "$b3.json") { + my %json = %{decode_json(l2u(join("",readFile("$b3.json"))))}; + $evt_latitude = $json{'latitude'}; + $evt_longitude = $json{'longitude'}; + $evt_depth = $json{'depth'}; + $evt_magnitude = $json{'magnitude'}; + $evt_region = l2u($json{'region'}); + $evt_department = l2u($json{'department'}); + $evt_agency = l2u($json{'agency'}); + + } elsif (-e "$b3.gse") { + my @gse = readFile("$b3.gse"); + $evt_latitude = trim(substr($gse[9],25,9)); + $evt_longitude = trim(substr($gse[9],34,9)); + $evt_depth = trim(substr($gse[9],47,7)); + $evt_magnitude = trim(substr($gse[9],74,4)); + $evt_region = l2u(trim($gse[12])); + $evt_agency = trim(substr($gse[9],105,8)); + } else { + $triggerOK = 0; + $trigger_check = 'disabled'; + } + $evt_department = $P{TRIGGER_DEPARTMENT} if ($evt_department eq ""); + $evt_agency = $P{TRIGGER_AGENCY} if ($evt_agency eq ""); + my $trigger_content = "Time: $evt_origin\n" + ."Latitude: $evt_latitude\n" + ."Longitude: $evt_longitude\n" + ."Depth: $evt_depth\n" + ."Magnitude: $evt_magnitude\n" + ."Department: $evt_department\n" + ."Region: $evt_region\n" + ."Agency: $trigger_agency\n"; if (-e "$b3.msg") { my @msg = readFile("$b3.msg"); @@ -387,25 +387,25 @@ sub print_secondary { print "

        $__{'Sending emails'}

        \n"; my $replyto = "export REPLYTO=$operator_email"; - # send trigger email - if ($q->param('send_trigger')) { - my $mail_address = $q->param('trigger_email'); - my $mail_subject = $q->param('trigger_subject'); - my $mail_content = "Time: ".$q->param('event_time')."\n" - ."Latitude: ".$q->param('event_latitude')."\n" - ."Longitude: ".$q->param('event_longitude')."\n" - ."Depth: ".$q->param('event_depth')."\n" - ."Magnitude: ".$q->param('event_magnitude')."\n" - ."Department: ".u2l($q->param('event_department'))."\n" - ."Region: ".u2l($q->param('event_region'))."\n" - ."Agency: ".u2l($q->param('agency'))."\n"; - my $cmd = "$replyto;echo \"$mail_content\" | mutt -s \"$mail_subject\" $mutt_options $mail_address $operator_email"; - if ( ! system($cmd) ) { - print_success($__{'Trigger email has been successfully sent!'}); - } else { - print_error($__{'Sorry, an error occured during report email sending. Please contact an administator.'}); + # send trigger email + if ($q->param('send_trigger')) { + my $mail_address = $q->param('trigger_email'); + my $mail_subject = $q->param('trigger_subject'); + my $mail_content = "Time: ".$q->param('event_time')."\n" + ."Latitude: ".$q->param('event_latitude')."\n" + ."Longitude: ".$q->param('event_longitude')."\n" + ."Depth: ".$q->param('event_depth')."\n" + ."Magnitude: ".$q->param('event_magnitude')."\n" + ."Department: ".u2l($q->param('event_department'))."\n" + ."Region: ".u2l($q->param('event_region'))."\n" + ."Agency: ".u2l($q->param('agency'))."\n"; + my $cmd = "$replyto;echo \"$mail_content\" | mutt -s \"$mail_subject\" $mutt_options $mail_address $operator_email"; + if ( ! system($cmd) ) { + print_success($__{'Trigger email has been successfully sent!'}); + } else { + print_error($__{'Sorry, an error occured during report email sending. Please contact an administator.'}); + } } - } # send report email if ($q->param('send_report')) { diff --git a/CODE/cgi-bin/mailInfo_OVPF.pl b/CODE/cgi-bin/mailInfo_OVPF.pl index 004e3192..995e0a4f 100755 --- a/CODE/cgi-bin/mailInfo_OVPF.pl +++ b/CODE/cgi-bin/mailInfo_OVPF.pl @@ -58,6 +58,7 @@ use Locale::TextDomain('webobs'); set_message(\&webobs_cgi_msg); + #my $old_locale = setlocale(LC_NUMERIC); #setlocale(LC_NUMERIC,'C'); @@ -106,7 +107,7 @@ my $debug; if ($valParams =~ /debug/) { - $debug = $cgi->url_param('debug'); + $debug = $cgi->url_param('debug'); } my $dateStart = $cgi->url_param('dateStart'); @@ -130,7 +131,7 @@ my @comments_geodesy = $cgi->url_param('comment_geodesy'); my $comments_geochemistry = $cgi->url_param('comment_geochemistry'); if ($comments_geochemistry eq "") { - $comments_geochemistry = "Géochimie non renseignée."; + $comments_geochemistry = "Géochimie non renseignée."; } my @mail = $cgi->url_param('mail'); @@ -149,8 +150,8 @@ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (($dateStart ne $dateEnd || $yesterday ne $dateEnd) && !defined($send)) { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -166,235 +167,238 @@ PART1 } elsif (defined($send)) { - my $html; - #my $outputFilename = '/tmp/bulletin.html'; - my $outputFilename = '/home/sysop/bulletin/bulletin.html'; - my $htmlOutput = ""; - my $htmlBrowser = ""; - my $htmlMail = ""; - my %alerts; - for (@typeAlerts) { - my @liste = split(/\|/,$_); - $alerts{$liste[0]} = $liste[1]; - } - my %geodesy; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - $geodesy{$liste[0]} = $liste[2]; + my $html; + + #my $outputFilename = '/tmp/bulletin.html'; + my $outputFilename = '/home/sysop/bulletin/bulletin.html'; + my $htmlOutput = ""; + my $htmlBrowser = ""; + my $htmlMail = ""; + my %alerts; + for (@typeAlerts) { + my @liste = split(/\|/,$_); + $alerts{$liste[0]} = $liste[1]; + } + my %geodesy; + for (@commentsGeodesy) { + my @liste = split(/\|/,$_); + $geodesy{$liste[0]} = $liste[2]; + } + + print $cgi->header(-charset=>'utf-8'); + + $html = ''; + $html .= ''; + $html .= ' '; + $html .= ' '; + $html .= ' Bulletin d\'information'; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= " "; + $htmlBrowser .= " "; + + #$htmlBrowser .= " "; + $htmlBrowser .= " "; + $html = ' '; + $html .= ' '; + $html .= '
        '; + $html .= '

        Observatoire Volcanologique du Piton de La Fournaise

        '; + $html .= '
        '; + $html .= ' '; + $html .= '
        '; + $html .= '
        '; + $html .= "

        $timePeriodHTML

        "; + my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); + $html .= "

        Bulletin créé le $dateBulletin TU.

        "; + $html .= "

        Ce bulletin est issu de l'examen préliminaire quotidien des dernières données. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
        Pour une information complète, veuillez vous reporter aux derniers bulletins mensuels validés de l'observatoire.

        "; + $html .= '
        '; + $html .= '

        '; + $html .= ' Piton de la Fournaise
        '; + $html .= ' 21°14\'38" S
        '; + $html .= ' 55°42\'29" E
        '; + $html .= ' Altitude : 2632m
        '; + $html .= '

        '; + $html .= '
        '; + $html .= '

        '; + $html .= " Niveau d'alerte : $alerts{$alert}"; + $html .= '

        '; + $html .= '
        '; + my %zones; + for (@typeZones) { + my @liste = split(/\|/,$_); + $zones{$liste[0]} = $liste[1]; + } + $html .= '

        Sismologie

        '; + + my $subject = "[ovpf_bulletin] $timePeriod"; + $html .= "

        - Nombre d'éboulements du $dateEndFrench : $comptabilisesRockfall
        "; + if($#zones_rockfall >= 0) { + if($#zones_rockfall == 0) { + $html .= "Zone concernée par les éboulements :
        "; + } else { + $html .= "Zones concernées par les éboulements :
        "; } - - print $cgi->header(-charset=>'utf-8'); - - $html = ''; - $html .= ''; - $html .= ' '; - $html .= ' '; - $html .= ' Bulletin d\'information'; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlBrowser .= " "; - #$htmlBrowser .= " "; - $htmlBrowser .= " "; - $html = ' '; - $html .= ' '; - $html .= '

        '; - $html .= '

        Observatoire Volcanologique du Piton de La Fournaise

        '; - $html .= '
        '; - $html .= ' '; - $html .= '
        '; - $html .= '
        '; - $html .= "

        $timePeriodHTML

        "; - my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); - $html .= "

        Bulletin créé le $dateBulletin TU.

        "; - $html .= "

        Ce bulletin est issu de l'examen préliminaire quotidien des dernières données. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
        Pour une information complète, veuillez vous reporter aux derniers bulletins mensuels validés de l'observatoire.

        "; - $html .= '
        '; - $html .= '

        '; - $html .= ' Piton de la Fournaise
        '; - $html .= ' 21°14\'38" S
        '; - $html .= ' 55°42\'29" E
        '; - $html .= ' Altitude : 2632m
        '; - $html .= '

        '; - $html .= '
        '; - $html .= '

        '; - $html .= " Niveau d'alerte : $alerts{$alert}"; - $html .= '

        '; - $html .= '
        '; - my %zones; - for (@typeZones) { - my @liste = split(/\|/,$_); - $zones{$liste[0]} = $liste[1]; + $html .= "
          "; + for (@zones_rockfall) { + $html .= "
        • $zones{$_}
          • "; + } + $html .= "
        "; + $html .= "

        "; + } + $html .= "

        - Nombre de séismes volcano-tectoniques (VT) du $dateEndFrench : $comptabilisesVT
        "; + if($#zones_vt >= 0) { + if($#zones_vt == 0) { + $html .= "Zone concernée par les VT :
        "; + } else { + $html .= "Zones concernées par les VT :
        "; } - $html .= '

        Sismologie

        '; - - my $subject = "[ovpf_bulletin] $timePeriod"; - $html .= "

        - Nombre d'éboulements du $dateEndFrench : $comptabilisesRockfall
        "; - if($#zones_rockfall >= 0) { - if($#zones_rockfall == 0) { - $html .= "Zone concernée par les éboulements :
        "; - } else { - $html .= "Zones concernées par les éboulements :
        "; - } - $html .= "

          "; - for (@zones_rockfall) { - $html .= "
        • $zones{$_}
          • "; - } - $html .= "
        "; - $html .= "

        "; - } - $html .= "

        - Nombre de séismes volcano-tectoniques (VT) du $dateEndFrench : $comptabilisesVT
        "; - if($#zones_vt >= 0) { - if($#zones_vt == 0) { - $html .= "Zone concernée par les VT :
        "; - } else { - $html .= "Zones concernées par les VT :
        "; - } - $html .= "

          "; - for (@zones_vt) { - $html .= "
        • $zones{$_}
          • "; - } - $html .= "
        "; - $html .= "

        "; - } - $html .= "

        - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
        "; - $html .= "

          "; - $html .= "
        • Durée : $stat_max_duration s
          • "; - $html .= "
        • Magnitude de durée : $stat_max_magnitude
          • "; - $html .= "
        "; - $html .= "

        - Nombre de séismes locaux (en dehors du massif du Piton de la Fournaise) du $dateEndFrench : $comptabilisesLOC

        "; - $html .= "

        - Séisme local de plus grande magnitude du $dateEndFrench :
        "; - $html .= "

          "; - $html .= "
        • Durée : $stat_max_duration_loc s
          • "; - $html .= "
        • Magnitude de durée : $stat_max_magnitude_loc
          • "; - $html .= "
        "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ""; - $htmlBrowser .= ""; - $html = "

        "; - $htmlMail .= $html; - $html .= "

        "; - $html .= "Carte de localisation (épicentres) et coupes nord-ouest - sud-est et sud-ouest - nord-est (montrant la localisation en profondeur, hypocentres) des séismes enregistrés et localisés par l'OVPF-IPGP sur 2 mois sous La Réunion. Seuls les séismes localisables ont été représentés sur la carte.
        "; - $html .= "L'observatoire enregistre des évènements sismiques non représentés sur cette carte car non localisables, en raison de leur trop faible magnitude.
        Pour prendre connaissance du nombre de séismes détectés par les réseaux de l'observatoire, vous pouvez vous reporter à son dernier bulletin mensuel.
        "; - $html .= "La sismicité déterminée et validée en continu par l'OVPF-IPGP peut être également suivie sur le portail RENASS."; - $html .= "

        "; - $html .= '
        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

        Déformations

        "; - for (@comments_geodesy) { - $html .= " - $geodesy{$_}

        "; + $html .= "

          "; + for (@zones_vt) { + $html .= "
        • $zones{$_}
          • "; } - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlOutput .= "
          "; - $htmlBrowser .= "
          "; - $html = "

          "; - $htmlMail .= $html; - $html .= "

          "; - $html .= "Illustration de la déformation sur 1 an. Sont ici représentées des lignes de base (variation de distance entre deux récepteurs GPS) traversant l'édifice du Piton de la Fournaise, au sommet (en haut), à la base du cône terminal (au milieu) et en champ lointain (en bas) (cf. localisation sur les cartes associées). Une hausse est synonyme d'élongation et donc de gonflement du volcan ; inversement une diminution est synonyme de contraction et donc de dégonflement du volcan. Les éventuelles périodes coloriées en rose clair correspondent aux éruptions."; + $html .= "

        "; $html .= "

        "; - $html .= '
        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

        Géochimie

        "; - $comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); - $comments_geochemistry =~ s;\n;
        ;g; - $html .= "

        $comments_geochemistry

        "; - if ($comment ne "") { - $html .= "

        Informations complémentaires

        "; - $comment = encode_entities(decode('utf8', $comment)); - $comment =~ s;\n;
        ;g; - $html .= "

        $comment

        "; - } - $html .= '
        '; - $html .= "

        Glossaire

        "; - $html .= "

        + } + $html .= "

        - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
        "; + $html .= "

          "; + $html .= "
        • Durée : $stat_max_duration s
          • "; + $html .= "
        • Magnitude de durée : $stat_max_magnitude
          • "; + $html .= "
        "; + $html .= "

        - Nombre de séismes locaux (en dehors du massif du Piton de la Fournaise) du $dateEndFrench : $comptabilisesLOC

        "; + $html .= "

        - Séisme local de plus grande magnitude du $dateEndFrench :
        "; + $html .= "

          "; + $html .= "
        • Durée : $stat_max_duration_loc s
          • "; + $html .= "
        • Magnitude de durée : $stat_max_magnitude_loc
          • "; + $html .= "
        "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ""; + $htmlBrowser .= ""; + $html = "

        "; + $htmlMail .= $html; + $html .= "

        "; + $html .= "Carte de localisation (épicentres) et coupes nord-ouest - sud-est et sud-ouest - nord-est (montrant la localisation en profondeur, hypocentres) des séismes enregistrés et localisés par l'OVPF-IPGP sur 2 mois sous La Réunion. Seuls les séismes localisables ont été représentés sur la carte.
        "; + $html .= "L'observatoire enregistre des évènements sismiques non représentés sur cette carte car non localisables, en raison de leur trop faible magnitude.
        Pour prendre connaissance du nombre de séismes détectés par les réseaux de l'observatoire, vous pouvez vous reporter à son dernier bulletin mensuel.
        "; + $html .= "La sismicité déterminée et validée en continu par l'OVPF-IPGP peut être également suivie sur le portail RENASS."; + $html .= "

        "; + $html .= '
        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

        Déformations

        "; + for (@comments_geodesy) { + $html .= " - $geodesy{$_}

        "; + } + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= " "; + $htmlOutput .= "
        "; + $htmlBrowser .= "
        "; + $html = "

        "; + $htmlMail .= $html; + $html .= "

        "; + $html .= "Illustration de la déformation sur 1 an. Sont ici représentées des lignes de base (variation de distance entre deux récepteurs GPS) traversant l'édifice du Piton de la Fournaise, au sommet (en haut), à la base du cône terminal (au milieu) et en champ lointain (en bas) (cf. localisation sur les cartes associées). Une hausse est synonyme d'élongation et donc de gonflement du volcan ; inversement une diminution est synonyme de contraction et donc de dégonflement du volcan. Les éventuelles périodes coloriées en rose clair correspondent aux éruptions."; + $html .= "

        "; + $html .= '
        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

        Géochimie

        "; + $comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); + $comments_geochemistry =~ s;\n;
        ;g; + $html .= "

        $comments_geochemistry

        "; + if ($comment ne "") { + $html .= "

        Informations complémentaires

        "; + $comment = encode_entities(decode('utf8', $comment)); + $comment =~ s;\n;
        ;g; + $html .= "

        $comment

        "; + } + $html .= '
        '; + $html .= "

        Glossaire

        "; + $html .= "

        - Séisme volcano-tectonique sommital : séisme localisé au dessus du niveau de la mer à l'aplomb du sommet du volcan.
        - Séisme volcano-tectonique profond : séisme localisé sous le niveau de la mer à l'aplomb du volcan.
        - Séisme local : séisme localisé dans un rayon de 200km de l'île.
        - Signaux GPS sommitaux: témoin de l'influence de sources de pression superficielles à l'aplomb du volcan.
        - Signaux GPS lointains: témoin de l'influence de sources de pression profondes à l'aplomb du volcan.

        "; - $html .= "
        "; - $html .= "
        "; - $html .= " "; - $html .= ""; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - - print "$htmlBrowser"; - - print "Debut ECRITURE BULLETIN"; - #open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; - open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; - print $fh $htmlOutput; - close $fh; - print "Fin ECRITURE BULLETIN"; - -# print "Envoie du mail"; - - my $from = $MC3{MAIL_FROM}; - my $smtpServer = $MC3{MAIL_SMTP_SERVER}; - my $smtpPort = $MC3{MAIL_SMTP_PORT}; - my $user = $MC3{MAIL_USER}; - my $passwd = $MC3{MAIL_PASSWD}; - - my $mailList = ''; - my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); - for (@mailConf) { - my @liste = split(/\|/,$_); - my %hash; - @hash{@mail}=(); - if (exists $hash{$liste[0]}){ - if ($mailList eq '') { - $mailList = $mailList.$liste[4] - } else { - $mailList = $mailList.','.$liste[4] - } - } - } - - my $message = Email::MIME->create_html( - header => [ - From => $from, - 'Reply-To' => $from, - Subject => $subject, - Type => 'text/html; charset=UTF-8', - ], - body => $htmlMail, - ); - - my @mailingList = split(/,/,$mailList); - for(@mailingList) { - if($MC3{MAIL_USE_SMTP}) { - my $transport = Email::Sender::Transport::SMTP::TLS->new( - host => $smtpServer, - port => $smtpPort, - username => $user, - password => $passwd, - ); - sendmail($message, { from => $from, to => $_, transport => $transport}); - } else { - sendmail($message, { from => $from, to => $_}); - } - } + $html .= "
        "; + $html .= "
        "; + $html .= " "; + $html .= ""; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + print "$htmlBrowser"; + + print "Debut ECRITURE BULLETIN"; + +#open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; + open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; + print $fh $htmlOutput; + close $fh; + print "Fin ECRITURE BULLETIN"; + + # print "Envoie du mail"; + + my $from = $MC3{MAIL_FROM}; + my $smtpServer = $MC3{MAIL_SMTP_SERVER}; + my $smtpPort = $MC3{MAIL_SMTP_PORT}; + my $user = $MC3{MAIL_USER}; + my $passwd = $MC3{MAIL_PASSWD}; + + my $mailList = ''; + my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); + for (@mailConf) { + my @liste = split(/\|/,$_); + my %hash; + @hash{@mail}=(); + if (exists $hash{$liste[0]}){ + if ($mailList eq '') { + $mailList = $mailList.$liste[4] + } else { + $mailList = $mailList.','.$liste[4] + } + } + } + + my $message = Email::MIME->create_html( + header => [ + From => $from, + 'Reply-To' => $from, + Subject => $subject, + Type => 'text/html; charset=UTF-8', + ], + body => $htmlMail, + ); + + my @mailingList = split(/,/,$mailList); + for(@mailingList) { + if($MC3{MAIL_USE_SMTP}) { + my $transport = Email::Sender::Transport::SMTP::TLS->new( + host => $smtpServer, + port => $smtpPort, + username => $user, + password => $passwd, + ); + sendmail($message, { from => $from, to => $_, transport => $transport}); + } else { + sendmail($message, { from => $from, to => $_}); + } + } } else { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -425,12 +429,12 @@

        Nombre d'éboulements : $comptabilisesRockfall

        @@ -438,24 +442,24 @@

        PART2 - for (@typeZones) { - my @liste = split(/\|/,$_); - print "$liste[1]\n"; - } + for (@typeZones) { + my @liste = split(/\|/,$_); + print "$liste[1]\n"; + } - print <<"PART3"; + print <<"PART3";

        Nombre de séismes volcano-tectoniques (VT) : $comptabilisesVT

        Zone(s) concernée(s) par les VT :

        PART3 - for (@typeZones) { - my @liste = split(/\|/,$_); - print "$liste[1]\n"; - } + for (@typeZones) { + my @liste = split(/\|/,$_); + print "$liste[1]\n"; + } - print <<"PART4"; + print <<"PART4";

        VT principal:

        @@ -475,52 +479,52 @@

        PART4 - print <<"PART51"; + print <<"PART51";

        Commentaire geodesie:

        PART51 - my $category = -1; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - if ($category != $liste[3]) { - if ($category != -1) { - print ""; - } - print ""; + } + print "

        PART52 - print <<"PART61"; + print <<"PART61";

        Commentaire geochimie:

        PART61 - print <<"PART7"; + print <<"PART7";

        Informations complémentaires :

        Destinataires :

        PART7 - my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); - for (@mails) { - my @liste = split(/\|/,$_); - if ($liste[3] == 1) { - if ($liste[2] == 1) { - print "$liste[1]
        \n"; - } else { - print "$liste[1]
        \n"; - } - } - } - - print <<"PART5"; + my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_INFO_CONF}"); + for (@mails) { + my @liste = split(/\|/,$_); + if ($liste[3] == 1) { + if ($liste[2] == 1) { + print "$liste[1]
        \n"; + } else { + print "$liste[1]
        \n"; + } + } + } + + print <<"PART5"; diff --git a/CODE/cgi-bin/mailInfo_REVOSIMA.pl b/CODE/cgi-bin/mailInfo_REVOSIMA.pl index 696d0ad0..554cec01 100755 --- a/CODE/cgi-bin/mailInfo_REVOSIMA.pl +++ b/CODE/cgi-bin/mailInfo_REVOSIMA.pl @@ -48,6 +48,7 @@ use Switch; set_message(\&webobs_cgi_msg); + #my $old_locale = setlocale(LC_NUMERIC); #setlocale(LC_NUMERIC,'C'); @@ -96,7 +97,7 @@ my $debug; if ($valParams =~ /debug/) { - $debug = $cgi->url_param('debug'); + $debug = $cgi->url_param('debug'); } my $dateStart = $cgi->url_param('dateStart'); @@ -171,7 +172,7 @@ my @comments_geodesy = $cgi->url_param('comment_geodesy'); my $comments_geochemistry = $cgi->url_param('comment_geochemistry'); if ($comments_geochemistry eq "") { - $comments_geochemistry = "Géochimie non renseignée."; + $comments_geochemistry = "Géochimie non renseignée."; } my @mail = $cgi->url_param('mail'); @@ -190,8 +191,8 @@ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (($dateStart ne $dateEnd || $yesterday ne $dateEnd) && !defined($send)) { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -207,36 +208,36 @@ PART1 } elsif (defined($send)) { - my $html; - my $outputFilename = '/opt/php/bulletin/bulletin.html'; - my $htmlOutput = ""; - my $htmlBrowser = ""; - my $htmlMail = ""; - my %alerts; - for (@typeAlerts) { - my @liste = split(/\|/,$_); - $alerts{$liste[0]} = $liste[1]; - } - my %geodesy; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - $geodesy{$liste[0]} = $liste[2]; - } + my $html; + my $outputFilename = '/opt/php/bulletin/bulletin.html'; + my $htmlOutput = ""; + my $htmlBrowser = ""; + my $htmlMail = ""; + my %alerts; + for (@typeAlerts) { + my @liste = split(/\|/,$_); + $alerts{$liste[0]} = $liste[1]; + } + my %geodesy; + for (@commentsGeodesy) { + my @liste = split(/\|/,$_); + $geodesy{$liste[0]} = $liste[2]; + } - print $cgi->header(-charset=>'utf-8'); - - $html = ''; - $html .= ''; - $html .= ' '; - $html .= ' '; - $html .= ' Bulletin d\'information'; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlBrowser .= " "; - $htmlBrowser .= " "; - $html = ' '; - $html .= ' '; - $html .= ' '; - $html .= '

        '; - $html .= '

        Réseau de surveillance Volcanologique et Sismologique de Mayotte

        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $html = '
        '; - $html .= ' '; - $html .= '
        '; - $html .= "

        $timePeriodHTML

        "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); - $html = "

        Bulletin créé le $dateBulletin TU.

        "; - $html .= "

        Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
        Pour une information complète, veuillez vous reporter aux actualités du réseau validées.

        "; - $html .= '
        '; - $html .= '

        Activité

        '; - $html .= '

        '; - $html .= ' Evènement en cours : activité sismique en cours entre 5 et 50 km l\'Est de Mayotte et émissions de fluides sur la zone du Fer à Cheval. Dernière activité sous-marine obsersée au niveau du volcan Fani Maoré le 18/01/2021 lors de la campagne MAYOBS17.'; - $html .= '

        '; - $html .= '

        '; - $html .= " Arrêt probable de l\'éruption. Aucune hypothèse n\'est pour l\'instant écartée quant à l\'évolution de la situation à venir (arrêt définitif, reprise de l'activité éruptive sur le même site, reprise de l'activité éruptive sur un autre site), compte tenu de l\'activité sismique persistante et d\'émissions de fluides localisées dans la zone du Fer à Cheval."; - $html .= '

        '; - $html .= '

        '; - $html .= " Edifice principal
        "; - $html .= ' Latitude : -12°54\' ; longitude : 45°43\'
        '; - $html .= ' Hauteur : au moins 800 m
        '; - $html .= ' Profondeur à la base du site éruptif : -3500 m
        '; - $html .= '

        '; - $html .= '
        '; - $html .= '

        '; - $html .= " Niveau d'alerte : $alerts{$alert}"; - $html .= '

        '; - $html .= '
        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - #$htmlOutput .= ' '; - #$htmlBrowser .= ' '; - $html = '

        Sismologie

        '; - - my $subject = "[revosima_bulletin] $timePeriod"; - $html .= "

        - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

        "; - $html .= "

        - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

        "; - $html .= "

        - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

        "; - $html .= "

        - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
        "; - $html .= "

          "; - $html .= "
        • Durée : $stat_max_duration s
          • "; - $html .= "
        • Magnitude (MLv) : $stat_max_magnitude
          • "; - $html .= "

        "; - $html .= "

        - Dernier séisme ressenti :
        "; - $html .= "

          "; - $html .= "
        • Date : $date_felt
          • "; - $html .= "
        • Magnitude (MLv) : $magnitude_felt
          • "; - $html .= "
        • Profondeur : $depth_felt km
          • "; - $html .= "
        • Localisation : $loc_felt
          • "; - $html .= "

        "; - $html .= "

        Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

        "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ""; - $htmlBrowser .= ""; - $html = "

        "; - $htmlMail .= $html; - $html .= "

        "; - $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, ITES) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA
        "; - $html .= "La sismicité déterminée et validée en continu par le REVOSIMA peut être également suivie sur le portail RENASS."; - $html .= "

        "; - $html .= '
        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

        Déformations

        "; - for (@comments_geodesy) { - $html .= " - $geodesy{$_}

        "; - } - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= "
        "; - $htmlBrowser .= "
        "; - $html = "

        "; - $htmlMail .= $html; - $html .= "

        "; - $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; - $html .= "

        "; - $html .= '
        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = ""; - $html .= "

        Géochimie

        "; - $comments_geochemistry = encode_entities(decode('utf-8', $comments_geochemistry)); - $comments_geochemistry =~ s;\n;
        ;g; - $html .= "

        $comments_geochemistry

        "; - if ($comment ne "") { - $html .= "

        Informations complémentaires

        "; - $comment = encode_entities(decode('utf-8', $comment)); - $comment =~ s;\n;
        ;g; - $html .= "

        $comment

        "; - } - $html .= '
        '; - $html .= "

        Contexte


        "; - $html .= "

        + $html .= ' '; + $html .= ' '; + $html .= '

        '; + $html .= '

        Réseau de surveillance Volcanologique et Sismologique de Mayotte

        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $html = '
        '; + $html .= ' '; + $html .= '
        '; + $html .= "

        $timePeriodHTML

        "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); + $html = "

        Bulletin créé le $dateBulletin TU.

        "; + $html .= "

        Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
        Pour une information complète, veuillez vous reporter aux actualités du réseau validées.

        "; + $html .= '
        '; + $html .= '

        Activité

        '; + $html .= '

        '; + $html .= ' Evènement en cours : activité sismique en cours entre 5 et 50 km l\'Est de Mayotte et émissions de fluides sur la zone du Fer à Cheval. Dernière activité sous-marine obsersée au niveau du volcan Fani Maoré le 18/01/2021 lors de la campagne MAYOBS17.'; + $html .= '

        '; + $html .= '

        '; + $html .= " Arrêt probable de l\'éruption. Aucune hypothèse n\'est pour l\'instant écartée quant à l\'évolution de la situation à venir (arrêt définitif, reprise de l'activité éruptive sur le même site, reprise de l'activité éruptive sur un autre site), compte tenu de l\'activité sismique persistante et d\'émissions de fluides localisées dans la zone du Fer à Cheval."; + $html .= '

        '; + $html .= '

        '; + $html .= " Edifice principal
        "; + $html .= ' Latitude : -12°54\' ; longitude : 45°43\'
        '; + $html .= ' Hauteur : au moins 800 m
        '; + $html .= ' Profondeur à la base du site éruptif : -3500 m
        '; + $html .= '

        '; + $html .= '
        '; + $html .= '

        '; + $html .= " Niveau d'alerte : $alerts{$alert}"; + $html .= '

        '; + $html .= '
        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + #$htmlOutput .= ' '; + #$htmlBrowser .= ' '; + $html = '

        Sismologie

        '; + + my $subject = "[revosima_bulletin] $timePeriod"; + $html .= "

        - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

        "; + $html .= "

        - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

        "; + $html .= "

        - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

        "; + $html .= "

        - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
        "; + $html .= "

          "; + $html .= "
        • Durée : $stat_max_duration s
          • "; + $html .= "
        • Magnitude (MLv) : $stat_max_magnitude
          • "; + $html .= "

        "; + $html .= "

        - Dernier séisme ressenti :
        "; + $html .= "

          "; + $html .= "
        • Date : $date_felt
          • "; + $html .= "
        • Magnitude (MLv) : $magnitude_felt
          • "; + $html .= "
        • Profondeur : $depth_felt km
          • "; + $html .= "
        • Localisation : $loc_felt
          • "; + $html .= "

        "; + $html .= "

        Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

        "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ""; + $htmlBrowser .= ""; + $html = "

        "; + $htmlMail .= $html; + $html .= "

        "; + $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, ITES) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA
        "; + $html .= "La sismicité déterminée et validée en continu par le REVOSIMA peut être également suivie sur le portail RENASS."; + $html .= "

        "; + $html .= '
        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

        Déformations

        "; + for (@comments_geodesy) { + $html .= " - $geodesy{$_}

        "; + } + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= "
        "; + $htmlBrowser .= "
        "; + $html = "

        "; + $htmlMail .= $html; + $html .= "

        "; + $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; + $html .= "

        "; + $html .= '
        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = ""; + $html .= "

        Géochimie

        "; + $comments_geochemistry = encode_entities(decode('utf-8', $comments_geochemistry)); + $comments_geochemistry =~ s;\n;
        ;g; + $html .= "

        $comments_geochemistry

        "; + if ($comment ne "") { + $html .= "

        Informations complémentaires

        "; + $comment = encode_entities(decode('utf-8', $comment)); + $comment =~ s;\n;
        ;g; + $html .= "

        $comment

        "; + } + $html .= '
        '; + $html .= "

        Contexte


        "; + $html .= "

        • Activité éruptive: Du 2 au 18 mai 2019, une campagne océanographique (MD220-MAYOBS1) sur le Marion Dufresne a permis la découverte d'un nouveau site éruptif sous-marin à 50 km à l'est de Mayotte qui a formé un édifice d'environ 820 m de hauteur sur le plancher océanique situé à 3500m de profondeur d'eau. Les campagnes (MD221-MAYOBS2 - 10-17 juin 2019 ; MD222-MAYOBS3 - 13-14 juillet 2019 ; MD223-MAYOBS4 - 19-31 juillet 2019 ; mission SHOM-MAYOBS5 20-21 août 2019; MAYOBS13 - 4-11 mai 2020) ont mis en évidence de nouvelles coulées de lave, au sud, à l'ouest et au nord du nouveau site éruptif. Des panaches acoustiques (700 à 1000 m de haut) de nature hydrothermale et/ou magmatique, ont été détectés dans la colonne d'eau au-dessus des coulées actives, ainsi qu'au-dessus de la structure volcanique ancienne dite du \"Fer à cheval \" située à l'aplomb de la zone de l'essaim sismique principal (5-15 km à l'est de Petite-Terre). En l’état actuel des connaissances, l’éruption a produit un volume estimé d’environ 6,4 km3 de lave depuis le début de son édification avec des flux qui ont variés, d'environ 35 à 181 m3/s. Ces volumes et flux éruptifs, notamment au début de la crise, sont exceptionnels et sont, malgré les incertitudes, parmi les plus élevés observés sur un volcan effusif depuis l'éruption du Laki (Islande) en 1783.

        • @@ -382,71 +384,71 @@

        "; - $html .= "
        "; - $html .= "
        "; - $html .= " "; - $html .= ""; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - - print "$htmlBrowser"; - - #open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; - open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; - print $fh $htmlOutput; - close $fh; - -# print "Envoie du mail"; - - my $from = $MC3{MAIL_FROM_REVOSIMA}; - my $smtpServer = $MC3{MAIL_SMTP_SERVER}; - my $smtpPort = $MC3{MAIL_SMTP_PORT}; - my $user = $MC3{MAIL_USER_REVOSIMA}; - my $passwd = $MC3{MAIL_PASSWD_REVOSIMA}; - - my $mailList = ''; - my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); - for (@mailConf) { - my @liste = split(/\|/,$_); - my %hash; - @hash{@mail}=(); - if (exists $hash{$liste[0]}){ - if ($mailList eq '') { - $mailList = $mailList.$liste[4] - } else { - $mailList = $mailList.','.$liste[4] - } - } - } - - my $message = Email::MIME->create_html( - header => [ - From => $from, - 'Reply-To' => $from, - Subject => $subject, - Type => 'text/html; charset=UTF-8', - ], - body => $htmlMail, - ); - - my @mailingList = split(/,/,$mailList); - for(@mailingList) { - if($MC3{MAIL_USE_SMTP_REVOSIMA}) { - my $transport = Email::Sender::Transport::SMTP::TLS->new( - host => $smtpServer, - port => $smtpPort, - username => $user, - password => $passwd, - ); - sendmail($message, { from => $from, to => $_, transport => $transport}); - } else { - sendmail($message, { from => $from, to => $_}); - } - } + $html .= "
        "; + $html .= " "; + $html .= " "; + $html .= ""; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + print "$htmlBrowser"; + +#open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; + open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; + print $fh $htmlOutput; + close $fh; + + # print "Envoie du mail"; + + my $from = $MC3{MAIL_FROM_REVOSIMA}; + my $smtpServer = $MC3{MAIL_SMTP_SERVER}; + my $smtpPort = $MC3{MAIL_SMTP_PORT}; + my $user = $MC3{MAIL_USER_REVOSIMA}; + my $passwd = $MC3{MAIL_PASSWD_REVOSIMA}; + + my $mailList = ''; + my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); + for (@mailConf) { + my @liste = split(/\|/,$_); + my %hash; + @hash{@mail}=(); + if (exists $hash{$liste[0]}){ + if ($mailList eq '') { + $mailList = $mailList.$liste[4] + } else { + $mailList = $mailList.','.$liste[4] + } + } + } + + my $message = Email::MIME->create_html( + header => [ + From => $from, + 'Reply-To' => $from, + Subject => $subject, + Type => 'text/html; charset=UTF-8', + ], + body => $htmlMail, + ); + + my @mailingList = split(/,/,$mailList); + for(@mailingList) { + if($MC3{MAIL_USE_SMTP_REVOSIMA}) { + my $transport = Email::Sender::Transport::SMTP::TLS->new( + host => $smtpServer, + port => $smtpPort, + username => $user, + password => $passwd, + ); + sendmail($message, { from => $from, to => $_, transport => $transport}); + } else { + sendmail($message, { from => $from, to => $_}); + } + } } else { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -463,12 +465,12 @@

        @@ -495,28 +497,28 @@

        Deplacements sur Mayotte sur le dernier mois

        PART12 - my $category = -1; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - if ($category != $liste[3]) { - if ($category != -1) { - print ""; - } - print ""; + } + print "

        PART52 - print <<"PART61"; + print <<"PART61";

        Commentaire geochimie:

        PART61 - print <<"PART7"; + print <<"PART7";

        Informations complémentaires :

        Ajouter un éventuel séisme ressenti au cours des 24 dernières heures.
        @@ -525,19 +527,19 @@

        PART7 - my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); - for (@mails) { - my @liste = split(/\|/,$_); - if ($liste[3] == 1) { - if ($liste[2] == 1) { - print "$liste[1]
        \n"; - } else { - print "$liste[1]
        \n"; - } - } - } - - print <<"PART5"; + my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); + for (@mails) { + my @liste = split(/\|/,$_); + if ($liste[3] == 1) { + if ($liste[2] == 1) { + print "$liste[1]
        \n"; + } else { + print "$liste[1]
        \n"; + } + } + } + + print <<"PART5"; diff --git a/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl b/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl index 4446c270..cac75f92 100755 --- a/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl +++ b/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl @@ -47,6 +47,7 @@ use Switch; set_message(\&webobs_cgi_msg); + #my $old_locale = setlocale(LC_NUMERIC); #setlocale(LC_NUMERIC,'C'); @@ -95,7 +96,7 @@ my $debug; if ($valParams =~ /debug/) { - $debug = $cgi->url_param('debug'); + $debug = $cgi->url_param('debug'); } my $dateStart = $cgi->url_param('dateStart'); @@ -169,7 +170,7 @@ my @comments_geodesy = $cgi->url_param('comment_geodesy'); my $comments_geochemistry = $cgi->url_param('comment_geochemistry'); if ($comments_geochemistry eq "") { - $comments_geochemistry = "Géochimie non renseignée."; + $comments_geochemistry = "Géochimie non renseignée."; } my @mail = $cgi->url_param('mail'); @@ -180,15 +181,15 @@ my @typeZones = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{ZONES_CODES_REVOSIMA_CONF}"); my @commentsGeodesy = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{COMMENTS_GEODESY_REVOSIMA_CONF}"); -my $dateEndFrench = substr($dateEnd,8,2)."-".substr($dateEnd,5,2)."-".substr($dateEnd,0,4); -my $dateStartFrench = substr($dateStart,8,2)."-".substr($dateStart,5,2)."-".substr($dateStart,0,4); +my $dateEndFrench = substr($dateEnd,8,2)."-".substr($dateEnd,5,2)."-".substr($dateEnd,0,4); +my $dateStartFrench = substr($dateStart,8,2)."-".substr($dateStart,5,2)."-".substr($dateStart,0,4); my $timePeriod = "Bilan du $dateEnd"; my $timePeriodHTML = "Bulletin préliminaire d'activité du $dateEndFrench"; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ($dateStart ne $dateEnd && !defined($send)) { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -202,37 +203,37 @@ PART1 - + } elsif (defined($send)) { - my $html; - my $outputFilename = '/opt/php/bulletin/bulletin.html'; - my $htmlOutput = ""; - my $htmlBrowser = ""; - my $htmlMail = ""; - my %alerts; - for (@typeAlerts) { - my @liste = split(/\|/,$_); - $alerts{$liste[0]} = $liste[1]; - } - my %geodesy; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - $geodesy{$liste[0]} = $liste[2]; - } + my $html; + my $outputFilename = '/opt/php/bulletin/bulletin.html'; + my $htmlOutput = ""; + my $htmlBrowser = ""; + my $htmlMail = ""; + my %alerts; + for (@typeAlerts) { + my @liste = split(/\|/,$_); + $alerts{$liste[0]} = $liste[1]; + } + my %geodesy; + for (@commentsGeodesy) { + my @liste = split(/\|/,$_); + $geodesy{$liste[0]} = $liste[2]; + } - print $cgi->header(-charset=>'utf-8'); - - $html = ''; - $html .= ''; - $html .= ' '; - $html .= ' '; - $html .= ' Bulletin d\'information'; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= " "; - $htmlBrowser .= " "; - $html = ' '; - $html .= ' '; - $html .= ' '; - $html .= '

        '; - $html .= '

        Réseau de surveillance Volcanologique et Sismologique de Mayotte

        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $html = '
        '; - $html .= ' '; - $html .= '
        '; - $html .= "

        $timePeriodHTML

        "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ' '; - $htmlBrowser .= ' '; - my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); - $html = "

        Bulletin créé le $dateBulletin TU.

        "; - $html .= "

        Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
        Pour une information complète, veuillez vous reporter aux Actualités du réseau validées.

        "; - $html .= '
        '; - $html .= '

        Activité

        '; - $html .= '

        '; - $html .= ' Evènement en cours : éruption sous-marine très probablement toujours en cours à 50-60 km à l\'Est de Mayotte avec sismicité et déformations associées. '; - $html .= '

        '; - $html .= '

        '; - $html .= " Dernière preuve sans équivoque d'activité éruptive : autour du 20 août 2019"; - $html .= '

        '; - $html .= '

        '; - $html .= " Site éruptif actuel (au 20-08-2019)
        "; - $html .= ' Edifice principal : latitude : -12°54\' ; longitude : 45°43\'
        '; - $html .= ' Hauteur : au moins 800 m
        '; - $html .= ' Profondeur à la base du site éruptif : -3500 m
        '; - $html .= '

        '; - $html .= '
        '; - $html .= '

        '; - $html .= " Niveau d'alerte : $alerts{$alert}"; - $html .= '

        '; - $html .= '
        '; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - #$htmlOutput .= ' '; - #$htmlBrowser .= ' '; - $html = '

        Sismologie

        '; - - my $subject = "$timePeriod"; - $html .= "

        - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

        "; - $html .= "

        - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

        "; - $html .= "

        - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

        "; - $html .= "

        - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
        "; - $html .= "

          "; - $html .= "
        • Durée : $stat_max_duration s
          • "; - $html .= "
        • Magnitude (MLv) : $stat_max_magnitude
          • "; - $html .= "

        "; - $html .= "

        - Dernier séisme ressenti :
        "; - $html .= "

          "; - $html .= "
        • Date : $date_felt
          • "; - $html .= "
        • Magnitude (MLv) : $magnitude_felt
          • "; - $html .= "
        • Profondeur : $depth_felt km
          • "; - $html .= "
        • Localisation : $loc_felt
          • "; - $html .= "

        "; - $html .= "

        Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

        "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= ""; - $htmlBrowser .= ""; - $html = "

        "; - $htmlMail .= $html; - $html .= "

        "; - $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, IPGS) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA"; - $html .= "

        "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = "

        Déformations

        "; - for (@comments_geodesy) { - $html .= " - $geodesy{$_}

        "; - } - $htmlOutput .= $html; - $htmlBrowser .= $html; - $htmlMail .= $html; - $htmlOutput .= "
        "; - $htmlBrowser .= "
        "; - $html = "

        "; - $htmlMail .= $html; - $html .= "

        "; - $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; - $html .= "

        "; - $htmlOutput .= $html; - $htmlBrowser .= $html; - - $html = ""; - #$html .= "

        Géochimie

        "; - #$comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); - #$comments_geochemistry =~ s;\n;
        ;g; - #$html .= "

        $comments_geochemistry

        "; - if ($comment ne "") { - $html .= "

        Informations complémentaires

        "; - $comment = encode_entities(decode('utf8', $comment)); - $comment =~ s;\n;
        ;g; - $html .= "

        $comment

        "; - } - $html .= '
        '; - $html .= "

        Contexte


        "; - $html .= "

        + '; + $html .= ' '; + $html .= ' '; + $html .= '

        '; + $html .= '

        Réseau de surveillance Volcanologique et Sismologique de Mayotte

        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $html = '
        '; + $html .= ' '; + $html .= '
        '; + $html .= "

        $timePeriodHTML

        "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ' '; + $htmlBrowser .= ' '; + my $dateBulletin = localtime->strftime('%d-%m-%Y %H:%M:%S'); + $html = "

        Bulletin créé le $dateBulletin TU.

        "; + $html .= "

        Ce bulletin est issu de l'examen préliminaire quotidien des dernières données par un.e analyste du REVOSIMA. Ces informations n'ont pas toutes été validées et sont susceptibles d'évoluer.
        Pour une information complète, veuillez vous reporter aux Actualités du réseau validées.

        "; + $html .= '
        '; + $html .= '

        Activité

        '; + $html .= '

        '; + $html .= ' Evènement en cours : éruption sous-marine très probablement toujours en cours à 50-60 km à l\'Est de Mayotte avec sismicité et déformations associées. '; + $html .= '

        '; + $html .= '

        '; + $html .= " Dernière preuve sans équivoque d'activité éruptive : autour du 20 août 2019"; + $html .= '

        '; + $html .= '

        '; + $html .= " Site éruptif actuel (au 20-08-2019)
        "; + $html .= ' Edifice principal : latitude : -12°54\' ; longitude : 45°43\'
        '; + $html .= ' Hauteur : au moins 800 m
        '; + $html .= ' Profondeur à la base du site éruptif : -3500 m
        '; + $html .= '

        '; + $html .= '
        '; + $html .= '

        '; + $html .= " Niveau d'alerte : $alerts{$alert}"; + $html .= '

        '; + $html .= '
        '; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + + #$htmlOutput .= ' '; + #$htmlBrowser .= ' '; + $html = '

        Sismologie

        '; + + my $subject = "$timePeriod"; + $html .= "

        - Nombre de signaux sismiques de type très longue période VLP (très basse fréquence, entre 0,01Hz et 0,2Hz) du $dateEndFrench : $comptabilisesVLP

        "; + $html .= "

        - Nombre de signaux sismiques de type longue période LP (basse fréquence, entre 0,5Hz et 5Hz) du $dateEndFrench : $comptabilisesLP

        "; + $html .= "

        - Nombre de séismes volcano-tectoniques VT (séismes dont la gamme de fréquence est la plus large, de 2Hz à 40Hz) du $dateEndFrench : $comptabilisesVT

        "; + $html .= "

        - Séisme volcano-tectonique de plus grande magnitude du $dateEndFrench :
        "; + $html .= "

          "; + $html .= "
        • Durée : $stat_max_duration s
          • "; + $html .= "
        • Magnitude (MLv) : $stat_max_magnitude
          • "; + $html .= "

        "; + $html .= "

        - Dernier séisme ressenti :
        "; + $html .= "

          "; + $html .= "
        • Date : $date_felt
          • "; + $html .= "
        • Magnitude (MLv) : $magnitude_felt
          • "; + $html .= "
        • Profondeur : $depth_felt km
          • "; + $html .= "
        • Localisation : $loc_felt
          • "; + $html .= "

        "; + $html .= "

        Il est fondamental de reporter tout séisme ressenti au BCSF-RENASS sur le site : http://www.franceseisme.fr

        "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= ""; + $htmlBrowser .= ""; + $html = "

        "; + $htmlMail .= $html; + $html .= "

        "; + $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, IPGS) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA"; + $html .= "

        "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = "

        Déformations

        "; + for (@comments_geodesy) { + $html .= " - $geodesy{$_}

        "; + } + $htmlOutput .= $html; + $htmlBrowser .= $html; + $htmlMail .= $html; + $htmlOutput .= "
        "; + $htmlBrowser .= "
        "; + $html = "

        "; + $htmlMail .= $html; + $html .= "

        "; + $html .= "Déplacements (en cm) enregistrés sur 9 stations GPS localisés à Mayotte (BDRL, GAMO, KAWE, KNKL, MAYG, MTSA, MTSB, PMZI, PORO), 1 station à Grande Glorieuse (GLOR) et 1 station au nord de Madagascar à Diego Suarez (DSUA) sur les composantes est (en haut), nord (au milieu) et vertical (en bas) depuis le 22 décembre 2013 pour visualiser une longue série temporelle anté-crise. Post-traitement de ces données réalisé par l'IPGP. ©OVPF-IPGP / REVOSIMA."; + $html .= "

        "; + $htmlOutput .= $html; + $htmlBrowser .= $html; + + $html = ""; + +#$html .= "

        Géochimie

        "; +#$comments_geochemistry = encode_entities(decode('utf8', $comments_geochemistry)); +#$comments_geochemistry =~ s;\n;
        ;g; +#$html .= "

        $comments_geochemistry

        "; + if ($comment ne "") { + $html .= "

        Informations complémentaires

        "; + $comment = encode_entities(decode('utf8', $comment)); + $comment =~ s;\n;
        ;g; + $html .= "

        $comment

        "; + } + $html .= '
        '; + $html .= "

        Contexte


        "; + $html .= "

        • Activité éruptive: Du 2 au 18 mai 2019, une campagne océanographique (MD220-MAYOBS-1) sur le Marion Dufresne a permis la découverte d'un nouveau site éruptif sous-marin à 50 km à l'est de Mayotte qui a formé un édifice d'environ 820 m de hauteur sur le plancher océanique situé à 3500m de profondeur d'eau. Les campagnes (MD221-MAYOBS-2 - 10-17 juin 2019 ; MD222-MAYOBS-3 - 13-14 juillet 2019 ; MD223-MAYOBS-4 - 19-31 juillet 2019 ; mission SHOM-MAYOBS-5 20-21 août 2019) ont mis en évidence de nouvelles coulées de lave, au sud, à l'ouest et au nord du nouveau site éruptif. Des panaches acoustiques (700 à 1000 m de haut) de nature hydrothermale et/ou magmatique, ont été détectés dans la colonne d'eau au-dessus des coulées actives, ainsi qu'au-dessus de la structure volcanique ancienne dite du \"Fer à cheval \" située à l'aplomb de la zone de l'essaim sismique principal (5-15 km à l'est de Petite-Terre). En l'état actuel des connaissances, le nouveau site éruptif a produit au moins 5,1 km3 de lave depuis le début de son édification avec des flux qui ont variés, d'environ 45 à 200 m3/s. Ces volumes et flux éruptifs, notamment au début de la crise, sont exceptionnels et sont, malgré les incertitudes, parmi les plus élevés observés sur un volcan effusif depuis l'éruption du Laki (Islande) en 1783.

        • @@ -377,23 +380,23 @@

        "; - $html .= "
        "; - $html .= "
        "; - $htmlBrowser .= $html; - $html .= " "; - $html .= ""; - $htmlOutput .= $html; - $htmlMail .= $html; + $html .= "
        "; + $html .= " "; + $htmlBrowser .= $html; + $html .= " "; + $html .= ""; + $htmlOutput .= $html; + $htmlMail .= $html; - print "$htmlBrowser"; - print 'Your visible link text'; + print "$htmlBrowser"; + print 'Your visible link text'; - #open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; - open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; - print $fh $htmlOutput; - close $fh; +#open(my $fh, '>', $outputFilename) or die "Could not open file '$outputFilename' $!"; + open(my $fh, '>', $outputFilename) or print "Could not open file '$outputFilename' $!"; + print $fh $htmlOutput; + close $fh; -# print "Envoie du mail"; + # print "Envoie du mail"; # my $from = $MC3{MAIL_FROM_REVOSIMA}; # my $smtpServer = $MC3{MAIL_SMTP_SERVER}; @@ -441,8 +444,8 @@ # } # } } else { - print $cgi->header(-charset=>'utf-8'); - print <<"PART1"; + print $cgi->header(-charset=>'utf-8'); + print <<"PART1"; @@ -459,12 +462,12 @@

        @@ -491,28 +494,28 @@

        Deplacements sur Mayotte sur le long terme

        PART12 - my $category = -1; - for (@commentsGeodesy) { - my @liste = split(/\|/,$_); - if ($category != $liste[3]) { - if ($category != -1) { - print ""; - } - print ""; + } + print "

        PART52 - print <<"PART61"; + print <<"PART61";

        Commentaire geochimie:

        PART61 - print <<"PART7"; + print <<"PART7";

        Informations complémentaires :

        Ajouter un éventuel séisme ressenti au cours des 24 dernières heures.
        @@ -521,19 +524,19 @@

        PART7 - my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); - for (@mails) { - my @liste = split(/\|/,$_); - if ($liste[3] == 1) { - if ($liste[2] == 1) { - print "$liste[1]
        \n"; - } else { - print "$liste[1]
        \n"; - } - } - } - - print <<"PART5"; + my @mails = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); + for (@mails) { + my @liste = split(/\|/,$_); + if ($liste[3] == 1) { + if ($liste[2] == 1) { + print "$liste[1]
        \n"; + } else { + print "$liste[1]
        \n"; + } + } + } + + print <<"PART5"; diff --git a/CODE/cgi-bin/mc3.pl b/CODE/cgi-bin/mc3.pl index 049edf38..e4ec9dab 100755 --- a/CODE/cgi-bin/mc3.pl +++ b/CODE/cgi-bin/mc3.pl @@ -157,6 +157,7 @@ =head1 HYPOCENTERS FILES use Locale::TextDomain('webobs'); set_message(\&webobs_cgi_msg); + #DL-TBD: no strict "subs"; #DL-TBD: my $old_locale = setlocale(LC_NUMERIC); #DL-TBD: setlocale(LC_NUMERIC,'C'); @@ -230,62 +231,61 @@ =head1 HYPOCENTERS FILES $|=1; - # ---- a few useful subroutines ----------------------------------------------- sub compute_energy { - # Energy calculation in joules, from: - # Hanks, T. C., & Kanamori, H. (1979). A moment magnitude scale. - # Journal of Geophysical Research: Solid Earth, 84(B5), 2348-2350 - my $mag = shift; - return 10**(1.5 * $mag + 11.8) / 10**7; -} + # Energy calculation in joules, from: + # Hanks, T. C., & Kanamori, H. (1979). A moment magnitude scale. + # Journal of Geophysical Research: Solid Earth, 84(B5), 2348-2350 + my $mag = shift; + return 10**(1.5 * $mag + 11.8) / 10**7; +} # ---- check/fix OR default the requested date range -------------------------- # - handle 28-31 days/month by re-evaluating with "YYYY-MM-01 (DD-1) day" # (ie. 2012-02-30 ==> 2012-03-02) # - check range-start < range-end , otherwise swap if ($QryParm->{'routine'} =~ /^(day|month|year)$/) { - if ($QryParm->{'routine'} eq "day") { - $start_datetime = DateTime->today()->subtract(days => 1); - $end_datetime = DateTime->today()->subtract(hours => 1); - } elsif ($QryParm->{'routine'} eq "month") { - $start_datetime = DateTime->today()->set_day(1)->subtract(months => 1); - $end_datetime = DateTime->today()->set_day(1)->subtract(hours => 1); - } elsif ($QryParm->{'routine'} eq "year") { - $start_datetime = DateTime->today()->subtract(years => 1)->set_month(1)->set_day(1); - $end_datetime = DateTime->today()->set_month(1)->set_day(1)->subtract(hours => 1); - } + if ($QryParm->{'routine'} eq "day") { + $start_datetime = DateTime->today()->subtract(days => 1); + $end_datetime = DateTime->today()->subtract(hours => 1); + } elsif ($QryParm->{'routine'} eq "month") { + $start_datetime = DateTime->today()->set_day(1)->subtract(months => 1); + $end_datetime = DateTime->today()->set_day(1)->subtract(hours => 1); + } elsif ($QryParm->{'routine'} eq "year") { + $start_datetime = DateTime->today()->subtract(years => 1)->set_month(1)->set_day(1); + $end_datetime = DateTime->today()->set_month(1)->set_day(1)->subtract(hours => 1); + } } elsif (($QryParm->{'y1'} ne "") && ($QryParm->{'m1'} ne "") && ($QryParm->{'d1'} ne "") - && ($QryParm->{'y2'} ne "") && ($QryParm->{'m2'} ne "") && ($QryParm->{'d2'} ne "")) { - - # We chose to handle short months by converting (e.g.) 30 February to 02 March, or 31 June to 01 July. - # For this, we add the number of days to the first day of the chosen month. - $start_datetime = DateTime->new(year => $QryParm->{y1}, - month => $QryParm->{m1}, - day => 1) - + DateTime::Duration->new(days => ($QryParm->{d1}-1)) - + DateTime::Duration->new(hours => ($QryParm->{h1})); - $end_datetime = DateTime->new(year => $QryParm->{y2}, - month => $QryParm->{m2}, - day => 1) - + DateTime::Duration->new(days => ($QryParm->{d2}-1)) - + DateTime::Duration->new(hours => ($QryParm->{h2})); + && ($QryParm->{'y2'} ne "") && ($QryParm->{'m2'} ne "") && ($QryParm->{'d2'} ne "")) { + +# We chose to handle short months by converting (e.g.) 30 February to 02 March, or 31 June to 01 July. +# For this, we add the number of days to the first day of the chosen month. + $start_datetime = DateTime->new(year => $QryParm->{y1}, + month => $QryParm->{m1}, + day => 1) + + DateTime::Duration->new(days => ($QryParm->{d1}-1)) + + DateTime::Duration->new(hours => ($QryParm->{h1})); + $end_datetime = DateTime->new(year => $QryParm->{y2}, + month => $QryParm->{m2}, + day => 1) + + DateTime::Duration->new(days => ($QryParm->{d2}-1)) + + DateTime::Duration->new(hours => ($QryParm->{h2})); } else { - $start_datetime = DateTime->now()->subtract(hours => (24*$MC3{DEFAULT_TABLE_DAYS}-1)); - $end_datetime = $now; + $start_datetime = DateTime->now()->subtract(hours => (24*$MC3{DEFAULT_TABLE_DAYS}-1)); + $end_datetime = $now; } # Change to local time if ($QryParm->{'slt'} != 0) { - $start_datetime = $start_datetime - DateTime::Duration->new(hours => ($slt)); - $end_datetime = $end_datetime - DateTime::Duration->new(hours => ($slt)); + $start_datetime = $start_datetime - DateTime::Duration->new(hours => ($slt)); + $end_datetime = $end_datetime - DateTime::Duration->new(hours => ($slt)); } # Swap start and end if necessary if ($start_datetime gt $end_datetime) { - ($start_datetime, $end_datetime) = ($end_datetime, $start_datetime); + ($start_datetime, $end_datetime) = ($end_datetime, $start_datetime); } $QryParm->{'y1'} = $start_datetime->year; @@ -310,9 +310,10 @@ sub compute_energy { my @Durations = readCfgFile("$MC3{DURATIONS_CONF}"); my %duration_s; for (@Durations) { - my ($key,$nam,$val) = split(/\|/,$_); - $duration_s{$key} = $val; + my ($key,$nam,$val) = split(/\|/,$_); + $duration_s{$key} = $val; } + # ---- Load Amplitudes -------------------------------------------------------- # my @amplitudes = readCfgFile("$MC3{AMPLITUDES_CONF}"); @@ -320,9 +321,9 @@ sub compute_energy { my %valAmp; my %opeAmp = ( 'le' => '≤', 'eq' => '=', 'ge' => '≥' ); for (@amplitudes) { - my ($key,$nam,$val) = split(/\|/,$_); - $namAmp{$key} = $nam; - $valAmp{$key} = $val; + my ($key,$nam,$val) = split(/\|/,$_); + $namAmp{$key} = $nam; + $valAmp{$key} = $val; } # ---- Load No location SC3 types ---------------------------------------------- @@ -332,197 +333,207 @@ sub compute_energy { # if ($QryParm->{'dump'} eq "") { - $html .= "

        $MC3{TITLE}

        "; - $html .= "

        »» [ Associated Sefran3: "; - # adds links to all associated Sefran - my @Sefran = qx(grep -H -E 'MC3_NAME\|$mc3\$' $WEBOBS{PATH_SEFRANS}/*/*.conf); - my @SefranLinks; - for my $s3 (@Sefran) { - chomp $s3; - $s3 =~ s/^$WEBOBS{PATH_SEFRANS}\///g; - $s3 =~ s/\/.*//g; - push(@SefranLinks, "$s3"); - } - $html .= join(" | ",@SefranLinks)." - Notes ]

        "; - - $html .= "
        " - .""; - ; - - # ----- selection box TZ (UTC or local) - if ($MC3{SELECT_LOCAL_TZ} ne "") { - $html .= "\n"; - } - - $html .="
        Date TZ: Start Date: "; - - # ----- selection box YEAR1 - $html .= "\n"; - # ----- selection box MONTH1 - $html .= "\n"; - # ----- selection box DAY1 - $html .= "\n"; - # ----- selection box HOUR1 - $html .= "\n"; - - # ----- selection box YEAR2 - $html .= "    End Date: \n"; - # ----- selection Box MONTH2 - $html .= "\n"; - # ----- selection box DAY2 - $html .= "\n"; - # ----- selection box HOUR2 - $html .= "\n"; - - # ----- selection box TYPE EVNT - $html .= "    Type: \n"; - - # ----- selection box DUREE - $html .= "    Duration: \n"; - - # ----- selection box AMPLITUDE - $html .= "    Amplitude: \n
        "; - - # ----- selection box OBSERVATION - my $msg = "Regular expression"; - if (@infoFiltre ne ("")) { - $msg = htmlspecialchars(join('',@infoFiltre)); - $msg =~ s/\n//g; # this is needed by overlib() - $msg =~ s/'/\\'/g; # this is needed by overlib() - } - - $html .= " Filter (?):" - ." {'obs'}\">"; - if ($QryParm->{'obs'} ne "") { - $html .= ""; - } - - # ----- selection box LOCALISATION - $html .= "  Status: \n"; - - $html .= "  Locations: \n"; - - if ( !$MC3{DISPLAY_LOCATION_DEFAULT} ) { - $html .= "  {'hideloc'} ? "":" checked").">Show loc info (slower)"; - } else { - $html .= "  {'hideloc'} ? " checked":"").">No loc info (faster)"; - } - - if (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) { - $html .= "  {'trash'} ? " checked":"").">Trash"; - } - $html .= "  {'nograph'} ? " checked":"").">No graph (faster)"; - $html .= "        		"; - - # ----- Hidden fields + button(s) - $html .= "\n" - ."\n" - ."{'newts'}\">\n" - #."" - ."" - ."
        \n" - ."
        Searching for data... please wait.
        "; - - $html .= "\n" - ."\n" - ."\n); - } + my ($job_jid, $job_kid, $org, $job_start, $job_end, + $job_cmd, $job_stdpath, $job_rc, $job_rcmsg, $elapsed) = @$run; + + push(@jid_list, $job_jid) unless grep{$_ eq $job_jid} @jid_list; + + if ($QryParm->{'jid'} eq "" || $QryParm->{'jid'} eq $job_jid) { + + my $elapsed_column = ''; + my $bgcolor = "transparent"; + + # Running jobs have an undefined end date + my $is_running = not defined($job_end); + $jobsdefsCount++; + $jobsdefsId="jdef".$jobsdefsCount; + + if ($is_running) { + $job_rc = ''; + $job_rcmsg = ''; + $job_end = 'Running'; + } else { + my ($seconds, $ms) = split(/\./, ($elapsed)); + my @time = reverse($seconds%60, ($seconds/=60) % 60, ($seconds/=60) % 24, ($seconds/=24) ); + $elapsed_column = sprintf "%03d:%02d:%02d:%02d.%3.3s", @time, $ms; + + # Return code shows success: use a green background in the RC column + $bgcolor = ($job_rc == 0 ? "green":"red"); + } + + if (length($job_cmd) > $maxdcmdl) { + my $s = ($maxdcmdl-5)/2; + $job_cmd = substr($job_cmd,0,$s).'(...)'.substr($job_cmd,-$s); + } + $job_start =~ s/^.* //; + $job_end =~ s/^.* //; + $jobsruns .= qq(\n); + } } - # ---- Print the rest of the page # ------------------------------- print <<"EOP1"; @@ -386,7 +398,7 @@ sub fetch_all { } EOP1 if ($admOK) { - print <<"EOP2"; + print <<"EOP2"; function delADate() { var d1 = \$('#indate').val(); var answer = confirm("do you really want to delete all records for "+d1+" ?"); @@ -426,29 +438,29 @@ sub fetch_all {
        EOP3 - print " •  Job: "; - print " "; - print " •  Date: "; - print ""; - if ($admOK) { - print ""; - } +print " •  Job: "; +print " "; +print " •  Date: "; +print ""; +if ($admOK) { + print ""; +} print <<"EOP4"; $jobsrunsMsg
        diff --git a/CODE/cgi-bin/sefran3.pl b/CODE/cgi-bin/sefran3.pl index 99dfda83..cce16da5 100755 --- a/CODE/cgi-bin/sefran3.pl +++ b/CODE/cgi-bin/sefran3.pl @@ -95,6 +95,7 @@ =head1 Query string parameters my $replay = $cgi->url_param('replay'); my $hpx = $cgi->url_param('hpx'); my $limit = $cgi->url_param('limit'); + # $hideloc is read below # ---- analysis (depouillement) mode ? @@ -108,7 +109,7 @@ =head1 Query string parameters my %SEFRAN3 = readCfg("$s3conf") if (-f "$s3conf"); my $hideloc = $cgi->url_param('hideloc') - // not $SEFRAN3{MC3_EVENT_DISPLAY_LOC} =~ m/^(Y|YES|1)$/i; + // not $SEFRAN3{MC3_EVENT_DISPLAY_LOC} =~ m/^(Y|YES|1)$/i; # ---- loads MC3 configuration: requested or Sefran's or default $mc3 ||= $SEFRAN3{MC3_NAME} ||= $WEBOBS{MC3_DEFAULT_NAME}; @@ -118,15 +119,15 @@ =head1 Query string parameters # ---- checking for authorizations my $editOK = 0; if (%SEFRAN3) { - if (%MC3) { - if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"MC") - || WebObs::Users::clientHasRead(type=>"authprocs",name=>"$mc3")) { - if ( WebObs::Users::clientHasEdit(type=>"authprocs",name=>"MC") - || WebObs::Users::clientHasEdit(type=>"authprocs",name=>"$mc3")) { - $editOK = 1; - } - } else { die "$__{'Not authorized'} (read)"} - } else { die "$__{'Could not read'} MC configuration $mc3" } + if (%MC3) { + if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"MC") + || WebObs::Users::clientHasRead(type=>"authprocs",name=>"$mc3")) { + if ( WebObs::Users::clientHasEdit(type=>"authprocs",name=>"MC") + || WebObs::Users::clientHasEdit(type=>"authprocs",name=>"$mc3")) { + $editOK = 1; + } + } else { die "$__{'Not authorized'} (read)"} + } else { die "$__{'Could not read'} MC configuration $mc3" } } else { die "$__{'Could not read'} Sefran configuration $s3" } my $userLevel = 0; @@ -135,6 +136,7 @@ =head1 Query string parameters $userLevel = 4 if (WebObs::Users::clientHasAdm(type=>"authprocs",name=>"MC") || WebObs::Users::clientHasAdm(type=>"authprocs",name=>"$mc3")); if (!defined($limit)) { $limit = $SEFRAN3{TIME_INTERVALS_DEFAULT_VALUE}; } + # for "last events" mode ($limit = 0), forces real-time ($ref = 0) if ($limit == 0) { $ref = 0; } @@ -144,26 +146,29 @@ =head1 Query string parameters my @alias; my @streams; for (@channels) { - my ($ali,$cod) = split(/\s+/,$_); - push(@alias,$ali); - push(@streams,$cod); + my ($ali,$cod) = split(/\s+/,$_); + push(@alias,$ali); + push(@streams,$cod); } + # event codes (types) my %types = readCfg("$MC3{EVENT_CODES_CONF}",'sorted'); my %typesSO; my $typesJSARR = "["; for (keys(%types)) { - $typesSO{$types{$_}{_SO_}} = $_; - $typesJSARR .= "\"$_\"," if ($types{$_}{WO2SC3} == 1); + $typesSO{$types{$_}{_SO_}} = $_; + $typesJSARR .= "\"$_\"," if ($types{$_}{WO2SC3} == 1); } $typesJSARR .= "]"; + # events duration texts my @durations = readCfgFile("$MC3{DURATIONS_CONF}"); my %duration_s; for (@durations) { - my ($key,$nam,$val) = split(/\|/,$_); - $duration_s{$key} = $val; + my ($key,$nam,$val) = split(/\|/,$_); + $duration_s{$key} = $val; } + # events amplitude texts/thresholds # [TODO]: converts to regular HoH config file... my %nomAmp; @@ -171,30 +176,30 @@ =head1 Query string parameters my @ampfile = readCfgFile("$MC3{AMPLITUDES_CONF}"); my $i = 0; for (@ampfile) { - my ($key,$nam,$val,$kb) = split(/\|/,$_); - my $skey = sprintf("%02d",$i)."_$key"; # adds a prefix "xx_" to the hash key to be sorted - $nomAmp{$key} = $nam; - $amplitudes{$skey}{Name} = $nam; - $amplitudes{$skey}{Value} = $val; - $amplitudes{$skey}{KBcode} = $kb; - $i++; + my ($key,$nam,$val,$kb) = split(/\|/,$_); + my $skey = sprintf("%02d",$i)."_$key"; # adds a prefix "xx_" to the hash key to be sorted + $nomAmp{$key} = $nam; + $amplitudes{$skey}{Name} = $nam; + $amplitudes{$skey}{Value} = $val; + $amplitudes{$skey}{KBcode} = $kb; + $i++; } + # time interval texts + value in hours my @time_intervals = split(/,/,exists($SEFRAN3{TIME_INTERVALS_LIST}) ? $SEFRAN3{TIME_INTERVALS_LIST}:"0,6,12,24,48"); my %time_limits; for (@time_intervals) { - if ($_ == 0) { - $time_limits{$_} = $__{'Last MC events'}; - } elsif ($_%168 == 0) { - $time_limits{$_} = ($_/168)." week".($_/168>1 ? "s":""); - } elsif ($_%24 == 0) { - $time_limits{$_} = ($_/24)." day".($_/24>1 ? "s":""); - } else { - $time_limits{$_} = "$_ hours"; - } + if ($_ == 0) { + $time_limits{$_} = $__{'Last MC events'}; + } elsif ($_%168 == 0) { + $time_limits{$_} = ($_/168)." week".($_/168>1 ? "s":""); + } elsif ($_%24 == 0) { + $time_limits{$_} = ($_/24)." day".($_/24>1 ? "s":""); + } else { + $time_limits{$_} = "$_ hours"; + } } - # spectrogram my $sgramOK = isok($SEFRAN3{SGRAM_ACTIVE}); @@ -226,16 +231,18 @@ =head1 Query string parameters my $i; if (!$ref) { - $yref = $Ya; - $mref = $ma; - $dref = $da; - $href = $Ha; + $yref = $Ya; + $mref = $ma; + $dref = $da; + $href = $Ha; } else { - # permits 29-31 days for all months... - my $day0 = $dref - 1; - ($yref,$mref,$dref) = split('/',strftime('%Y/%m/%d',gmtime(timegm(0,0,0,1,$mref-1,$yref-1900) + $day0*86400))); - # if the reference date is specified (not real-time), forces 24 hours minimum display - $limit = 24 if ($limit < 24); + + # permits 29-31 days for all months... + my $day0 = $dref - 1; + ($yref,$mref,$dref) = split('/',strftime('%Y/%m/%d',gmtime(timegm(0,0,0,1,$mref-1,$yref-1900) + $day0*86400))); + +# if the reference date is specified (not real-time), forces 24 hours minimum display + $limit = 24 if ($limit < 24); } # ---- some display setups @@ -244,8 +251,8 @@ =head1 Query string parameters my $largeur_voies = $SEFRAN3{VALUE_PPI}+1; my $speed = $SEFRAN3{VALUE_SPEED}; if (($high || $dep) && $SEFRAN3{VALUE_SPEED_HIGH} > 0) { - $high = 1; - $speed = $SEFRAN3{VALUE_SPEED_HIGH}; + $high = 1; + $speed = $SEFRAN3{VALUE_SPEED_HIGH}; } my $largeur_image = $speed*$SEFRAN3{VALUE_PPI}; my $hauteur_image = ($hpx ne "" ? $hpx:$SEFRAN3{HEIGHT_INCH}*$SEFRAN3{VALUE_PPI}) + 1; @@ -268,7 +275,7 @@ =head1 Query string parameters "; if (!$date && !$ref) { - print "\n"; + print "\n"; } # ---- dynamic Javascript share variables with sefran3.js ---------------------- @@ -313,7 +320,7 @@ =head1 Query string parameters html if ($dep) { - print < html + # ---- end dynamic CSS --------------------------------------------------------- print ""; @@ -415,740 +423,760 @@ =head1 Query string parameters # ----------------------------------------------------------------------------- if (!$date) { - my $last_mc; - my $dt_lastmc; - my $limit_lastmc = $SEFRAN3{TIME_INTERVALS_DEFAULT_VALUE}; - if ($limit == 0) { - # gets the N=$SEFRAN3{DISPLAY_LAST_MC} last MC event: from the 2 last monthly files, extracts the Nth last event non 'AUTO' and returns 'yyyy-mm-dd|HH' - $last_mc = qx(find $MC3{ROOT} -name "$MC3{FILE_PREFIX}*.txt" | sort | tail -n2 | xargs sort -t '|' -k2,3 | tail -n$SEFRAN3{DISPLAY_LAST_MC} | head -n1 |sed -nE "s/^[0-9]+\\|([0-9]{4}-[0-9]{2}-[0-9]{2}\\|[0-9]{2}):.*/\\1/p" | xargs echo -n); - my $dtn = timegm(gmtime); - $dt_lastmc = timegm(0,0,substr($last_mc,11,2),substr($last_mc,8,2),substr($last_mc,5,2)-1,substr($last_mc,0,4)); - $limit_lastmc = int(($dtn - $dt_lastmc)/3600); - $limit_lastmc = $SEFRAN3{DISPLAY_DAYS}*24 if ($limit_lastmc/24 > $SEFRAN3{DISPLAY_DAYS}); - } - # builds the list of dates and loads associated MC events over the period (+ 1 day) - my @dates; - my @mclist; - for (0 .. ($limit>0?$limit:$limit_lastmc)) { - my $ymdh = strftime('%Y-%m-%d|%H',gmtime(timegm(0,0,$href,$dref,$mref-1,$yref-1900) - $_*3600)); - my $ymd = substr($ymdh,0,10); - push(@dates,$ymd) if (!grep(/^$ymd$/,@dates) && $_ < 24*$SEFRAN3{DISPLAY_DAYS}); - my $f = "$MC3{ROOT}/".substr($ymd,0,4)."/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}".substr($ymd,0,4).substr($ymd,5,2).".txt"; - if (-f $f) { - my @mchour = split(/\n/,qx(grep "|$ymdh:" $f)); - push(@mclist,@mchour); - } - } - my @listeHeures = reverse('00'..'23'); - - my $dt = 0; - my $last_mn; - my $lmn; - - # what's the last minute-image ? searches for it and computes realtime delta - my $last_d = qx(y=\$(find $SEFRAN3{ROOT} -maxdepth 1 -name "????" | sort | tail -n1);find \$y -maxdepth 1| sort | tail -n1 | xargs echo -n); - if ($last_d) { - $last_mn = qx/find $last_d -name "??????????????.png"|sort|tail -n1/; - if ($last_mn) { - $lmn = basename($last_mn); - my @lm = (substr($lmn,10,2),substr($lmn,8,2),substr($lmn,6,2),substr($lmn,4,2),substr($lmn,0,4)); - $dt = (timegm(gmtime) - timegm(0,$lm[0],$lm[1],$lm[2],$lm[3]-1,$lm[4]-1900) - 60); - } - } - - # title and current data/time - print "
        "; - if ($QryParm->{'nograph'} == 0) { - $html .= "
        \n" - ."\n" - ."
        		"; - # ----- selection box graph-type - $html .= "

        Graph: 

        "; - } else { - $html .= "        		"; - } + $html .= "

        $MC3{TITLE}

        "; + $html .= "

        »» [ Associated Sefran3: "; + + # adds links to all associated Sefran + my @Sefran = qx(grep -H -E 'MC3_NAME\|$mc3\$' $WEBOBS{PATH_SEFRANS}/*/*.conf); + my @SefranLinks; + for my $s3 (@Sefran) { + chomp $s3; + $s3 =~ s/^$WEBOBS{PATH_SEFRANS}\///g; + $s3 =~ s/\/.*//g; + push(@SefranLinks, "$s3"); + } + $html .= join(" | ",@SefranLinks)." - Notes ]

        "; + + $html .= "" + .""; + ; + + # ----- selection box TZ (UTC or local) + if ($MC3{SELECT_LOCAL_TZ} ne "") { + $html .= "\n"; + } + + $html .="
        Date TZ: Start Date: "; + + # ----- selection box YEAR1 + $html .= "\n"; + + # ----- selection box MONTH1 + $html .= "\n"; + + # ----- selection box DAY1 + $html .= "\n"; + + # ----- selection box HOUR1 + $html .= "\n"; + + # ----- selection box YEAR2 + $html .= "    End Date: \n"; + + # ----- selection Box MONTH2 + $html .= "\n"; + + # ----- selection box DAY2 + $html .= "\n"; + + # ----- selection box HOUR2 + $html .= "\n"; + + # ----- selection box TYPE EVNT + $html .= "    Type: \n"; + + # ----- selection box DUREE + $html .= "    Duration: \n"; + + # ----- selection box AMPLITUDE + $html .= "    Amplitude: \n
        "; + + # ----- selection box OBSERVATION + my $msg = "Regular expression"; + if (@infoFiltre ne ("")) { + $msg = htmlspecialchars(join('',@infoFiltre)); + $msg =~ s/\n//g; # this is needed by overlib() + $msg =~ s/'/\\'/g; # this is needed by overlib() + } + + $html .= " Filter (?):" + ." {'obs'}\">"; + if ($QryParm->{'obs'} ne "") { + $html .= ""; + } + + # ----- selection box LOCALISATION + $html .= "  Status: \n"; + + $html .= "  Locations: \n"; + + if ( !$MC3{DISPLAY_LOCATION_DEFAULT} ) { + $html .= "  {'hideloc'} ? "":" checked").">Show loc info (slower)"; + } else { + $html .= "  {'hideloc'} ? " checked":"").">No loc info (faster)"; + } + + if (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) { + $html .= "  {'trash'} ? " checked":"").">Trash"; + } + $html .= "  {'nograph'} ? " checked":"").">No graph (faster)"; + $html .= "        		"; + + # ----- Hidden fields + button(s) + $html .= "\n" + ."\n" + ."{'newts'}\">\n" + +#."" + ."" + ."
        \n" + ."
        Searching for data... please wait.
        "; + + $html .= "\n" + ."\n" + ."
        "; + if ($QryParm->{'nograph'} == 0) { + $html .= "
        \n" + ."
        " + ."plot all" + + #."
        download image
        \n" + ."
        		"; + + # ----- selection box graph-type + $html .= "

        Graph: 

        "; + } else { + $html .= "        		"; + } } # ---- some more inits (mainly for files below) ------------------------------- @@ -546,13 +557,13 @@ sub compute_energy { my @b3_lon; my @b3_lat; my @b3_nam; my @b3_isl; my @b3_sit; my @b3_dat; my $i = 0; for (@listeCommunes) { - my (@champs) = split(/\|/,$_); - $b3_sit[$i] = $champs[4]; - $b3_lon[$i] = $champs[1]; - $b3_lat[$i] = $champs[0]; - $b3_nam[$i] = $champs[2]; - $b3_isl[$i] = $champs[3]; - $i++; + my (@champs) = split(/\|/,$_); + $b3_sit[$i] = $champs[4]; + $b3_lon[$i] = $champs[1]; + $b3_lat[$i] = $champs[0]; + $b3_nam[$i] = $champs[2]; + $b3_isl[$i] = $champs[3]; + $i++; } # ---- init/check for Hypocenters files (FMT) usage --------------------------- @@ -561,10 +572,10 @@ sub compute_energy { my $HYPO_USE_FMT0_FILE = ""; # FMT0 was SISMOHYP_HYPO_USE and al. my $HYPO_USE_FMT1_PATH = ""; # FMT1 was OVPF_HYPO_USE and al. if (defined $MC3{HYPO_USE_FMT0} and length $MC3{HYPO_USE_FMT0}) { - ($HYPO_USE_FMT0_PATH,$HYPO_USE_FMT0_FILE) = split(/,/,$MC3{HYPO_USE_FMT0}); + ($HYPO_USE_FMT0_PATH,$HYPO_USE_FMT0_FILE) = split(/,/,$MC3{HYPO_USE_FMT0}); } if (defined $MC3{HYPO_USE_FMT1} and length $MC3{HYPO_USE_FMT1}) { - $HYPO_USE_FMT1_PATH = $MC3{HYPO_USE_FMT1}; + $HYPO_USE_FMT1_PATH = $MC3{HYPO_USE_FMT1}; } # ---- Load hypocentres ------------------------------------------------------- @@ -572,55 +583,58 @@ sub compute_energy { #DL-was: if ($MC3{SISMOHYP_HYPO_USE}) { #DL-was: my $fileHypo = "$WEBOBS{RACINE_FTP}/$WEBOBS{SISMOHYP_PATH_FTP}/$WEBOBS{SISMOHYP_HYPO_FILE}"; if ($HYPO_USE_FMT0_PATH) { - my $fileHypo = "$HYPO_USE_FMT0_PATH/$HYPO_USE_FMT0_FILE"; - if (-e $fileHypo) { - @hypos = readFile($fileHypo); - } - my $fileHypoAuto = "$HYPO_USE_FMT0_PATH/Auto/$HYPO_USE_FMT0_FILE"; - if (-e $fileHypoAuto) { - push(@hypos,readFile($fileHypoAuto)); - } + my $fileHypo = "$HYPO_USE_FMT0_PATH/$HYPO_USE_FMT0_FILE"; + if (-e $fileHypo) { + @hypos = readFile($fileHypo); + } + my $fileHypoAuto = "$HYPO_USE_FMT0_PATH/Auto/$HYPO_USE_FMT0_FILE"; + if (-e $fileHypoAuto) { + push(@hypos,readFile($fileHypoAuto)); + } } # ---- Load data files (MC + HYPO) for [dateStart-dateEnd] -------------------- # for my $y ($start_datetime->year..$end_datetime->year) { - my $y2 = substr($y,2); - if ($HYPO_USE_FMT0_PATH) { - my $fileHypo2 = "$HYPO_USE_FMT0_PATH/Global/$y"."_".$HYPO_USE_FMT0_FILE; - if (-e $fileHypo2) { - push(@hypos,readFile($fileHypo2)); - } - } - #DL-was: if ($MC3{OVPF_HYPO_USE}) { - #DL-was: my $fileHypo3 = "$WEBOBS{OVPFHYP_PATH}/$y.hyp" - if ($HYPO_USE_FMT1_PATH) { - my $fileHypo3 = "$HYPO_USE_FMT1_PATH/$y.hyp"; - if (-e $fileHypo3) { - push(@hypos,readFile($fileHypo3)); - } - } - for my $m ("01".."12") { - my $start_month = DateTime->new(year => $y, month => $m, day => 1); - #my $end_month = DateTime->last_day_of_month(year => $y, month => $m); - my $end_month = $start_month->clone; - $end_month->add( months => 1 ); # first day of the next month - if (DateTime->compare($end_month,$start_datetime) gt 0 - && DateTime->compare($start_month,$end_datetime) le 0) { - $fileMC = "$MC3{ROOT}/$y/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$y$m.txt"; - if (-e $fileMC) { - push(@lignes,grep(/.+\|.+/,readCfgFile($fileMC))); - $nb = $#lignes; - } - # @hypo will contain only valid year-month locations - if ($HYPO_USE_FMT0_PATH) { - push(@hypo,grep(/^$y$m/,@hypos)); - } - if ($HYPO_USE_FMT1_PATH) { - push(@hypo,grep(/^$y2$m/,@hypos)); - } - } - } + my $y2 = substr($y,2); + if ($HYPO_USE_FMT0_PATH) { + my $fileHypo2 = "$HYPO_USE_FMT0_PATH/Global/$y"."_".$HYPO_USE_FMT0_FILE; + if (-e $fileHypo2) { + push(@hypos,readFile($fileHypo2)); + } + } + + #DL-was: if ($MC3{OVPF_HYPO_USE}) { + #DL-was: my $fileHypo3 = "$WEBOBS{OVPFHYP_PATH}/$y.hyp" + if ($HYPO_USE_FMT1_PATH) { + my $fileHypo3 = "$HYPO_USE_FMT1_PATH/$y.hyp"; + if (-e $fileHypo3) { + push(@hypos,readFile($fileHypo3)); + } + } + for my $m ("01".."12") { + my $start_month = DateTime->new(year => $y, month => $m, day => 1); + + #my $end_month = DateTime->last_day_of_month(year => $y, month => $m); + my $end_month = $start_month->clone; + $end_month->add( months => 1 ); # first day of the next month + if (DateTime->compare($end_month,$start_datetime) gt 0 + && DateTime->compare($start_month,$end_datetime) le 0) { + $fileMC = "$MC3{ROOT}/$y/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$y$m.txt"; + if (-e $fileMC) { + push(@lignes,grep(/.+\|.+/,readCfgFile($fileMC))); + $nb = $#lignes; + } + + # @hypo will contain only valid year-month locations + if ($HYPO_USE_FMT0_PATH) { + push(@hypo,grep(/^$y$m/,@hypos)); + } + if ($HYPO_USE_FMT1_PATH) { + push(@hypo,grep(/^$y2$m/,@hypos)); + } + } + } } # ---- Load titles ------------------------------------------------------------ @@ -631,198 +645,212 @@ sub compute_energy { # ---- Process request to dump a bulletin ------------------------------------- # if ($QryParm->{'dump'} eq 'bul') { - $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_bulletin.csv"; - push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); - push(@csv,"#YYYYmmdd HHMMSS.ss;Nb(#);Duration;Amplitude;Magnitude;E(J);Longitude;Latitude;Depth;Type;File;LocMode;LocType;Projection;Operator;Timestamp;ID\n"); + $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_bulletin.csv"; + push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); + push(@csv,"#YYYYmmdd HHMMSS.ss;Nb(#);Duration;Amplitude;Magnitude;E(J);Longitude;Latitude;Depth;Type;File;LocMode;LocType;Projection;Operator;Timestamp;ID\n"); } if ($QryParm->{'dump'} eq 'cum') { - $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_daily_total.csv"; - push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); - push(@csv,"#Daily histogram counted from ".(($start_datetime)->strftime('%F %H:00:00'))."\n"); - push(@csv,"#YYYY-mm-dd Daily_Total(#);Daily_Count;Daily_Moment(N.m);Daily_Energy(J)\n"); + $dumpFile = "WO_$WEBOBS{WEBOBS_ID}_${mc3}_dump_daily_total.csv"; + push(@csv,"#WEBOBS-$WEBOBS{WEBOBS_ID}: $MC3{TITLE}\n"); + push(@csv,"#Daily histogram counted from ".(($start_datetime)->strftime('%F %H:00:00'))."\n"); + push(@csv,"#YYYY-mm-dd Daily_Total(#);Daily_Count;Daily_Moment(N.m);Daily_Energy(J)\n"); } # ---- Filter events based on selection criteria: use of grep on the data line (fast!) ------------------------------ - # Filter out trashed event (except for Administrators) - # - if ( (!clientHasAdm(type=>"authprocs",name=>"MC") && !clientHasAdm(type=>"authprocs",name=>"$mc3")) || $QryParm->{'trash'} == 0 ) { - @lignes = grep(!/^-/, @lignes); - } - # Filter on type - # - if (($QryParm->{'type'} ne "") && ($QryParm->{'type'} ne "ALL")) { - @lignes = grep(/\|$QryParm->{'type'}\|/, @lignes) - } - # Filter on amplitude - # - if (($QryParm->{'ampoper'} eq "eq") && ($QryParm->{'amplitude'} ne "") && ($QryParm->{'amplitude'} ne "ALL")) { - @lignes = grep(/\|$QryParm->{'amplitude'}\|/, @lignes) - } - # Filter on observations - # - if ($QryParm->{'obs'} ne "") { - if (substr($QryParm->{'obs'},0,1) eq "!") { - my $regex = substr($QryParm->{'obs'},1); - @lignes = grep(!/$regex/i, @lignes); - } else { - @lignes = grep(/$QryParm->{'obs'}/i, @lignes); - } - } +# Filter out trashed event (except for Administrators) +# +if ( (!clientHasAdm(type=>"authprocs",name=>"MC") && !clientHasAdm(type=>"authprocs",name=>"$mc3")) || $QryParm->{'trash'} == 0 ) { + @lignes = grep(!/^-/, @lignes); +} + +# Filter on type +# +if (($QryParm->{'type'} ne "") && ($QryParm->{'type'} ne "ALL")) { + @lignes = grep(/\|$QryParm->{'type'}\|/, @lignes) +} + +# Filter on amplitude +# +if (($QryParm->{'ampoper'} eq "eq") && ($QryParm->{'amplitude'} ne "") && ($QryParm->{'amplitude'} ne "ALL")) { + @lignes = grep(/\|$QryParm->{'amplitude'}\|/, @lignes) +} + +# Filter on observations +# +if ($QryParm->{'obs'} ne "") { + if (substr($QryParm->{'obs'},0,1) eq "!") { + my $regex = substr($QryParm->{'obs'},1); + @lignes = grep(!/$regex/i, @lignes); + } else { + @lignes = grep(/$QryParm->{'obs'}/i, @lignes); + } +} # ---- Filters requiring loading of data from $dateStart to $DateEnd), duration, localization, ... # my $l = 0; my %QML; foreach my $line (@lignes) { - $l++; - my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat, - $nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature, - $comment) = split(/\|/,$line); - my ($operator,$timestamp) = split("/",$signature); - my $origin; - my $duree_s = ($duree ? $duree*$duration_s{$unite}:""); - my @evt_date_elem = split(/-/,$date); - my @evt_hour_elem = split(/:/,$heure); - my $evt_date = DateTime->new(year => $evt_date_elem[0], - month => $evt_date_elem[1], - day => $evt_date_elem[2], - hour => $evt_hour_elem[0]); - my $evt_amp = $valAmp{$amplitude}; - # default timestamp for old data is event date - $timestamp = join('',@evt_date_elem)."T".join('',@evt_hour_elem) if ($timestamp eq ""); - my ($lat,$lon,$dep,$mag,$mty,$cod,$dat,$pha,$qua,$mod,$sta,$mth,$mdl,$typ); - #XB-was: if (($date le $dateEnd && $date ge $dateStart) - #XB-was: && ($QryParm->{'duree'} eq "" || $QryParm->{'duree'} eq "NA" || $QryParm->{'duree'} eq "ALL" || $duree_s >= $QryParm->{'duree'}) - if ($evt_date ge $start_datetime && $evt_date le $end_datetime - && ($QryParm->{'duree'} ~~ ["", "NA", "ALL"] || $duree_s >= $QryParm->{'duree'} || length($qml) > 2) - && ($QryParm->{'amplitude'} ~~ ["", "ALL"] || $QryParm->{'ampoper'} eq 'eq' - || ($QryParm->{'ampoper'} eq 'le' && $evt_amp <= $valAmp{$QryParm->{'amplitude'}}) - || ($QryParm->{'ampoper'} eq 'ge' && $evt_amp >= $valAmp{$QryParm->{'amplitude'}})) - && ($QryParm->{'newts'} eq "" || $timestamp ge $QryParm->{'newts'}) - ) { - # do not display location informations - if ($QryParm->{'hideloc'} == 1 || $MC3{SC3_EVENTS_ROOT} eq "") { - for (keys %QML) { - delete $QML{$_}; - } - } - # ID SC3 case: load SC3ml file (et écrasement d'une éventuelle origine existante - cas de Zandets) - elsif ($MC3{SC3_EVENTS_ROOT} ne "" && $qml =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { - my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$qml); - %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$qml/$sc3id.last.xml"); - if (%QML) { - $origin = "$sc3id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; - } else { - $origin = ''; - } - $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; - } - # ID FDSNWS case: request QuakeML file by FDSN webservice - elsif ($qml =~ /:\/\//) { - my ($fdsnws_src,$evt_id) = split(/:\/\//,$qml); - my $fdsnws_url = ""; - my $fdsnws_detail = ""; - if (defined($MC3{FDSNWS_EVENTS_URL})) { - $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; - } - if (length($fdsnws_src) > 0) { - my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; - $fdsnws_url = "$MC3{$varname}"; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; - $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_src"; - if (defined($MC3{$varname})) { - $fdsnws_detail = $MC3{$varname}; - } - } - %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); - if (%QML) { - #[FB-note]: replaced by empty type in the SC3_EVENT_TYPES_NOLOCATION list - #$QML{type} = "not locatable" if ($QML{type} eq ""); - $origin = "$evt_id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; - } else { - $origin = ''; - } - $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; - } - # Old suds ID case : - elsif (length($qml) < 3 && $HYPO_USE_FMT0_PATH) { - my @loca; - my $suds_sans_seconde; - my $suds_racine; - my $evt_annee4; - my $evt_mois; - if (length($suds) > 10 && ($suds =~ ".gwa" || $suds =~ ".mq0")) { - ($evt_annee4, $evt_mois) = unpack("a4 a2",$suds); - } else { - ($evt_annee4, $evt_mois) = unpack("a4 x a2",$date); - } - if (length($suds)==12 && substr($suds,8,1) eq '.') { - # ne prend que les premiers caractères du nom de fichier - $suds_sans_seconde = substr($suds,0,7); - @loca = grep(/ $suds_sans_seconde/,grep(/^$evt_annee4$evt_mois/,@hypo)); - } elsif (length($suds)==19) { - $suds_racine = substr($suds,0,15); - @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); - } - for (@loca) { - my $id; - $dat = sprintf("%d-%02d-%02d %02d:%02d:%02.2f TU",substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,9,2),substr($_,11,2),substr($_,14,5)); - $mag = substr($_,47,5); - $mty = 'Md'; - $lat = substr($_,20,2) + substr($_,23,5)/60; - $lon = -(substr($_,30,2) + substr($_,33,5)/60); - $dep = substr($_,39,6); - $pha = substr($_,53,2); - $qua = substr($_,80,1); - $cod = substr($_,83,5); - if (length(substr($_,89))>15) { - $id = substr($_,89,15); - } - elsif (length(substr($_,89))<10) { - $id = substr($_,89); - } - $mod = 'manual'; - $origin = "$id;$dat;$lat;$lon;$dep;$pha;$mod;;$mag;$mty;Hypo71;;$cod"; - $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; - } - } - - ($cod,$dat,$lat,$lon,$dep,$pha,$mod,$sta,$mag,$mty,$mth,$mdl,$typ) = split(';',$origin); - my $noloc = 0; - $noloc = 1 if (grep(/^$typ$/,@nolocation_types)); - - if ($QryParm->{'located'} == 0 && $QryParm->{'locstatus'} == 0 - || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') - || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') - || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 0) - || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') - || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') - || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 0) - || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') - || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') - || $QryParm->{'hideloc'} == 1 ) { - if ($QryParm->{'dump'} eq 'bul') { - my $energy = ''; - if ($mag) { - # Include energy in joules into the CSV output - $energy = compute_energy($mag); - } - push(@csv,join('',split(/-/,$date))." ".join('',split(/:/,$heure)).";" - ."$nombre;$duree_s;$amplitude;$mag;$energy;$lon;$lat;$dep;$type;$qml;" - #.($mod eq 'manual' ? "1":"0").";WGS84;$operator;$timestamp;" - ."$mod".($sta == "" ? "":" ($sta)").";$typ;WGS84;$operator;$timestamp;" - .substr($date,0,7)."#$id_evt\n"); - #FB-was:} elsif ($QryParm->{'dump'} eq "") { - } else { - push(@finalLignes,$line); - push(@numeroLigneReel,$l); - } - } - } + $l++; + my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat, + $nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature, + $comment) = split(/\|/,$line); + my ($operator,$timestamp) = split("/",$signature); + my $origin; + my $duree_s = ($duree ? $duree*$duration_s{$unite}:""); + my @evt_date_elem = split(/-/,$date); + my @evt_hour_elem = split(/:/,$heure); + my $evt_date = DateTime->new(year => $evt_date_elem[0], + month => $evt_date_elem[1], + day => $evt_date_elem[2], + hour => $evt_hour_elem[0]); + my $evt_amp = $valAmp{$amplitude}; + + # default timestamp for old data is event date + $timestamp = join('',@evt_date_elem)."T".join('',@evt_hour_elem) if ($timestamp eq ""); + my ($lat,$lon,$dep,$mag,$mty,$cod,$dat,$pha,$qua,$mod,$sta,$mth,$mdl,$typ); + +#XB-was: if (($date le $dateEnd && $date ge $dateStart) +#XB-was: && ($QryParm->{'duree'} eq "" || $QryParm->{'duree'} eq "NA" || $QryParm->{'duree'} eq "ALL" || $duree_s >= $QryParm->{'duree'}) + if ($evt_date ge $start_datetime && $evt_date le $end_datetime + && ($QryParm->{'duree'} ~~ ["", "NA", "ALL"] || $duree_s >= $QryParm->{'duree'} || length($qml) > 2) + && ($QryParm->{'amplitude'} ~~ ["", "ALL"] || $QryParm->{'ampoper'} eq 'eq' + || ($QryParm->{'ampoper'} eq 'le' && $evt_amp <= $valAmp{$QryParm->{'amplitude'}}) + || ($QryParm->{'ampoper'} eq 'ge' && $evt_amp >= $valAmp{$QryParm->{'amplitude'}})) + && ($QryParm->{'newts'} eq "" || $timestamp ge $QryParm->{'newts'}) + ) { + + # do not display location informations + if ($QryParm->{'hideloc'} == 1 || $MC3{SC3_EVENTS_ROOT} eq "") { + for (keys %QML) { + delete $QML{$_}; + } + } + +# ID SC3 case: load SC3ml file (et écrasement d'une éventuelle origine existante - cas de Zandets) + elsif ($MC3{SC3_EVENTS_ROOT} ne "" && $qml =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { + my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$qml); + %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$qml/$sc3id.last.xml"); + if (%QML) { + $origin = "$sc3id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; + } else { + $origin = ''; + } + $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; + } + + # ID FDSNWS case: request QuakeML file by FDSN webservice + elsif ($qml =~ /:\/\//) { + my ($fdsnws_src,$evt_id) = split(/:\/\//,$qml); + my $fdsnws_url = ""; + my $fdsnws_detail = ""; + if (defined($MC3{FDSNWS_EVENTS_URL})) { + $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; + } + if (length($fdsnws_src) > 0) { + my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; + $fdsnws_url = "$MC3{$varname}"; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; + $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_src"; + if (defined($MC3{$varname})) { + $fdsnws_detail = $MC3{$varname}; + } + } + %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); + if (%QML) { + + #[FB-note]: replaced by empty type in the SC3_EVENT_TYPES_NOLOCATION list + #$QML{type} = "not locatable" if ($QML{type} eq ""); + $origin = "$evt_id;$QML{time};$QML{latitude};$QML{longitude};$QML{depth};$QML{phases};$QML{mode};$QML{status};$QML{magnitude};$QML{magtype};$QML{method};$QML{model};$QML{type}"; + } else { + $origin = ''; + } + $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; + } + + # Old suds ID case : + elsif (length($qml) < 3 && $HYPO_USE_FMT0_PATH) { + my @loca; + my $suds_sans_seconde; + my $suds_racine; + my $evt_annee4; + my $evt_mois; + if (length($suds) > 10 && ($suds =~ ".gwa" || $suds =~ ".mq0")) { + ($evt_annee4, $evt_mois) = unpack("a4 a2",$suds); + } else { + ($evt_annee4, $evt_mois) = unpack("a4 x a2",$date); + } + if (length($suds)==12 && substr($suds,8,1) eq '.') { + + # ne prend que les premiers caractères du nom de fichier + $suds_sans_seconde = substr($suds,0,7); + @loca = grep(/ $suds_sans_seconde/,grep(/^$evt_annee4$evt_mois/,@hypo)); + } elsif (length($suds)==19) { + $suds_racine = substr($suds,0,15); + @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); + } + for (@loca) { + my $id; + $dat = sprintf("%d-%02d-%02d %02d:%02d:%02.2f TU",substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,9,2),substr($_,11,2),substr($_,14,5)); + $mag = substr($_,47,5); + $mty = 'Md'; + $lat = substr($_,20,2) + substr($_,23,5)/60; + $lon = -(substr($_,30,2) + substr($_,33,5)/60); + $dep = substr($_,39,6); + $pha = substr($_,53,2); + $qua = substr($_,80,1); + $cod = substr($_,83,5); + if (length(substr($_,89))>15) { + $id = substr($_,89,15); + } + elsif (length(substr($_,89))<10) { + $id = substr($_,89); + } + $mod = 'manual'; + $origin = "$id;$dat;$lat;$lon;$dep;$pha;$mod;;$mag;$mty;Hypo71;;$cod"; + $line = "$id_evt|$date|$heure|$type|$amplitude|$duree|$unite|$duree_sat|$nombre|$s_moins_p|$station|$arrivee|$suds|$qml|$event_img|$signature|$comment|$origin"; + } + } + + ($cod,$dat,$lat,$lon,$dep,$pha,$mod,$sta,$mag,$mty,$mth,$mdl,$typ) = split(';',$origin); + my $noloc = 0; + $noloc = 1 if (grep(/^$typ$/,@nolocation_types)); + + if ($QryParm->{'located'} == 0 && $QryParm->{'locstatus'} == 0 + || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') + || ($QryParm->{'located'} == 0 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') + || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 0) + || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') + || ($QryParm->{'located'} == 1 && $noloc == 0 && $pha >= $MC3{LOCATION_MIN_PHASES} && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') + || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 0) + || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 1 && $mod eq 'manual') + || ($QryParm->{'located'} == 2 && ($noloc == 1 || $pha >= $MC3{LOCATION_MIN_PHASES}) && $QryParm->{'locstatus'} == 2 && $mod eq 'automatic') + || $QryParm->{'hideloc'} == 1 ) { + if ($QryParm->{'dump'} eq 'bul') { + my $energy = ''; + if ($mag) { + + # Include energy in joules into the CSV output + $energy = compute_energy($mag); + } + push(@csv,join('',split(/-/,$date))." ".join('',split(/:/,$heure)).";" + ."$nombre;$duree_s;$amplitude;$mag;$energy;$lon;$lat;$dep;$type;$qml;" + + #.($mod eq 'manual' ? "1":"0").";WGS84;$operator;$timestamp;" + ."$mod".($sta == "" ? "":" ($sta)").";$typ;WGS84;$operator;$timestamp;" + .substr($date,0,7)."#$id_evt\n"); + + #FB-was:} elsif ($QryParm->{'dump'} eq "") { + } else { + push(@finalLignes,$line); + push(@numeroLigneReel,$l); + } + } + } } # ---- finalLignes = data to process, sorted ---------------------------------- @@ -837,17 +865,17 @@ sub compute_energy { my @stat_t; # Dates in YYYY-MM-DD format my @stat_j; # Javascript dates (in ms since 1970-01-01) for my $d (0..($nbDays - 1/24)) { - push(@stat_t, ($start_datetime + DateTime::Duration->new(days => $d))->strftime('%F')); - push(@stat_j, ($start_datetime + DateTime::Duration->new(days => $d) + DateTime::Duration->new(hours => 12))->epoch * 1000); + push(@stat_t, ($start_datetime + DateTime::Duration->new(days => $d))->strftime('%F')); + push(@stat_j, ($start_datetime + DateTime::Duration->new(days => $d) + DateTime::Duration->new(hours => 12))->epoch * 1000); } my @stat_th; my @stat_jh; # Javascript dates hourly (in ms since 1970-01-01) for my $h (0 .. ($nbDays*24 - 1)) { - my $d = $start_datetime + DateTime::Duration->new(hours => $h); - if ($d <= $now) { - push(@stat_th, $d->strftime('%F %H')); - push(@stat_jh, $d->epoch*1000); - } + my $d = $start_datetime + DateTime::Duration->new(hours => $h); + if ($d <= $now) { + push(@stat_th, $d->strftime('%F %H')); + push(@stat_jh, $d->epoch*1000); + } } my %stat_m; # hash of event types seismic moment per day my %stat_energy; # hash of event types seismic energy per day @@ -866,150 +894,154 @@ sub compute_energy { my $stat_max_duration_loc = 0; my $stat_max_magnitude_loc = 0; foreach (@finalLignes) { - if ( $_ ne "" ) { - my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); - if (!$nombre) { $nombre = 1; } - my $time = timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2),substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900); - my $duree_s = ($duree ? $duree*$duration_s{$unite}:0); - # computes index into data array from time - my $time_dt = DateTime->new(year => substr($date,0,4), - month => substr($date,5,2), - day => substr($date,8,2), - hour => substr($heure,0,2), - minute => substr($heure,3,2), - second => substr($heure,6,2)); - my $kd = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/86400); - my $kh = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/3600); - if ($origin) { - my @orig = split(';',$origin); - if ($orig[0]) { - # Event has an ID - my $M0 = 0; - my $km = 0; - my $mag = $orig[8]; - if ($mag) { - $M0 = 10**(1.5*$mag + 9.1); # unit = N.m - $stat_m{$type}[$kd] += $M0; - $stat_smh{$type}[$kh] += $M0; - $km = int($mag*10); - # negative magnitudes are counted in the first histogram bin - if ($km < 0) { $km = 0; } - $stat_grm[$km] = $km/10; - $stat_gr{$type}[$km] += 1; - - # Seismic energy calculation (J) - my $energy = compute_energy($mag); - $stat_energy{$type}[$kd] += $energy; - $stat_energy{TOTAL}[$kd] += $energy; - } - } - } - $stat{$type} += $nombre; - $stat{TOTAL} += $nombre; - $stat{VTcount} += ($types{$type}{asVT} ? $nombre * $types{$type}{asVT}:0); - $stat{RFcount} += ($types{$type}{asRF} ? $nombre * $types{$type}{asRF}:0); - if ($type eq "LOCAL") { - $stat{LOCcount} += $nombre; - } - - $stat_d{$type}[$kd] += $nombre; - if ($QryParm->{'nograph'} == 0) { - $stat_ch{$type}[$kh] += $nombre; - $stat_dh{$type}[$kh] += $nombre; - for ($kh .. ($kh+23)) { - $stat_vh{$type}[$_] += $nombre if ($_ <= $#stat_th); - } - for ($kh .. ($kh+(7*24-1))) { - $stat_wh{$type}[$_] += $nombre if ($_ <= $#stat_th); - } - for ($kh .. ($kh+(28*24-1))) { - $stat_mh{$type}[$_] += $nombre if ($_ <= $#stat_th); - } - } - my $dist; - my $Pvel = 6; - $Pvel = $MC3{P_WAVE_VELOCITY} if (defined $MC3{P_WAVE_VELOCITY}); - my $VpVs = 1.75; - $VpVs = $MC3{VP_VS_RATIO} if (defined $MC3{VP_VS_RATIO}); - if ($s_moins_p ne "NA" && $s_moins_p ne "") { - $dist = $Pvel*$s_moins_p/($VpVs-1); - } else { - $dist = 0; - } - if ($types{$type}{asVT} && $duree_s > $stat_max_duration) { - $stat_max_duration = $duree_s; - $stat_max_magnitude = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; - } - if ($type eq "LOCAL" && $duree_s > $stat_max_duration_loc) { - $stat_max_duration_loc = $duree_s; - $stat_max_magnitude_loc = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; - } - } + if ( $_ ne "" ) { + my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); + if (!$nombre) { $nombre = 1; } + my $time = timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2),substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900); + my $duree_s = ($duree ? $duree*$duration_s{$unite}:0); + + # computes index into data array from time + my $time_dt = DateTime->new(year => substr($date,0,4), + month => substr($date,5,2), + day => substr($date,8,2), + hour => substr($heure,0,2), + minute => substr($heure,3,2), + second => substr($heure,6,2)); + my $kd = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/86400); + my $kh = int($time_dt->subtract_datetime_absolute($start_datetime)->seconds/3600); + if ($origin) { + my @orig = split(';',$origin); + if ($orig[0]) { + + # Event has an ID + my $M0 = 0; + my $km = 0; + my $mag = $orig[8]; + if ($mag) { + $M0 = 10**(1.5*$mag + 9.1); # unit = N.m + $stat_m{$type}[$kd] += $M0; + $stat_smh{$type}[$kh] += $M0; + $km = int($mag*10); + + # negative magnitudes are counted in the first histogram bin + if ($km < 0) { $km = 0; } + $stat_grm[$km] = $km/10; + $stat_gr{$type}[$km] += 1; + + # Seismic energy calculation (J) + my $energy = compute_energy($mag); + $stat_energy{$type}[$kd] += $energy; + $stat_energy{TOTAL}[$kd] += $energy; + } + } + } + $stat{$type} += $nombre; + $stat{TOTAL} += $nombre; + $stat{VTcount} += ($types{$type}{asVT} ? $nombre * $types{$type}{asVT}:0); + $stat{RFcount} += ($types{$type}{asRF} ? $nombre * $types{$type}{asRF}:0); + if ($type eq "LOCAL") { + $stat{LOCcount} += $nombre; + } + + $stat_d{$type}[$kd] += $nombre; + if ($QryParm->{'nograph'} == 0) { + $stat_ch{$type}[$kh] += $nombre; + $stat_dh{$type}[$kh] += $nombre; + for ($kh .. ($kh+23)) { + $stat_vh{$type}[$_] += $nombre if ($_ <= $#stat_th); + } + for ($kh .. ($kh+(7*24-1))) { + $stat_wh{$type}[$_] += $nombre if ($_ <= $#stat_th); + } + for ($kh .. ($kh+(28*24-1))) { + $stat_mh{$type}[$_] += $nombre if ($_ <= $#stat_th); + } + } + my $dist; + my $Pvel = 6; + $Pvel = $MC3{P_WAVE_VELOCITY} if (defined $MC3{P_WAVE_VELOCITY}); + my $VpVs = 1.75; + $VpVs = $MC3{VP_VS_RATIO} if (defined $MC3{VP_VS_RATIO}); + if ($s_moins_p ne "NA" && $s_moins_p ne "") { + $dist = $Pvel*$s_moins_p/($VpVs-1); + } else { + $dist = 0; + } + if ($types{$type}{asVT} && $duree_s > $stat_max_duration) { + $stat_max_duration = $duree_s; + $stat_max_magnitude = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; + } + if ($type eq "LOCAL" && $duree_s > $stat_max_duration_loc) { + $stat_max_duration_loc = $duree_s; + $stat_max_magnitude_loc = 2*log($duree_s)/log(10)+0.0035*$dist-0.87; + } + } } my $total = 0; $i = 0; foreach my $day (@stat_t) { - my $daily_count = 0; - my $daily_moment = 0; - my $daily_energy = 0; - foreach my $evt_type (keys(%stat_d)) { - $daily_count += $stat_d{$evt_type}[$i] || 0; - $daily_moment += $stat_m{$evt_type}[$i] || 0; - - # Cumulate the total events energy for this day - $daily_energy += $stat_energy{$evt_type}[$i] || 0; - - # Also add up daily energy for this type of event - $stat_energy{$evt_type}[$i] += ($stat_energy{$evt_type}[$i-1] || 0) unless ($i == 0); - } - # Store the total daily energy - $stat_energy{TOTAL}[$i] = ($i > 0 ? $stat_energy{TOTAL}[$i-1] : 0) + $daily_energy; - - if ($QryParm->{'dump'} eq 'cum') { - push(@csv, sprintf("%s;%d;%g;%e\n", $day, $daily_count, $daily_moment, $daily_energy)); - } - $total += $daily_count; - $i++; + my $daily_count = 0; + my $daily_moment = 0; + my $daily_energy = 0; + foreach my $evt_type (keys(%stat_d)) { + $daily_count += $stat_d{$evt_type}[$i] || 0; + $daily_moment += $stat_m{$evt_type}[$i] || 0; + + # Cumulate the total events energy for this day + $daily_energy += $stat_energy{$evt_type}[$i] || 0; + + # Also add up daily energy for this type of event + $stat_energy{$evt_type}[$i] += ($stat_energy{$evt_type}[$i-1] || 0) unless ($i == 0); + } + + # Store the total daily energy + $stat_energy{TOTAL}[$i] = ($i > 0 ? $stat_energy{TOTAL}[$i-1] : 0) + $daily_energy; + + if ($QryParm->{'dump'} eq 'cum') { + push(@csv, sprintf("%s;%d;%g;%e\n", $day, $daily_count, $daily_moment, $daily_energy)); + } + $total += $daily_count; + $i++; } if ($QryParm->{'nograph'} == 0) { - for ($i = 1; $i <= $#stat_th; $i++) { - foreach (keys(%stat_smh)) { - $stat_smh{$_}[$i] += ($stat_smh{$_}[$i-1] ? $stat_smh{$_}[$i-1]:0); - } - foreach (keys(%stat_ch)) { - $stat_ch{$_}[$i] += ($stat_ch{$_}[$i-1] ? $stat_ch{$_}[$i-1]:0); - } - } - for ($i = $#stat_grm - 1; $i >= 0; $i--) { - if (!$stat_grm[$i]) { - $stat_grm[$i] = $i/10; - } - foreach (keys(%stat_gr)) { - $stat_gr{$_}[$i] += ($stat_gr{$_}[$i+1] ? $stat_gr{$_}[$i+1]:0); - } - } - my @key = keys(%stat_gr); - for ($i = 0; $i <= $#stat_grm; $i++) { - foreach (@key) { - $stat_gr{TOTAL}[$i] += ($stat_gr{$_}[$i] ? $stat_gr{$_}[$i]:0); - } - } + for ($i = 1; $i <= $#stat_th; $i++) { + foreach (keys(%stat_smh)) { + $stat_smh{$_}[$i] += ($stat_smh{$_}[$i-1] ? $stat_smh{$_}[$i-1]:0); + } + foreach (keys(%stat_ch)) { + $stat_ch{$_}[$i] += ($stat_ch{$_}[$i-1] ? $stat_ch{$_}[$i-1]:0); + } + } + for ($i = $#stat_grm - 1; $i >= 0; $i--) { + if (!$stat_grm[$i]) { + $stat_grm[$i] = $i/10; + } + foreach (keys(%stat_gr)) { + $stat_gr{$_}[$i] += ($stat_gr{$_}[$i+1] ? $stat_gr{$_}[$i+1]:0); + } + } + my @key = keys(%stat_gr); + for ($i = 0; $i <= $#stat_grm; $i++) { + foreach (@key) { + $stat_gr{TOTAL}[$i] += ($stat_gr{$_}[$i] ? $stat_gr{$_}[$i]:0); + } + } } my $nbD = int($nbDays); $html .= "

        Selection: $nbD day".($nbD>1 ? "s":""); if ($nbDays - $nbD != 0) { - my $nbH = int(($nbDays - $nbD)*24); - $html .= " $nbH hour".($nbH>1 ? "s":""); + my $nbH = int(($nbDays - $nbD)*24); + $html .= " $nbH hour".($nbH>1 ? "s":""); } if ($nbDays > 365) { - my $nbY = int($nbDays/365.25 + 0.5); - my $nbM = int(($nbDays%365.25)/30.4 + 0.5); - $html .= " ( ~ $nbY year".($nbY>1 ? "s":"")." $nbM month".($nbM>1 ? "s":"")." ) ";; + my $nbY = int($nbDays/365.25 + 0.5); + my $nbM = int(($nbDays%365.25)/30.4 + 0.5); + $html .= " ( ~ $nbY year".($nbY>1 ? "s":"")." $nbM month".($nbM>1 ? "s":"")." ) ";; } elsif ($nbDays > 30) { - my $nbM = int($nbDays/30. + 0.5); - $html .= " ( ~ $nbM month".($nbM>1 ? "s":"")." ) "; + my $nbM = int($nbDays/30. + 0.5); + $html .= " ( ~ $nbM month".($nbM>1 ? "s":"")." ) "; } $html .= "

        Total number of events: $total

        "; $html .= qq(

        Cumulated energy:).sprintf(" %.3e MJ", $stat_energy{TOTAL}[-1] / 10**6).qq(

        ); @@ -1017,30 +1049,31 @@ sub compute_energy { $html .= "

        Events bulletin:

        "; $html .= "\n"; - # ---- HTML-form for Information mailing # if ($MC3{DISPLAY_INFO_MAIL} && (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3"))) { - $html .= "
        "; - $html .= "

        Mail d'information:

        "; - #XB-was: $html .= ""; - #XB-was: $html .= ""; - $html .= "strftime("%F")."\"/>"; - $html .= "strftime("%F")."\"/>"; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= ""; - $html .= "
        \n"; - $html .= "
        "; - $html .= "

        Mail d'information REVOSIMA:

        "; - $html .= "strftime("%F")."\"/>"; - $html .= "strftime("%F")."\"/>"; - $html .= "
        \n"; + $html .= "
        "; + $html .= "

        Mail d'information:

        "; + +#XB-was: $html .= ""; +#XB-was: $html .= ""; + $html .= "strftime("%F")."\"/>"; + $html .= "strftime("%F")."\"/>"; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= ""; + $html .= "
        \n"; + $html .= "
        "; + $html .= "

        Mail d'information REVOSIMA:

        "; + $html .= "strftime("%F")."\"/>"; + $html .= "strftime("%F")."\"/>"; + $html .= "
        \n"; } + # ---- END of HTML-form #print ""; @@ -1050,94 +1083,96 @@ sub compute_energy { #print ""; #print "
        Total
        $total
        ", $html .= "
        " - ."
        "; + ."
        "; # ---- JavaScript for graphs with flot.js ------------------------------------- # if ($QryParm->{'nograph'} == 0) { - my @stat_v; - $html .= "\n"; + my @stat_v; + $html .= "\n"; } # ---- start building main table ---------------------------------------------- @@ -1145,51 +1180,55 @@ sub compute_energy { $html .= ""; @titres = split(/\|/,$ligneTitre[0]); for (my $i = 0; $i <= $#titres; $i++) { - if ($QryParm->{'hideloc'} == 0 || $i < 15 ) { - $html .= ""; - } + if ($QryParm->{'hideloc'} == 0 || $i < 15 ) { + $html .= ""; + } } $html .= ""; # ---- build/display main table ----------------------------------------------- # for (@finalLignes) { - if ( $_ ne "") { - my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); - my ($operator,$timestamp) = split("/",$signature); - my ($evt_annee4,$evt_mois,$evt_jour,$suds_jour,$suds_heure,$suds_minute,$suds_seconde,$suds_reseau) = split; - my $diriaspei; - my $suds_continu; - my $dirTrigger; - my $dirTriggerUrn; - my $seedlink; - my $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&date=".substr($date,0,4).substr($date,5,2).substr($date,8,2).substr($heure,0,2).substr($heure,3,2).substr($heure,6,2)."&id=$id_evt"; - my $begin = strftime('%Y,%m,%d,%H,%M,%S', - gmtime(timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2), - substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900)-10)); - my $duree_s = ($duree ne "" ? $duree*$duration_s{$unite}:0); - my $durmseed = ($duree_s + 20); - if (length($suds) > 10 && $suds =~ ".gwa") { - ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); - $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_GWA}."/".$evt_annee4.$evt_mois.$suds_jour; - $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".gwa"; - #djl-was:$editURL = "frameMC2.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; - } elsif (length($suds) > 10 && $suds =~ ".mq0") { - ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); - $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_MQ0}."/".$evt_annee4.$evt_mois.$suds_jour; - $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".mar"; - #djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; - } elsif (length($suds) > 10 && $suds =~ ".GUA" || $suds =~ ".GUX" || $suds =~ ".gl0") { - ($suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a2 a2 a2 a2 x a3",$suds); - ($evt_annee4,$evt_mois,$evt_jour) = split(/-/,$date); - $diriaspei = $WEBOBS{"PATH_SOURCE_SISMO_$suds_reseau"}."/".$evt_annee4.$evt_mois.$suds_jour; - #djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; - } else { - ($evt_annee4, $evt_mois, $suds_jour) = unpack("a4 x a2 x a2",$date); - ($suds_heure,$suds_minute) = unpack("a2 x a2",$heure); - $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&s3=$suds&date=$evt_annee4$evt_mois$suds_jour$suds_heure$suds_minute&id=$id_evt"; - $seedlink = 1; - } + if ( $_ ne "") { + my ($id_evt,$date,$heure,$type,$amplitude,$duree,$unite,$duree_sat,$nombre,$s_moins_p,$station,$arrivee,$suds,$qml,$event_img,$signature,$comment,$origin) = split(/\|/,$_); + my ($operator,$timestamp) = split("/",$signature); + my ($evt_annee4,$evt_mois,$evt_jour,$suds_jour,$suds_heure,$suds_minute,$suds_seconde,$suds_reseau) = split; + my $diriaspei; + my $suds_continu; + my $dirTrigger; + my $dirTriggerUrn; + my $seedlink; + my $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&date=".substr($date,0,4).substr($date,5,2).substr($date,8,2).substr($heure,0,2).substr($heure,3,2).substr($heure,6,2)."&id=$id_evt"; + my $begin = strftime('%Y,%m,%d,%H,%M,%S', + gmtime(timegm(substr($heure,6,2),substr($heure,3,2),substr($heure,0,2), + substr($date,8,2),substr($date,5,2)-1,substr($date,0,4)-1900)-10)); + my $duree_s = ($duree ne "" ? $duree*$duration_s{$unite}:0); + my $durmseed = ($duree_s + 20); + if (length($suds) > 10 && $suds =~ ".gwa") { + ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); + $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_GWA}."/".$evt_annee4.$evt_mois.$suds_jour; + $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".gwa"; + +#djl-was:$editURL = "frameMC2.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; + } elsif (length($suds) > 10 && $suds =~ ".mq0") { + ($evt_annee4, $evt_mois, $suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a4 a2 a2 x a2 a2 a2 a2 x a3",$suds); + $diriaspei = $WEBOBS{PATH_SOURCE_SISMO_MQ0}."/".$evt_annee4.$evt_mois.$suds_jour; + $suds_continu = $evt_annee4.$evt_mois.$suds_jour."_".$suds_heure.$suds_minute.$suds_seconde.".mar"; + +#djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; + } elsif (length($suds) > 10 && $suds =~ ".GUA" || $suds =~ ".GUX" || $suds =~ ".gl0") { + ($suds_jour, $suds_heure, $suds_minute, $suds_seconde, $suds_reseau) = unpack("a2 a2 a2 a2 x a3",$suds); + ($evt_annee4,$evt_mois,$evt_jour) = split(/-/,$date); + $diriaspei = $WEBOBS{"PATH_SOURCE_SISMO_$suds_reseau"}."/".$evt_annee4.$evt_mois.$suds_jour; + +#djl-was: $editURL = "frameMC.pl?f=/$diriaspei/$suds_continu&id_evt=$id_evt"; + } else { + ($evt_annee4, $evt_mois, $suds_jour) = unpack("a4 x a2 x a2",$date); + ($suds_heure,$suds_minute) = unpack("a2 x a2",$heure); + $editURL = "$WEBOBS{CGI_SEFRAN3}?mc=$mc3&s3=$suds&date=$evt_annee4$evt_mois$suds_jour$suds_heure$suds_minute&id=$id_evt"; + $seedlink = 1; + } + # JMS was # $dirTrigger = "$WEBOBS{SISMOCP_PATH_FTP}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; # $dirTriggerUrn = "$WEBOBS{SISMOCP_PATH_FTP_URN}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; @@ -1199,7 +1238,7 @@ sub compute_energy { # my $suds_racine; # my $suds_ext; # my $suds2_pointe; - #djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { +#djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { # if (length($suds)==12 && substr($suds,8,1) eq '.') { # # ne prend que les premiers caractères du nom de fichier # $suds_sans_seconde = substr($suds,0,7); @@ -1212,28 +1251,29 @@ sub compute_energy { # @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); # } - my @lat; - my @lon; - my @dep; - my @mag; - my @mth; - my @mdl; - my @typ; - my @mty; - my @cod; - my @msk; - my @dat; - my @pha; - my @qua; - my @mod; - my @sta; - my @bcube; - my @nomB3; - my $isNotManuel = 1; - my $gse = ""; - - my $ii; - if ($QryParm->{'hideloc'} == 0) { + my @lat; + my @lon; + my @dep; + my @mag; + my @mth; + my @mdl; + my @typ; + my @mty; + my @cod; + my @msk; + my @dat; + my @pha; + my @qua; + my @mod; + my @sta; + my @bcube; + my @nomB3; + my $isNotManuel = 1; + my $gse = ""; + + my $ii; + if ($QryParm->{'hideloc'} == 0) { + # JMS was # if ($HYPO_USE_FMT0_PATH) { # $ii = 0; @@ -1261,7 +1301,7 @@ sub compute_energy { # .substr($_,0,8)."T".sprintf("%02.0f",substr($_,9,2)).sprintf("%02.0f",substr($_,11,2)) # .sprintf("%02.0f",substr($_,14,5))."_b3"; # } - # calcul de la distance epicentrale minimum (et azimut epicentre/villes) +# calcul de la distance epicentrale minimum (et azimut epicentre/villes) # for (0..$#b3_lat) { # my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); # my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; @@ -1273,353 +1313,371 @@ sub compute_energy { # } # } - # si le séisme a été localisé, les infos sont dans le champ $origin - if ($origin) { - ($cod[0],$dat[0],$lat[0],$lon[0],$dep[0],$pha[0],$mod[0],$sta[0],$mag[0],$mty[0],$mth[0],$mdl[0],$typ[0]) = split(';',$origin); - if($mod[0] eq 'manual' && $type eq 'AUTO') { - $type = 'UNKNOWN'; - } - - for ($ii = 0; $ii <= $#dat; $ii++) { - # calcul de la distance epicentrale minimum (et azimut epicentre/villes) - for (0..$#b3_lat) { - my ($dist,$bear) = greatcircle($b3_lat[$_],$b3_lon[$_],$lat[$ii],$lon[$ii]); - #my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); - #my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; - #$b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",sqrt($dx**2 + $dy**2),atan2($dy,$dx),$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); - $b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",$dist,$bear,$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); - } - my @xx = sort { $a cmp $b } @b3_dat; - $bcube[$ii] = $xx[0]; - if ($MC3{TREMBLEMAPS_PROC}) { - $nomB3[$ii] = substr($dat[$ii],0,4)."/".substr($dat[$ii],5,2)."/".substr($dat[$ii],8,2)."/$cod[$ii]"; - } - # cas d'une loc au format hyp71sum2k - if ($HYPO_USE_FMT0_PATH && (substr($typ[$ii],2,1) =~ /[2-9]{1}/)) { - $msk[$ii] = romanx(substr($typ[$ii],2,1)); - } - } - } - } - - ($duree_sat eq 0) and $duree_sat = " "; - ($s_moins_p eq 0) and $s_moins_p = " "; - - my $code = $station; - # extraction du code station (depuis NET.STA.LOC.CHA) - if ($station =~ /\./) { - my @stream = split(/\./,$station); - #$code = substr($stream[1],0,3); - $code = $stream[1]; - } - - # mise en evidence du filtre et pop-up - my $typeAff = ($types{$type}{Name} ? $types{$type}{Name}:""); - my $imageCAPTION = "$date $heure UT"; - my $imagePOPUP = "$typeAff $duree s $code - $comment [$operator]"; - if ($QryParm->{'obs'} ne "") { - #if (grep(/$QryParm->{'obs'}/i,$type)) { - # $typeAff =~ s/($QryParm->{'obs'})/$1<\/span>/ig; - #} - if (grep(/$QryParm->{'obs'}/i,$station)) { - $station =~ s/($QryParm->{'obs'})/$1<\/span>/ig; - } - if (grep(/$QryParm->{'obs'}/i,$comment)) { - $comment =~ s/($QryParm->{'obs'})/$1<\/span>/ig; - } - } - my $tc = $type; - if ($operator eq $MC3{SC3_USER}) { $tc = "AUTO"; } - - $html .= ""; - - # --- edit button - $html .= ""; - my $tmp = "$evt_annee4$evt_mois"; - - # --- computes distance and duration magnitude - my $md; - my $dist = -1; - if ($types{$type}{Md} == 0) { - $dist = 0; - } - if ($s_moins_p && !($s_moins_p ~~ ["","NA"," "]) && $types{$type}{Md} != -1) { - $dist = 8*$s_moins_p; - } - if ($duree_s > 0 && $dist >= 0) { - $md = sprintf("%.1f",2*log($duree_s)/log(10)+0.0035*$dist-0.87); - $html .= ""; - } else { - $html .= ""; - } - - # --- first arrival station - if ($arrivee eq "0") { - $html .= ""; - } else { - $html .= ""; - } - - # --- date and hour - $html .= "" - .""; - - # --- number of event - $html .= ""; - - # --- type of event - $html .= "$typeAff"; - my $amplitude_texte = ($amplitude ? (($amplitude eq "Sature" || $amplitude eq "OVERSCALE") ? "$namAmp{$amplitude} ($duree_sat s)" : "$namAmp{$amplitude}"):""); - my $amplitude_img = "/icons/signal_amplitude_".lc($amplitude).".png"; - if (! -e "$WEBOBS{ROOT_CODE}/$amplitude_img" ) { - $amplitude_img = "/icons/signal_amplitude_.png"; - } - $html .= ""; - - # --- duree - $html .= ""; - - # --- S-P - $html .= ""; - - # --- link to the waveform signal - $html .= ""; - - #print ""; - - # --- link to Sefran screenshot - $html .= ""; - - # --- comment - $html .= ""; - - # S'il y a au moins une localisation correspondante à l'événement: extraction des infos et calculs - $ii = 0; - for (@dat) { - # S'il y a une localisation validée, on n'affiche pas la localisation automatique - if ( ($isNotManuel && ($cod[$ii] eq "XXX ")) || $cod[$ii] ne "XXX " ) { - # Si la localisation est automatique, surlignage - # S'il y en a plus d'une, elles sont mises sur des lignes en-dessous, qui ne répetent pas les dates/heures - if ($ii > 0) { - $html .= "\n"; - $html .= "" - .""; - } else { - $html .= "  not locatable"; - } - - # --- Event energy calculation in joules (displayed in the popover for the magnitude column) - my $popover_attrs = ""; - if ($mag[$ii]) { - my $mag_disp = sprintf("%.2f %s", $mag[$ii], $mty[$ii]); - my $energy_disp = sprintf("%.3e", compute_energy($mag[$ii])); - my $popover_text = qq(Magnitude: $mag_disp
        ); - $popover_text .= qq(Energy: $energy_disp J
        ); - $popover_attrs = qq(onMouseOut="nd()" onMouseOver="overlib('$popover_text', CAPTION, 'Mag / Energy', WIDTH, 140)"); - } - - # --- Magnitude - $html .= qq("; - - # --- EMS - #if ($MC3{SISMOHYP_HYPO_USE} > 0) { - $html .= ""; - #} - - # Lien vers le B-Cube - if ($nomB3[$ii]) { - $html .= ""; - } - $ii++; - } - $html .= ($ii == 0 ? "\n"; - $nbLignesRetenues++; - } + # si le séisme a été localisé, les infos sont dans le champ $origin + if ($origin) { + ($cod[0],$dat[0],$lat[0],$lon[0],$dep[0],$pha[0],$mod[0],$sta[0],$mag[0],$mty[0],$mth[0],$mdl[0],$typ[0]) = split(';',$origin); + if($mod[0] eq 'manual' && $type eq 'AUTO') { + $type = 'UNKNOWN'; + } + + for ($ii = 0; $ii <= $#dat; $ii++) { + + # calcul de la distance epicentrale minimum (et azimut epicentre/villes) + for (0..$#b3_lat) { + my ($dist,$bear) = greatcircle($b3_lat[$_],$b3_lon[$_],$lat[$ii],$lon[$ii]); + +#my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); +#my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; +#$b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",sqrt($dx**2 + $dy**2),atan2($dy,$dx),$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); + $b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",$dist,$bear,$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); + } + my @xx = sort { $a cmp $b } @b3_dat; + $bcube[$ii] = $xx[0]; + if ($MC3{TREMBLEMAPS_PROC}) { + $nomB3[$ii] = substr($dat[$ii],0,4)."/".substr($dat[$ii],5,2)."/".substr($dat[$ii],8,2)."/$cod[$ii]"; + } + + # cas d'une loc au format hyp71sum2k + if ($HYPO_USE_FMT0_PATH && (substr($typ[$ii],2,1) =~ /[2-9]{1}/)) { + $msk[$ii] = romanx(substr($typ[$ii],2,1)); + } + } + } + } + + ($duree_sat eq 0) and $duree_sat = " "; + ($s_moins_p eq 0) and $s_moins_p = " "; + + my $code = $station; + + # extraction du code station (depuis NET.STA.LOC.CHA) + if ($station =~ /\./) { + my @stream = split(/\./,$station); + + #$code = substr($stream[1],0,3); + $code = $stream[1]; + } + + # mise en evidence du filtre et pop-up + my $typeAff = ($types{$type}{Name} ? $types{$type}{Name}:""); + my $imageCAPTION = "$date $heure UT"; + my $imagePOPUP = "$typeAff $duree s $code - $comment [$operator]"; + if ($QryParm->{'obs'} ne "") { + + #if (grep(/$QryParm->{'obs'}/i,$type)) { + # $typeAff =~ s/($QryParm->{'obs'})/$1<\/span>/ig; + #} + if (grep(/$QryParm->{'obs'}/i,$station)) { + $station =~ s/($QryParm->{'obs'})/$1<\/span>/ig; + } + if (grep(/$QryParm->{'obs'}/i,$comment)) { + $comment =~ s/($QryParm->{'obs'})/$1<\/span>/ig; + } + } + my $tc = $type; + if ($operator eq $MC3{SC3_USER}) { $tc = "AUTO"; } + + $html .= ""; + + # --- edit button + $html .= ""; + my $tmp = "$evt_annee4$evt_mois"; + + # --- computes distance and duration magnitude + my $md; + my $dist = -1; + if ($types{$type}{Md} == 0) { + $dist = 0; + } + if ($s_moins_p && !($s_moins_p ~~ ["","NA"," "]) && $types{$type}{Md} != -1) { + $dist = 8*$s_moins_p; + } + if ($duree_s > 0 && $dist >= 0) { + $md = sprintf("%.1f",2*log($duree_s)/log(10)+0.0035*$dist-0.87); + $html .= ""; + } else { + $html .= ""; + } + + # --- first arrival station + if ($arrivee eq "0") { + $html .= ""; + } else { + $html .= ""; + } + + # --- date and hour + $html .= "" + .""; + + # --- number of event + $html .= ""; + + # --- type of event + $html .= "$typeAff"; + my $amplitude_texte = ($amplitude ? (($amplitude eq "Sature" || $amplitude eq "OVERSCALE") ? "$namAmp{$amplitude} ($duree_sat s)" : "$namAmp{$amplitude}"):""); + my $amplitude_img = "/icons/signal_amplitude_".lc($amplitude).".png"; + if (! -e "$WEBOBS{ROOT_CODE}/$amplitude_img" ) { + $amplitude_img = "/icons/signal_amplitude_.png"; + } + $html .= ""; + + # --- duree + $html .= ""; + + # --- S-P + $html .= ""; + + # --- link to the waveform signal + $html .= ""; + + #print ""; + + # --- link to Sefran screenshot + $html .= ""; + + # --- comment + $html .= ""; + +# S'il y a au moins une localisation correspondante à l'événement: extraction des infos et calculs + $ii = 0; + for (@dat) { + +# S'il y a une localisation validée, on n'affiche pas la localisation automatique + if ( ($isNotManuel && ($cod[$ii] eq "XXX ")) || $cod[$ii] ne "XXX " ) { + +# Si la localisation est automatique, surlignage +# S'il y en a plus d'une, elles sont mises sur des lignes en-dessous, qui ne répetent pas les dates/heures + if ($ii > 0) { + $html .= "\n"; + $html .= "" + .""; + } else { + $html .= "  not locatable"; + } + +# --- Event energy calculation in joules (displayed in the popover for the magnitude column) + my $popover_attrs = ""; + if ($mag[$ii]) { + my $mag_disp = sprintf("%.2f %s", $mag[$ii], $mty[$ii]); + my $energy_disp = sprintf("%.3e", compute_energy($mag[$ii])); + my $popover_text = qq(Magnitude: $mag_disp
        ); + $popover_text .= qq(Energy: $energy_disp J
        ); + $popover_attrs = qq(onMouseOut="nd()" onMouseOver="overlib('$popover_text', CAPTION, 'Mag / Energy', WIDTH, 140)"); + } + + # --- Magnitude + $html .= qq("; + + # --- EMS + #if ($MC3{SISMOHYP_HYPO_USE} > 0) { + $html .= ""; + + #} + + # Lien vers le B-Cube + if ($nomB3[$ii]) { + $html .= ""; + } + $ii++; + } + $html .= ($ii == 0 ? "\n"; + $nbLignesRetenues++; + } } $html .= "
        $titres[$i]$titres[$i]
        "; - if ($editURL ne "") { - my $msg = "View..."; - my $ico = "view.png"; - if ( (($operator eq "" || $operator eq $CLIENT || $type eq "AUTO") - && (clientHasEdit(type=>"authprocs",name=>"MC") ||clientHasEdit(type=>"authprocs",name=>"$mc3"))) || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) { - $msg = "Edit..."; - $ico = "modif.png"; - } - $html .= qq() - .qq(); - } else { $html .= " " } - $html .= "$md".sprintf("%.0f",$dist)."  $code$code $date  $heure  ".($nombre gt 1 ? "$nombre" : $nombre)." ×$amplitude_texte".($duree ? sprintf("%1.1f %s",$duree,$unite):"")."".($s_moins_p eq "NA" ? " " : "$s_moins_p").""; - #djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { - #if (length($suds)==12 && substr($suds,8,1) eq '.') { - # for(@suds_liste) { - # $html .= ""; - # } - #} elsif (-f "$dirTrigger/$suds2_pointe") { - # for my $lettre ("a".."z") { - # $suds2_pointe = "${suds_racine}_${lettre}.${suds_ext}"; - # if (-f "$dirTrigger/$suds2_pointe") { - # $html .= ""; - # } - # } - #} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { - # $html .= ""; - #} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { - # $html .= ""; - #} elsif (-f "$WEBOBS{RACINE_SIGNAUX_SISMO}/$diriaspei/$suds") { - # $html .= ""; - #} elsif ($suds eq $nosuds) { - # $html .= ""; - #} elsif ($seedlink) { - # [FXB] AJOUTER &all=1 lorsque le serveur ArcLink acceptera les wildcards... - $html .= ""; - #} else { - # $html .= "($suds)"; - #} - $html .= "$sc3id"; - #FB-was: my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois/$MC3{FILE_PREFIX}$event_img"; - my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois"; - my $event_img_path = "$MC3{ROOT}/$event_img_subdir/$event_img"; - - # Split the MC3 column value on commas in case multiple images were to be displayed - my @img_list = map { $_ =~ s/^\s+|\s+$//g; $_; } split(/,/, "$event_img"); - - if (@img_list) { - # Define the icon visible in the MC3 'Sefran' column - # (wolbtarget designates the gallery of images to display defined below) - $html .= ""; - - # Add all collected images to a unique common gallery (same wolbset) - for my $img (@img_list) { - $html .= ""; - } - } else { - # No image was designated in the MC3 entry - $html .= " "; - } - - # --- operator - $html .= "$operator$comment
        "; - } - # Distance et direction d'après B3 - my $noloc = 0; - $noloc = 1 if (grep(/^$typ[$ii]$/,@nolocation_types)); - my $sc3AutoStyle = ($mod[$ii] eq 'automatic' || $noloc == 1 ? "color:gray":""); - my @b3; - my $town; - my $pga; - my $pgamax; - my $dir; - my $dkm; - my $ems; - my $emsmax; - if ($bcube[$ii]) { - @b3 = split(/\|/,$bcube[$ii]); - $b3[2] =~ s/\'/\`/g; - $town = $b3[2]; - #DL-was: if ($b3[4] != $WEBOBS{SHAKEMAPS_COMMUNES_PLACE}) { - if ($b3[3] ne $MC3{CITIES_PLACE}) { - $town = $b3[3]; - } - $pga = attenuation(($mag[$ii] ? $mag[$ii]:0),sqrt($b3[0]**2 + ($dep[$ii] ne "" ? $dep[$ii]**2:0))); - #DL-was: my $pgamax = $pga*$WEBOBS{SHAKEMAPS_SITE_EFFECTS}; - #FB-was: $pgamax = $pga*$MC3{CITIES_SITE_EFFECTS}; - $pgamax = $pga*($b3[4] > 0 ? $b3[4]:3); - $dir = compass($b3[1]); - $dkm = sprintf("%5.1f",$b3[0]); - $dkm =~ s/\s/  /g; - $ems = pga2msk($pga); - $emsmax = pga2msk($pgamax); - } - my $M_A = "M":"red>A").""; - - # Info-bulle avec les détails de la localisation - $html .= "$M_A%1.2f
        ",$mty[$ii],$mag[$ii]):"") - .($lat[$ii] < 0 ? sprintf("%2.2f°S",-$lat[$ii]):sprintf("%2.2f°N",$lat[$ii])) - ."  " - .($lon[$ii] < 0 ? sprintf("%2.2f°W",-$lon[$ii]):sprintf("%2.2f°E",$lon[$ii])) - .($dep[$ii] ? "  ".sprintf("%1.1f km",$dep[$ii]):"")."
        " - .(@b3 ? "$dkm km $dir $town
        ":""); - } - $html .="$pha[$ii] phases".($qua[$ii] ? " ($qua[$ii])":"")." / $mod[$ii]".($sta[$ii] ne "" ? " ($sta[$ii])":"")."
        " - .($mth[$ii] ne "" || $mdl[$ii] ne "" ? "$mth[$ii] / $mdl[$ii]
        ":"") - .($typ[$ii] ne "" ? "$typ[$ii]
        ":"") - ."
        " - ."ID = $cod[$ii]',CAPTION,'$dat[$ii]')\">"; - if ($noloc == 0 && $pha[$ii] >= $MC3{LOCATION_MIN_PHASES} && @b3) { - $html .= "$dkm km \"$dir\" $town        		".($dep[$ii] ? sprintf("%2.1f",$dep[$ii]):"").") - .($mty[$ii] && $mag[$ii] ? sprintf("%1.2f  %s",$mag[$ii],$mty[$ii]):"")."".($msk[$ii] ? $msk[$ii]:"")."%s (%s)
        %s (max. %s)",$b3[2],$b3[3],$ems,$emsmax) - } - $html .= "',CAPTION,'Rapport B³',WIDTH,80)\">"; - if ($ext) { - ( my $link = readlink("$fileB3/b3$ext") ) =~ s/.pdf//g; - $html .= ""; - # Print a link to remove the B3 file, only if no filter is in use and only for the last 10 lines - #if ($end_datetime->truncate(to => 'day') == $today - if ($nbLignesRetenues <= 10 - and ( (($operator eq "" || $operator eq $CLIENT) - && (clientHasEdit(type=>"authprocs",name=>"MC") || clientHasEdit(type=>"authprocs",name=>"$mc3"))) - || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) ) { - $html .= qq{  x}; - } - } elsif ($emsmax ne 'I') { - $html .= "$ems ($emsmax)"; - } - } else { - $html .= "        		"; - } - $html .= "
        ":"")."
        "; + if ($editURL ne "") { + my $msg = "View..."; + my $ico = "view.png"; + if ( (($operator eq "" || $operator eq $CLIENT || $type eq "AUTO") + && (clientHasEdit(type=>"authprocs",name=>"MC") ||clientHasEdit(type=>"authprocs",name=>"$mc3"))) || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) { + $msg = "Edit..."; + $ico = "modif.png"; + } + $html .= qq() + .qq(); + } else { $html .= " " } + $html .= "$md".sprintf("%.0f",$dist)."  $code$code $date  $heure  ".($nombre gt 1 ? "$nombre" : $nombre)." ×$amplitude_texte".($duree ? sprintf("%1.1f %s",$duree,$unite):"")."".($s_moins_p eq "NA" ? " " : "$s_moins_p").""; + +#djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { +#if (length($suds)==12 && substr($suds,8,1) eq '.') { +# for(@suds_liste) { +# $html .= ""; +# } +#} elsif (-f "$dirTrigger/$suds2_pointe") { +# for my $lettre ("a".."z") { +# $suds2_pointe = "${suds_racine}_${lettre}.${suds_ext}"; +# if (-f "$dirTrigger/$suds2_pointe") { +# $html .= ""; +# } +# } +#} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { +# $html .= ""; +#} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { +# $html .= ""; +#} elsif (-f "$WEBOBS{RACINE_SIGNAUX_SISMO}/$diriaspei/$suds") { +# $html .= ""; +#} elsif ($suds eq $nosuds) { +# $html .= ""; +#} elsif ($seedlink) { +# [FXB] AJOUTER &all=1 lorsque le serveur ArcLink acceptera les wildcards... + $html .= ""; + + #} else { + # $html .= "($suds)"; + #} + $html .= "$sc3id"; + +#FB-was: my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois/$MC3{FILE_PREFIX}$event_img"; + my $event_img_subdir = "$evt_annee4/$MC3{PATH_IMAGES}/$evt_annee4$evt_mois"; + my $event_img_path = "$MC3{ROOT}/$event_img_subdir/$event_img"; + +# Split the MC3 column value on commas in case multiple images were to be displayed + my @img_list = map { $_ =~ s/^\s+|\s+$//g; $_; } split(/,/, "$event_img"); + + if (@img_list) { + + # Define the icon visible in the MC3 'Sefran' column + # (wolbtarget designates the gallery of images to display defined below) + $html .= ""; + + # Add all collected images to a unique common gallery (same wolbset) + for my $img (@img_list) { + $html .= ""; + } + } else { + + # No image was designated in the MC3 entry + $html .= " "; + } + + # --- operator + $html .= "$operator$comment
        "; + } + + # Distance et direction d'après B3 + my $noloc = 0; + $noloc = 1 if (grep(/^$typ[$ii]$/,@nolocation_types)); + my $sc3AutoStyle = ($mod[$ii] eq 'automatic' || $noloc == 1 ? "color:gray":""); + my @b3; + my $town; + my $pga; + my $pgamax; + my $dir; + my $dkm; + my $ems; + my $emsmax; + if ($bcube[$ii]) { + @b3 = split(/\|/,$bcube[$ii]); + $b3[2] =~ s/\'/\`/g; + $town = $b3[2]; + + #DL-was: if ($b3[4] != $WEBOBS{SHAKEMAPS_COMMUNES_PLACE}) { + if ($b3[3] ne $MC3{CITIES_PLACE}) { + $town = $b3[3]; + } + $pga = attenuation(($mag[$ii] ? $mag[$ii]:0),sqrt($b3[0]**2 + ($dep[$ii] ne "" ? $dep[$ii]**2:0))); + + #DL-was: my $pgamax = $pga*$WEBOBS{SHAKEMAPS_SITE_EFFECTS}; + #FB-was: $pgamax = $pga*$MC3{CITIES_SITE_EFFECTS}; + $pgamax = $pga*($b3[4] > 0 ? $b3[4]:3); + $dir = compass($b3[1]); + $dkm = sprintf("%5.1f",$b3[0]); + $dkm =~ s/\s/  /g; + $ems = pga2msk($pga); + $emsmax = pga2msk($pgamax); + } + my $M_A = "M":"red>A").""; + + # Info-bulle avec les détails de la localisation + $html .= "$M_A%1.2f
        ",$mty[$ii],$mag[$ii]):"") + .($lat[$ii] < 0 ? sprintf("%2.2f°S",-$lat[$ii]):sprintf("%2.2f°N",$lat[$ii])) + ."  " + .($lon[$ii] < 0 ? sprintf("%2.2f°W",-$lon[$ii]):sprintf("%2.2f°E",$lon[$ii])) + .($dep[$ii] ? "  ".sprintf("%1.1f km",$dep[$ii]):"")."
        " + .(@b3 ? "$dkm km $dir $town
        ":""); + } + $html .="$pha[$ii] phases".($qua[$ii] ? " ($qua[$ii])":"")." / $mod[$ii]".($sta[$ii] ne "" ? " ($sta[$ii])":"")."
        " + .($mth[$ii] ne "" || $mdl[$ii] ne "" ? "$mth[$ii] / $mdl[$ii]
        ":"") + .($typ[$ii] ne "" ? "$typ[$ii]
        ":"") + ."
        " + ."ID = $cod[$ii]',CAPTION,'$dat[$ii]')\">"; + if ($noloc == 0 && $pha[$ii] >= $MC3{LOCATION_MIN_PHASES} && @b3) { + $html .= "$dkm km \"$dir\" $town        		".($dep[$ii] ? sprintf("%2.1f",$dep[$ii]):"").") + .($mty[$ii] && $mag[$ii] ? sprintf("%1.2f  %s",$mag[$ii],$mty[$ii]):"")."".($msk[$ii] ? $msk[$ii]:"")."%s (%s)
        %s (max. %s)",$b3[2],$b3[3],$ems,$emsmax) + } + $html .= "',CAPTION,'Rapport B³',WIDTH,80)\">"; + if ($ext) { + ( my $link = readlink("$fileB3/b3$ext") ) =~ s/.pdf//g; + $html .= ""; + +# Print a link to remove the B3 file, only if no filter is in use and only for the last 10 lines +#if ($end_datetime->truncate(to => 'day') == $today + if ($nbLignesRetenues <= 10 + and ( (($operator eq "" || $operator eq $CLIENT) + && (clientHasEdit(type=>"authprocs",name=>"MC") || clientHasEdit(type=>"authprocs",name=>"$mc3"))) + || (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) ) ) { + $html .= qq{  x}; + } + } elsif ($emsmax ne 'I') { + $html .= "$ems ($emsmax)"; + } + } else { + $html .= "        		"; + } + $html .= "
        ":"")."
        \n"; if ($QryParm->{'debug'}) { - $html .= "
        "; - $html .= "Number of lines kept / read: $nbLignesRetenues / $nb
        "; - $html .= "Dates interval: [".$start_datetime->strftime("%F %Hh").",".$end_datetime->strftime("%F %Hh")."]
        "; - $html .= "Type criteria: $QryParm->{'type'}
        "; - $html .= "Durations greater than: $QryParm->{'duree'} s
        "; - $html .= "User: $CLIENT
        "; - $html .= join('
        ',@listeCommunes); + $html .= "
        "; + $html .= "Number of lines kept / read: $nbLignesRetenues / $nb
        "; + $html .= "Dates interval: [".$start_datetime->strftime("%F %Hh").",".$end_datetime->strftime("%F %Hh")."]
        "; + $html .= "Type criteria: $QryParm->{'type'}
        "; + $html .= "Durations greater than: $QryParm->{'duree'} s
        "; + $html .= "User: $CLIENT
        "; + $html .= join('
        ',@listeCommunes); } # ---- Notes/legends area ----------------------------------------------------- # $html .= "
        "; - # legend : build types table ---------------------------------------------- - $html .= "

        Event Types

        " - ."\n"; - for (sort(keys(%typesSO))) { - my $key = $typesSO{$_}; - if ($key ne 'ALL' && $key ne 'TOTAL') { - $html .= "" - ."\n"; - } - } - # note : read from file --------------------------------------------------- - $html .= "
        CodeType
        $key$types{$key}{Name}
        \n" - ."
        ".WebObs::Wiki::wiki2html(join('',@infoTexte))."
        "; +# legend : build types table ---------------------------------------------- +$html .= "

        Event Types

        " + ."\n"; +for (sort(keys(%typesSO))) { + my $key = $typesSO{$_}; + if ($key ne 'ALL' && $key ne 'TOTAL') { + $html .= "" + ."\n"; + } +} +# note : read from file --------------------------------------------------- +$html .= "
        CodeType
        $key$types{$key}{Name}
        \n" + ."
        ".WebObs::Wiki::wiki2html(join('',@infoTexte))."
        "; # ---- now wrap $html into page html+javascript ------------------------------- # if ($QryParm->{'dump'} eq "") { - print $cgi->header(-charset=>'utf-8'); - print <<"ENDTOPOFPAGE"; + print $cgi->header(-charset=>'utf-8'); + print <<"ENDTOPOFPAGE"; @@ -1688,9 +1746,9 @@ sub compute_energy { ENDTOPOFPAGE - print $html; + print $html; - print <<"ENDBOTOFPAGE"; + print <<"ENDBOTOFPAGE"; -"; +"; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print "\n"; print "\n"; - # ---- List of available days in the 'runs' database table # -------------------------------------------------------- my @run_day_list = map { $_->[0] } (@{fetch_all($SCHED{SQL_DB_JOBS}, - "SELECT DISTINCT(DATE(CAST(startts AS INTEGER), 'unixepoch', 'localtime'))" - ." FROM runs ORDER BY 1 DESC")}); - + "SELECT DISTINCT(DATE(CAST(startts AS INTEGER), 'unixepoch', 'localtime'))" + ." FROM runs ORDER BY 1 DESC")}); # ---- Prepare the HTML table of job runs for selected day # -------------------------------------------------------- @@ -311,62 +322,63 @@ sub fetch_all { my @jid_list; my $query_runs = "SELECT jid, kid, org, DATETIME(CAST(startts AS INTEGER), 'unixepoch', 'localtime')," - . " CASE WHEN endts != 0 THEN DATETIME(CAST(endts AS INTEGER), 'unixepoch', 'localtime') ELSE NULL END," - . " cmd, stdpath, rc, rcmsg, endts - startts AS elps FROM runs" - . " WHERE startts >= $rdate AND startts <= $rdate+86400" - . " ORDER BY startts, jid"; + . " CASE WHEN endts != 0 THEN DATETIME(CAST(endts AS INTEGER), 'unixepoch', 'localtime') ELSE NULL END," + . " cmd, stdpath, rc, rcmsg, endts - startts AS elps FROM runs" + . " WHERE startts >= $rdate AND startts <= $rdate+86400" + . " ORDER BY startts, jid"; my $run_list = fetch_all($SCHED{SQL_DB_JOBS}, $query_runs); # Prepare the rows of the job run table for my $run (@$run_list) { - my ($job_jid, $job_kid, $org, $job_start, $job_end, - $job_cmd, $job_stdpath, $job_rc, $job_rcmsg, $elapsed) = @$run; - - push(@jid_list, $job_jid) unless grep{$_ eq $job_jid} @jid_list; - - if ($QryParm->{'jid'} eq "" || $QryParm->{'jid'} eq $job_jid) { - - my $elapsed_column = ''; - my $bgcolor = "transparent"; - # Running jobs have an undefined end date - my $is_running = not defined($job_end); - $jobsdefsCount++; - $jobsdefsId="jdef".$jobsdefsCount; - - if ($is_running) { - $job_rc = ''; - $job_rcmsg = ''; - $job_end = 'Running'; - } else { - my ($seconds, $ms) = split(/\./, ($elapsed)); - my @time = reverse($seconds%60, ($seconds/=60) % 60, ($seconds/=60) % 24, ($seconds/=24) ); - $elapsed_column = sprintf "%03d:%02d:%02d:%02d.%3.3s", @time, $ms; - # Return code shows success: use a green background in the RC column - $bgcolor = ($job_rc == 0 ? "green":"red"); - } - - if (length($job_cmd) > $maxdcmdl) { - my $s = ($maxdcmdl-5)/2; - $job_cmd = substr($job_cmd,0,$s).'(...)'.substr($job_cmd,-$s); - } - $job_start =~ s/^.* //; - $job_end =~ s/^.* //; - $jobsruns .= qq(
        ); - if ($is_running && $admOK) { - $jobsruns .= qq(); - } - $jobsruns .= qq(); - if (!$is_running && $admOK && $job_jid =~ /^\w/) { - $jobsruns .= qq(); - } - $jobsruns .= qq($job_jid$job_kid$org$job_start$job_end$job_cmd); - my $log_filename = $job_stdpath =~ s/^[><] +//r; - $jobsruns .= qq($log_filename); - $jobsruns .= qq($job_rc$job_rcmsg$elapsed_column
        ); + if ($is_running && $admOK) { + $jobsruns .= qq(); + } + $jobsruns .= qq(); + if (!$is_running && $admOK && $job_jid =~ /^\w/) { + $jobsruns .= qq(); + } + $jobsruns .= qq($job_jid$job_kid$org$job_start$job_end$job_cmd); + my $log_filename = $job_stdpath =~ s/^[><] +//r; + $jobsruns .= qq($log_filename); + $jobsruns .= qq($job_rc$job_rcmsg$elapsed_column
        "; - if ($header) { - print ""; - if (!$ref || $SEFRAN3{REF_NORTC} == 0) { - print ""; - } - print ""; - } - # form to display/select dates span (interval) and realtime vs start-date (reference) - print ""; - print "

        $titrePage".($userLevel == 4 ? " ":"")."

        ", - "

        »» [ ", - "", - " | "; - print "", - " | " if ($sgramOK); - print "$__{'Information'}", - " | $MC3{TITLE}", - " ]

        $Ya-$ma-$da
        $Ha:$Ma UTC

        ", - "ΔT ".($dt < 120 ? "= $dt s" : "< ".($dt < 7200 ? int($dt/60 +1)." mn" : int($dt/3600)." hr"))."
        "; - print "
        "; - # hidden values to pass all parameters in the form - print ""; - print "$__{'Interval'}: "; - print "  $__{'Reference'}: \n"; - print ""; - print " "; - print ""; - print " ".$__{'Header'}; - print " ".$__{'Status'}; - print " ".$__{'Event Loc'}; - print " ".$__{'Trash'}; - print "
        "; - print "
        "; - if ($sgramOK) { - print "", - ""; - } - - print ""; - my $nb_heures = 0; - my $nb_vign = 0; - for (@dates) { - my $dd = $_; - my $da = substr($_,0,4); - my $dm = substr($_,5,2); - my $dj = substr($_,8,2); - my $ddd = "$da$dm$dj"; - my $dt = l2u(strftime('%A %-d %B %Y UTC',gmtime(timegm(0,0,0,$dj,$dm-1,$da-1900)))); - my $nb_heures_jour=0; - for (@listeHeures) { - my $hh = $_; - if (($today ne $dd)||($Ha ge $hh)) { - if (($limit != 0 && ++$nb_heures <= $limit) || ($limit == 0 && ($nb_heures++ <= $limit_lastmc))) { - $nb_heures_jour++; - $nb_vign++; - my $f = "$da/$ddd/$SEFRAN3{PATH_IMAGES_HOUR}/$ddd$hh"; - my $imgopt = "border=\"1\" onClick=\"window.open('$prog&date=$ddd$hh&trash=$trash')\""; - print ""; - if (-e "$SEFRAN3{ROOT}/$f.jpg") { - my $sgramimg = ""; - my $sgramalign = ""; - if ($sgramOK) { - my $fs = "$SEFRAN3{ROOT}/${f}s.jpg"; - if (-e $fs) { - if ($nb_vign > 1) { - my ($w, $h) = dim(image_info($fs)); - $sgramalign = ";left:".($SEFRAN3{HOURLY_WIDTH}-$w)."px !important"; - } - $sgramimg = ""; - } - } - print "\n"; - } - } - } - if ($nb_heures_jour > 0) { - print "\n"; - } - - } - - print "
         $da-$dm-$dj 
         $hhh UTC 
        "; - print "$sgramimg"; - } else { - print "
        no image"; - } - - # plots MC events over sefran - for (reverse @mclist) { - my %MC = mcinfo($_,$evtloc); - if (($MC{id} > 0 || ($userLevel >= 2 && $trash == 1)) && $userLevel >= 1) { - # event start and end expressed in days - my $d0 = $MC{year}*10000 + $MC{month}*100 + $MC{day} + $MC{hour}/24 + $MC{minute}/1440 + $MC{second}/86400; - my $d1 = $d0 + $MC{duration}*$duration_s{$MC{unit}}/86400; - if ($d0 < $ddd + ($hh+1)/24 && $d1 >= $ddd + $hh/24) { - # event start and duration expressed in hour - my $h0 = $MC{minute}/60 + $MC{second}/3600; - my $dh = $MC{duration}*$duration_s{$MC{unit}}/3600; - # event start and duration expressed in pixels - my $deb_evt = 2 + int($SEFRAN3{HOURLY_WIDTH}*$h0); - my $dur_evt = 1 + int(0.5 + $SEFRAN3{HOURLY_WIDTH}*$dh); - # case A: event starts in the current hour - if ($MC{hour} eq $hh) { - # case A1: event duration exceeds current hour - if ($deb_evt + $dur_evt > $SEFRAN3{HOURLY_WIDTH}) { - $dur_evt = $SEFRAN3{HOURLY_WIDTH} - $deb_evt + 2; - } - # case B: event has started in a previous hour - } else { - $deb_evt = 2; - my $hdeb = $MC{hour}; - $hdeb -= 24 if ($hdeb > $hh); # solves event crossover a day - # case B1: more than 3 hours overlap = full width - if ($h0 + $dh > $hh - $hdeb + 1) { - $dur_evt = $SEFRAN3{HOURLY_WIDTH}; - } else { - $dur_evt = $SEFRAN3{HOURLY_WIDTH}*($h0 + $dh - ($hh-$hdeb)) + 1; - } - } - print "
        ", - "
        \n"; - } - } - } - print "
        ⇑  $dt  ⇑

        "; - - # table information about channel streams - print "

        Informations

        \n"; - if ($status) { - my $now_seconds = timegm(gmtime); - my $Q = qx($WEBOBS{PRGM_ALARM} $SEFRAN3{SEEDLINK_SERVER_TIMEOUT_SECONDS} $WEBOBS{SLINKTOOL_PRGM} -Q $SEFRAN3{SEEDLINK_SERVER}); - my @stream_server = split(/\n/,$Q); - - # read statistics - my @stat_streams = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:streams]" $last_mn/); - my @stat_offset = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:offset]" $last_mn/); - my @stat_median = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:median]" $last_mn/); - my @stat_rate = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:rate]" $last_mn/); - my @stat_sampling = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:sampling]" $last_mn/); - my @stat_drms = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:drms]" $last_mn/); - my @stat_asymetry = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:asymetry]" $last_mn/); - my @stat_fdom; - - if ($sgramOK) { - (my $last_sg = $last_mn) =~ s/$SEFRAN3{PATH_IMAGES_MINUTE}/$SEFRAN3{PATH_IMAGES_SGRAM}/; - $last_sg =~ s/\.png/s.png/; - @stat_fdom = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:freqdom]" $last_sg/); - } - - print "", - "", - "", - "", - "", - ($sgramOK ? "":""), - "\n"; - for (@channels) { - $i++; - my ($alias,$codes,$calib,$offset,$pp,$color) = split(/\s+/,$_); - $color =~ s/"//; - my ($net,$sta,$loc,$cha) = split(/\./,$codes); - my @chan = grep(/$net *$sta *$loc *$cha/,@stream_server); - my $idx = first { $stat_streams[$_] eq $codes } 0..$#stat_streams; - - print "", - "", - ""; - - my $ch_nagios = 3; # Nagios 'UNKNOWN' value - if ($idx ge 0) { - my ($status_offset,$status_noise) = (1,1); - if (abs($stat_offset[$idx]) < $SEFRAN3{STATUS_OFFSET_WARNING}) { $status_offset = 0; } - elsif (abs($stat_offset[$idx]) > $SEFRAN3{STATUS_OFFSET_CRITICAL}) { $status_offset = 2; } - if ($stat_drms[$idx] != 0 && ($stat_drms[$idx]/$calib) < $SEFRAN3{STATUS_NOISE_WARNING}) { $status_noise = 0; } - elsif ($stat_drms[$idx] == 0 || ($stat_drms[$idx]/$calib) > $SEFRAN3{STATUS_NOISE_CRITICAL}) { $status_noise = 2; } - printf("",1e6*$stat_median[$idx]/$calib); - printf("",100*$stat_offset[$idx]); - printf("",100*$stat_asymetry[$idx]); - printf("",1e6*$stat_drms[$idx]/$calib); - printf("",100*$stat_sampling[$idx]); - printf("",$stat_rate[$idx]); - printf("",$stat_fdom[$idx]) if ($sgramOK); - if ($status_offset == 0 && $status_noise == 0) { - $ch_nagios = 0; # Nagios 'OK' value - } elsif ($status_offset == 2 || $status_noise == 2) { - $ch_nagios = 2; # Nagios 'CRITICAL' value - } else { - $ch_nagios = 1; # Nagios 'WARNING' value - } - } else { - print ""; - } - - if (@chan) { - my ($start,$end) = split(/ - /,substr($chan[0],18)); - my $start_s = timegm(substr($start,17,2),substr($start,14,2),substr($start,11,2),substr($start,8,2),substr($start,5,2)-1,substr($start,0,4)-1900); - my $end_s = timegm(substr($end,17,2),substr($end,14,2),substr($end,11,2),substr($end,8,2),substr($end,5,2)-1,substr($end,0,4)-1900); - my $bl = int(($end_s - $start_s)/60); # ringbuffer length (in minutes) - my $dt = ($now_seconds - $end_s); - my $status_delay = 0; - if ($dt > $SEFRAN3{STATUS_DELAY_CRITICAL}) { - $status_delay = 2; - $ch_nagios = 2; - } elsif ($ch_nagios < 2 && $dt > $SEFRAN3{STATUS_DELAY_WARNING}) { - $status_delay = 1; - $ch_nagios = 1; - } - print "", - ""; - print ""; - #if ($dt > $SEFRAN3{ARCLINK_DELAY_HOURS}) { - } else { - print ""; - } - switch ($ch_nagios) { - case 0 { print ""; } - case 1 { print ""; } - case 2 { print ""; } - case 3 { print ""; } - } - print "\n"; - } - print "
        #AliasChannelCalibration
        (count/(m/s))        		FilterPeak-Peak
        (m/s)        		Signal statistics on last image
        $lmn        		SeedLink server $SEFRAN3{SEEDLINK_SERVER}Status
        Offset
        (μm/s)        		Asym.RMSΔ
        (μm/s)        		Acq.
        (%)        		Samp.
        (Hz)        		Freq
        (Hz)        		Oldest dataLast dataBufferΔT
        $i.$alias$codes$calib$offset$pp%1.4f%2.0f%%2.0f%%1.4f%1.0f%g%1.2fnot available$start$end" - .($bl < 60 ? "$bl mn":($bl < 1440 ? int($bl/60 + 0.5)." h":int($bl/1440 + 0.5)." d"))."" - .($dt < 60 ? "$dt s":($dt < 3600 ? int($dt/60 + 0.5)." mn":($dt < 86400 ? int($dt/3600 + 0.5)." h":int($dt/86400 + 0.5)." d")))."not availableOKPBHS?

        \n"; - } - - print "

        Sefran3 configuration file: $s3

        \n"; - print "

        Channels parameters file: $SEFRAN3{CHANNEL_CONF}

        \n"; - print "

        Update window: $SEFRAN3{UPDATE_HOURS} h

        \n"; - print "

        Datasource: ".($SEFRAN3{DATASOURCE} ne "" ? "$SEFRAN3{DATASOURCE}":"Not configured.")."

        \n"; - print "

        Broom wagon: ".($SEFRAN3{BROOMWAGON_ACTIVE} ? ("Active (delay = $SEFRAN3{BROOMWAGON_DELAY_HOURS} h," - ."update window = $SEFRAN3{BROOMWAGON_UPDATE_HOURS} h, " - ."maximum dead channels = $SEFRAN3{BROOMWAGON_MAX_DEAD_CHANNELS}, " - ."maximum gap = ".sprintf("%g%%",$SEFRAN3{BROOMWAGON_MAX_GAP_FACTOR}*100).")"):"Not active")."

        \n"; - - print "", - "\n", - "", - "\n", - "", - "\n", - "
        Virtual speed
        (inches/minute)        		Resolution
        (pixels/second)        		1-minute image width
        (pixels)        		Density \@100Hz
        (samples/pixel)
        Normal view$SEFRAN3{VALUE_SPEED}".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}/60)."", - "".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}))."
        High-speed view$SEFRAN3{VALUE_SPEED_HIGH}".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}/60)."", - "".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}))."
        \n"; - print "

        MC events: ".@mclist."

        \n"; - print "

        Last MC: $last_mc ($limit_lastmc h)

        \n" if ($limit==0); - - my @notes = readFile("$SEFRAN3{NOTES}"); - print WebObs::Wiki::wiki2html(join("",@notes)); - - print ""; + my $last_mc; + my $dt_lastmc; + my $limit_lastmc = $SEFRAN3{TIME_INTERVALS_DEFAULT_VALUE}; + if ($limit == 0) { + +# gets the N=$SEFRAN3{DISPLAY_LAST_MC} last MC event: from the 2 last monthly files, extracts the Nth last event non 'AUTO' and returns 'yyyy-mm-dd|HH' + $last_mc = qx(find $MC3{ROOT} -name "$MC3{FILE_PREFIX}*.txt" | sort | tail -n2 | xargs sort -t '|' -k2,3 | tail -n$SEFRAN3{DISPLAY_LAST_MC} | head -n1 |sed -nE "s/^[0-9]+\\|([0-9]{4}-[0-9]{2}-[0-9]{2}\\|[0-9]{2}):.*/\\1/p" | xargs echo -n); + my $dtn = timegm(gmtime); + $dt_lastmc = timegm(0,0,substr($last_mc,11,2),substr($last_mc,8,2),substr($last_mc,5,2)-1,substr($last_mc,0,4)); + $limit_lastmc = int(($dtn - $dt_lastmc)/3600); + $limit_lastmc = $SEFRAN3{DISPLAY_DAYS}*24 if ($limit_lastmc/24 > $SEFRAN3{DISPLAY_DAYS}); + } + +# builds the list of dates and loads associated MC events over the period (+ 1 day) + my @dates; + my @mclist; + for (0 .. ($limit>0?$limit:$limit_lastmc)) { + my $ymdh = strftime('%Y-%m-%d|%H',gmtime(timegm(0,0,$href,$dref,$mref-1,$yref-1900) - $_*3600)); + my $ymd = substr($ymdh,0,10); + push(@dates,$ymd) if (!grep(/^$ymd$/,@dates) && $_ < 24*$SEFRAN3{DISPLAY_DAYS}); + my $f = "$MC3{ROOT}/".substr($ymd,0,4)."/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}".substr($ymd,0,4).substr($ymd,5,2).".txt"; + if (-f $f) { + my @mchour = split(/\n/,qx(grep "|$ymdh:" $f)); + push(@mclist,@mchour); + } + } + my @listeHeures = reverse('00'..'23'); + + my $dt = 0; + my $last_mn; + my $lmn; + + # what's the last minute-image ? searches for it and computes realtime delta + my $last_d = qx(y=\$(find $SEFRAN3{ROOT} -maxdepth 1 -name "????" | sort | tail -n1);find \$y -maxdepth 1| sort | tail -n1 | xargs echo -n); + if ($last_d) { + $last_mn = qx/find $last_d -name "??????????????.png"|sort|tail -n1/; + if ($last_mn) { + $lmn = basename($last_mn); + my @lm = (substr($lmn,10,2),substr($lmn,8,2),substr($lmn,6,2),substr($lmn,4,2),substr($lmn,0,4)); + $dt = (timegm(gmtime) - timegm(0,$lm[0],$lm[1],$lm[2],$lm[3]-1,$lm[4]-1900) - 60); + } + } + + # title and current data/time + print ""; + if ($header) { + print ""; + if (!$ref || $SEFRAN3{REF_NORTC} == 0) { + print ""; + } + print ""; + } + +# form to display/select dates span (interval) and realtime vs start-date (reference) + print ""; + print "

        $titrePage".($userLevel == 4 ? " ":"")."

        ", + "

        »» [ ", + "", + " | "; + print "", + " | " if ($sgramOK); + print "$__{'Information'}", + " | $MC3{TITLE}", + " ]

        $Ya-$ma-$da
        $Ha:$Ma UTC

        ", + "ΔT ".($dt < 120 ? "= $dt s" : "< ".($dt < 7200 ? int($dt/60 +1)." mn" : int($dt/3600)." hr"))."
        "; + print "
        "; + + # hidden values to pass all parameters in the form + print ""; + print "$__{'Interval'}: "; + print "  $__{'Reference'}: \n"; + print ""; + print " "; + print ""; + print " ".$__{'Header'}; + print " ".$__{'Status'}; + print " ".$__{'Event Loc'}; + print " ".$__{'Trash'}; + print "
        "; + print "
        "; + if ($sgramOK) { + print "", + ""; + } + + print ""; + my $nb_heures = 0; + my $nb_vign = 0; + for (@dates) { + my $dd = $_; + my $da = substr($_,0,4); + my $dm = substr($_,5,2); + my $dj = substr($_,8,2); + my $ddd = "$da$dm$dj"; + my $dt = l2u(strftime('%A %-d %B %Y UTC',gmtime(timegm(0,0,0,$dj,$dm-1,$da-1900)))); + my $nb_heures_jour=0; + for (@listeHeures) { + my $hh = $_; + if (($today ne $dd)||($Ha ge $hh)) { + if (($limit != 0 && ++$nb_heures <= $limit) || ($limit == 0 && ($nb_heures++ <= $limit_lastmc))) { + $nb_heures_jour++; + $nb_vign++; + my $f = "$da/$ddd/$SEFRAN3{PATH_IMAGES_HOUR}/$ddd$hh"; + my $imgopt = "border=\"1\" onClick=\"window.open('$prog&date=$ddd$hh&trash=$trash')\""; + print ""; + if (-e "$SEFRAN3{ROOT}/$f.jpg") { + my $sgramimg = ""; + my $sgramalign = ""; + if ($sgramOK) { + my $fs = "$SEFRAN3{ROOT}/${f}s.jpg"; + if (-e $fs) { + if ($nb_vign > 1) { + my ($w, $h) = dim(image_info($fs)); + $sgramalign = ";left:".($SEFRAN3{HOURLY_WIDTH}-$w)."px !important"; + } + $sgramimg = ""; + } + } + print "\n"; + } + } + } + if ($nb_heures_jour > 0) { + print "\n"; + } + + } + + print "
         $da-$dm-$dj 
         $hhh UTC 
        "; + print "$sgramimg"; + } else { + print "
        no image"; + } + + # plots MC events over sefran + for (reverse @mclist) { + my %MC = mcinfo($_,$evtloc); + if (($MC{id} > 0 || ($userLevel >= 2 && $trash == 1)) && $userLevel >= 1) { + + # event start and end expressed in days + my $d0 = $MC{year}*10000 + $MC{month}*100 + $MC{day} + $MC{hour}/24 + $MC{minute}/1440 + $MC{second}/86400; + my $d1 = $d0 + $MC{duration}*$duration_s{$MC{unit}}/86400; + if ($d0 < $ddd + ($hh+1)/24 && $d1 >= $ddd + $hh/24) { + + # event start and duration expressed in hour + my $h0 = $MC{minute}/60 + $MC{second}/3600; + my $dh = $MC{duration}*$duration_s{$MC{unit}}/3600; + + # event start and duration expressed in pixels + my $deb_evt = 2 + int($SEFRAN3{HOURLY_WIDTH}*$h0); + my $dur_evt = 1 + int(0.5 + $SEFRAN3{HOURLY_WIDTH}*$dh); + + # case A: event starts in the current hour + if ($MC{hour} eq $hh) { + + # case A1: event duration exceeds current hour + if ($deb_evt + $dur_evt > $SEFRAN3{HOURLY_WIDTH}) { + $dur_evt = $SEFRAN3{HOURLY_WIDTH} - $deb_evt + 2; + } + + # case B: event has started in a previous hour + } else { + $deb_evt = 2; + my $hdeb = $MC{hour}; + $hdeb -= 24 if ($hdeb > $hh); # solves event crossover a day + + # case B1: more than 3 hours overlap = full width + if ($h0 + $dh > $hh - $hdeb + 1) { + $dur_evt = $SEFRAN3{HOURLY_WIDTH}; + } else { + $dur_evt = $SEFRAN3{HOURLY_WIDTH}*($h0 + $dh - ($hh-$hdeb)) + 1; + } + } + print "
        ", + "
        \n"; + } + } + } + print "
        ⇑  $dt  ⇑

        "; + + # table information about channel streams + print "

        Informations

        \n"; + if ($status) { + my $now_seconds = timegm(gmtime); + my $Q = qx($WEBOBS{PRGM_ALARM} $SEFRAN3{SEEDLINK_SERVER_TIMEOUT_SECONDS} $WEBOBS{SLINKTOOL_PRGM} -Q $SEFRAN3{SEEDLINK_SERVER}); + my @stream_server = split(/\n/,$Q); + + # read statistics + my @stat_streams = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:streams]" $last_mn/); + my @stat_offset = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:offset]" $last_mn/); + my @stat_median = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:median]" $last_mn/); + my @stat_rate = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:rate]" $last_mn/); + my @stat_sampling = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:sampling]" $last_mn/); + my @stat_drms = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:drms]" $last_mn/); + my @stat_asymetry = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:asymetry]" $last_mn/); + my @stat_fdom; + + if ($sgramOK) { + (my $last_sg = $last_mn) =~ s/$SEFRAN3{PATH_IMAGES_MINUTE}/$SEFRAN3{PATH_IMAGES_SGRAM}/; + $last_sg =~ s/\.png/s.png/; + @stat_fdom = split(/,/,qx/$WEBOBS{PRGM_IDENTIFY} -format "%[sefran3:freqdom]" $last_sg/); + } + + print "", + "", + "", + "", + "", + ($sgramOK ? "":""), + "\n"; + for (@channels) { + $i++; + my ($alias,$codes,$calib,$offset,$pp,$color) = split(/\s+/,$_); + $color =~ s/"//; + my ($net,$sta,$loc,$cha) = split(/\./,$codes); + my @chan = grep(/$net *$sta *$loc *$cha/,@stream_server); + my $idx = first { $stat_streams[$_] eq $codes } 0..$#stat_streams; + + print "", + "", + ""; + + my $ch_nagios = 3; # Nagios 'UNKNOWN' value + if ($idx ge 0) { + my ($status_offset,$status_noise) = (1,1); + if (abs($stat_offset[$idx]) < $SEFRAN3{STATUS_OFFSET_WARNING}) { $status_offset = 0; } + elsif (abs($stat_offset[$idx]) > $SEFRAN3{STATUS_OFFSET_CRITICAL}) { $status_offset = 2; } + if ($stat_drms[$idx] != 0 && ($stat_drms[$idx]/$calib) < $SEFRAN3{STATUS_NOISE_WARNING}) { $status_noise = 0; } + elsif ($stat_drms[$idx] == 0 || ($stat_drms[$idx]/$calib) > $SEFRAN3{STATUS_NOISE_CRITICAL}) { $status_noise = 2; } + printf("",1e6*$stat_median[$idx]/$calib); + printf("",100*$stat_offset[$idx]); + printf("",100*$stat_asymetry[$idx]); + printf("",1e6*$stat_drms[$idx]/$calib); + printf("",100*$stat_sampling[$idx]); + printf("",$stat_rate[$idx]); + printf("",$stat_fdom[$idx]) if ($sgramOK); + if ($status_offset == 0 && $status_noise == 0) { + $ch_nagios = 0; # Nagios 'OK' value + } elsif ($status_offset == 2 || $status_noise == 2) { + $ch_nagios = 2; # Nagios 'CRITICAL' value + } else { + $ch_nagios = 1; # Nagios 'WARNING' value + } + } else { + print ""; + } + + if (@chan) { + my ($start,$end) = split(/ - /,substr($chan[0],18)); + my $start_s = timegm(substr($start,17,2),substr($start,14,2),substr($start,11,2),substr($start,8,2),substr($start,5,2)-1,substr($start,0,4)-1900); + my $end_s = timegm(substr($end,17,2),substr($end,14,2),substr($end,11,2),substr($end,8,2),substr($end,5,2)-1,substr($end,0,4)-1900); + my $bl = int(($end_s - $start_s)/60); # ringbuffer length (in minutes) + my $dt = ($now_seconds - $end_s); + my $status_delay = 0; + if ($dt > $SEFRAN3{STATUS_DELAY_CRITICAL}) { + $status_delay = 2; + $ch_nagios = 2; + } elsif ($ch_nagios < 2 && $dt > $SEFRAN3{STATUS_DELAY_WARNING}) { + $status_delay = 1; + $ch_nagios = 1; + } + print "", + ""; + print ""; + + #if ($dt > $SEFRAN3{ARCLINK_DELAY_HOURS}) { + } else { + print ""; + } + switch ($ch_nagios) { + case 0 { print ""; } + case 1 { print ""; } + case 2 { print ""; } + case 3 { print ""; } + } + print "\n"; + } + print "
        #AliasChannelCalibration
        (count/(m/s))        		FilterPeak-Peak
        (m/s)        		Signal statistics on last image
        $lmn        		SeedLink server $SEFRAN3{SEEDLINK_SERVER}Status
        Offset
        (μm/s)        		Asym.RMSΔ
        (μm/s)        		Acq.
        (%)        		Samp.
        (Hz)        		Freq
        (Hz)        		Oldest dataLast dataBufferΔT
        $i.$alias$codes$calib$offset$pp%1.4f%2.0f%%2.0f%%1.4f%1.0f%g%1.2fnot available$start$end" + .($bl < 60 ? "$bl mn":($bl < 1440 ? int($bl/60 + 0.5)." h":int($bl/1440 + 0.5)." d"))."" + .($dt < 60 ? "$dt s":($dt < 3600 ? int($dt/60 + 0.5)." mn":($dt < 86400 ? int($dt/3600 + 0.5)." h":int($dt/86400 + 0.5)." d")))."not availableOKPBHS?

        \n"; + } + + print "

        Sefran3 configuration file: $s3

        \n"; + print "

        Channels parameters file: $SEFRAN3{CHANNEL_CONF}

        \n"; + print "

        Update window: $SEFRAN3{UPDATE_HOURS} h

        \n"; + print "

        Datasource: ".($SEFRAN3{DATASOURCE} ne "" ? "$SEFRAN3{DATASOURCE}":"Not configured.")."

        \n"; + print "

        Broom wagon: ".($SEFRAN3{BROOMWAGON_ACTIVE} ? ("Active (delay = $SEFRAN3{BROOMWAGON_DELAY_HOURS} h," + ."update window = $SEFRAN3{BROOMWAGON_UPDATE_HOURS} h, " + ."maximum dead channels = $SEFRAN3{BROOMWAGON_MAX_DEAD_CHANNELS}, " + ."maximum gap = ".sprintf("%g%%",$SEFRAN3{BROOMWAGON_MAX_GAP_FACTOR}*100).")"):"Not active")."

        \n"; + + print "", + "\n", + "", + "\n", + "", + "\n", + "
        Virtual speed
        (inches/minute)        		Resolution
        (pixels/second)        		1-minute image width
        (pixels)        		Density \@100Hz
        (samples/pixel)
        Normal view$SEFRAN3{VALUE_SPEED}".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}/60)."", + "".int($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED}*$SEFRAN3{VALUE_PPI}))."
        High-speed view$SEFRAN3{VALUE_SPEED_HIGH}".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}/60)."", + "".int($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI})."".int(100*60/($SEFRAN3{VALUE_SPEED_HIGH}*$SEFRAN3{VALUE_PPI}))."
        \n"; + print "

        MC events: ".@mclist."

        \n"; + print "

        Last MC: $last_mc ($limit_lastmc h)

        \n" if ($limit==0); + + my @notes = readFile("$SEFRAN3{NOTES}"); + print WebObs::Wiki::wiki2html(join("",@notes)); + + print ""; } # ----------------------------------------------------------------------------- # ---- Case: hour and analysis (depouillement) form page ------------------- # ----------------------------------------------------------------------------- if ($date) { - my ($Yc,$mc,$dc,$Hc,$Mc) = unpack("a4 a2 a2 a2 a2",$date); - - # read existing events from MC for current hour - my @mc_hlist; - my $f = "$MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$Yc$mc.txt"; - if (-e $f) { - @mc_hlist = split(/\n/,qx(grep "|$Yc-$mc-$dc|$Hc:" $f)); - } - - print "
        "; - my %MC; - my $fileMC = "$MC3{FILE_PREFIX}$Yc$mc.txt"; - my $date_deb; # starting date (relative) - my $date_nbm; # number of files - my $date_prec = my $dprec = ""; - my $date_suiv = my $dsuiv = ""; - my $idarg = ""; - - if ($dep) { - if ($id) { # read event ID from MC + set number of minute-files containing signal + 1 - my @mc_evt = qx(grep "^$id|" $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); - %MC = mcinfo($mc_evt[0],1); - $date_nbm = 1 + int(1 + ($MC{duration}*$duration_s{$MC{unit}} + $MC{second})/60); - } else { - $date_nbm = $MC3{WINDOW_LENGTH_MINUTE}; - } - $date_deb = 0; - $date_prec = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); - $dprec = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); - $date_suiv = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); - $dsuiv = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); - $idarg = "&id=$id"; - } else { - $date_deb = -1; - $date_nbm = 61; - $date_prec = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); - $dprec = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); - $date_suiv = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); - $dsuiv = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); - } - - # prev+next hour 'big arrows' - if (!$dep && defined($SEFRAN3{BIGARROWS})) { - print "
         
        "; - print "
         
        "; - } - - # control-panel fixed box (zoom,mctag toggle,next/prev buttons) - print "
        "; - print "Controls"; - print "
        "; - print "+\n"; - print "=\n"; - print "−\n"; - print "\n"; - print "←\n"; - print "→\n"; - print "\n"; - if ($sgramOK) { - print "
        ", - " ", - "
        \n", - ""; - } - print "
        "; - print "
        "; - - # image of channels - my $voies = "$SEFRAN3{PATH_WEB}/$Yc/$Yc$mc$dc/$SEFRAN3{PATH_IMAGES_HEADER}/$Yc$mc$dc$Hc\_voies.png"; - - # builds the list of minute images - my @liste_png; - for ($i = $date_deb; $i < $date_nbm; $i++) { - my ($Y,$m,$d,$H,$M) = split('/',strftime('%Y/%m/%d/%H/%M',gmtime(timegm(0,($dep ? "$Mc":"0"),$Hc,$dc,$mc-1,$Yc-1900) + $i*60))); - push(@liste_png,sprintf("%s/%4d/%04d%02d%02d/%s/%04d%02d%02d%02d%02d00", - $SEFRAN3{ROOT},$Y,$Y,$m,$d,$SEFRAN3{PATH_IMAGES_MINUTE},$Y,$m,$d,$H,$M)); - } - my $fin = 0; - my $reload = 0; - - if ($voies_classiques && !$dep) { - print "\n"; - } else { - print "\n"; - } - print "\n"; - print ""; - - for (reverse @mc_hlist) { - my %MC = mcinfo($_,1); - #DL-was: if (($MC{id} > 0 || $userLevel == 4) && $userLevel >= 1 && $MC{id} != $id && ($MC{minute} - $Mc) <= $date_nbm) { - if (($MC{id} > 0 || ($userLevel == 4 && $trash == 1)) && $userLevel >= 1 && ($MC{minute} - $Mc) <= $date_nbm) { - my $deb_evt; - if ($dep) { - $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} - $Mc + $MC{second}/60)); - } else { - $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} + 1 + $MC{second}/60)); - } - my $dur_evt = 1 + int(0.5 + $largeur_image*$MC{duration}*$duration_s{$MC{unit}}/60); - if ($MC{id} != $id) { - print "
        \n"; - } else { - my $dlstripes = "background: repeating-linear-gradient(120deg, white, white 7px, $types{$MC{type}}{Color} 7px, $types{$MC{type}}{Color} 14px);"; - print "
        "; - } - } - } - - print "
        "; - for (@liste_png) { - my $png = qx(basename $_); chomp $png; - my ($Y,$m,$d,$H,$M,$S) = unpack("a4 a2 a2 a2 a2 a2",$png); - my $timestamp = "$Y-$m-$d $H:$M UT"; - my $png_file = "$_".($high ? "_high":"").".png"; - if ( -f $png_file ) { - my $png_web = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_MINUTE}/$png".($high ? "_high":"").".png"; - my $png_sgram = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_SGRAM}/${png}s.png"; - my $mseed = "$mseedreq&t1=$Y,$m,$d,$H,$M,0&ds=60"; - - print "$timestamp', WIDTH, 200)\"", - " shape=rect coords=\"0,0,$largeur_image,$hauteur_label_haut\" alt=\"miniSEED $png\">", - "= 2) { - print " class=\"flyhour\" onMouseOver=\"flyhour(this,'$__{'Click to start input Main Courante'}')\"", - " href=\"$prog&date=$Y$m$d$H$M&s3=$s3\" target=\"_blank\" rel=\"opener\""; - } - print " shape=rect coords=\"0,".($hauteur_label_haut + 1).",$largeur_image,".($hauteur_image - $hauteur_label_haut)."\">"; - print "" if ($sgramOK); - print ""; - } elsif ( "$Y$m$d$H$M" >= "$Ya$ma$da$Ha$Ma") { - if (!$fin) { - print "
        Now
        $Ya-$ma-$da
        $Ha:$Ma:$Sa UTC
        		"; - if (!$reload && !$dep) { - print ""; - $reload = 1; - } - $fin = 1; - } - } elsif ( "$Y$m$d$H$M" >= "$Yr$mr$dr$Hr$Mr") { - print "

        In progress...
        $Y-$m-$d
        $H:$M:$S UTC
        		"; - if (!$reload && !$dep) { - print ""; - $reload = 1; - } - } else { - print "
        No image
        $Y-$m-$d
        $H:$M:$S UTC
        		"; - } - } - print "
        "; - print "
        "; - - if ($dep) { - # default values for mcform; - # case : editing an existing id or not - my $date_evt = ($id ? "$MC{date} $MC{hour}:$MC{minute}" : "$Yc-$mc-$dc $Hc:$Mc"); - my $seconde_evt = ($id ? $MC{second} : ""); - my $type_evt = ($id ? $MC{type} : "$MC3{DEFAULT_TYPE}"); - my $amplitude_evt = ($id ? $MC{amplitude} : "$MC3{DEFAULT_AMPLITUDE}"); - my $duree_evt = ($id ? $MC{duration} : ""); - my $unite_evt = ($id ? $MC{unit} : "s"); - my $duree_sat_evt = ($id ? $MC{overscale} : 0); - my $nb_evt = ($id ? $MC{amount} : 1); - my $s_moins_p_evt = ($id ? $MC{s_minus_p} : "");$s_moins_p_evt =~ s/^NA$//; - my $station = $MC{station}; - my $unique_evt = ($id ? $MC{unique} : 0); - my $operateur = $MC{operator}; - my $comment_evt = ($id ? htmlspecialchars(l2u($MC{comment})) : ""); - # case : 'replay mode' ('replay' and 'editing id' must be exclusive) - if ($replay && !$id) { - my @mcreplay = qx(awk -F'|' '\$1 == $replay {printf "\%s",\$0}' $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); - my %MCreplay = mcinfo($mcreplay[0]); - $type_evt = $MCreplay{type}; - $amplitude_evt = $MCreplay{amplitude}; - } - - my $modif = 0; - - if ((isok($MC3{LEVEL2_MODIFY_ALL_EVENTS}) && $userLevel ==2) || ($userLevel == 2 && ($operateur eq "" || $operateur eq $USERS{$CLIENT}{UID} || $type_evt eq "AUTO")) || $userLevel == 4 ) { - $modif = 1; - } - # --- mcform: edit form for Main Courante - print "
        ", - "
        ", - "", - "", - "", - "", - "", - "", - "", - "", # compatibilite MC2: nombre de fichiers - "", # pour compatibilite MC2: remplace par la version SEFRAN - "", - "", - "", - "", - "

        ".($id ? ($modif > 0 ? "$__{'Update'}":""):"$__{'Input'}")." $MC3{TITLE}

        "; - if ($id) { - print "
        "; - if ($modif) { - print ""; - } - print "
        ", - ""; - if ($userLevel == 4) { - print ""; - } - print "$__{'Event'}"; - if ($operateur eq "" || $operateur eq $MC3{SC3_USER}) { - print " $__{'not validated by operator (automatic)'}"; - } else { - print " $__{'identified by'} ".join(',',WebObs::Users::userName($operateur)).""; - } - if (length($MC{qml})>2) { - print "
        QML: $MC{qml}"; - } - print "
        "; - } - - # list of operators - print "

        $__{'Operator'}:

        "; - - # list of stations - print "

        $__{'Station of first arrival'}: "; - print "   Multiple", - "   Unique

        \n"; - - # date and time of first arrival - print "

        Date, HH:MM : "; - - # seconds of first arrival - print " $__{'Seconds'}:

        "; - - # duration - print "

        $__{'Duration'}: "; - print "\n"; - - # number of events - print "  $__{'Number of events'} =

        \n"; - - # S-P - print "

        S−P ($__{'Seconds'}): ", - "", - "", - "

        "; - - # amplitude and saturation - print "

        $__{'Max amplitude'}:

        \n"; - print "

        $__{'Overscale duration'} ($__{'Seconds'}): ", - " (0 = $__{'not overscale'})

        \n"; - - # type of event - print "

        $__{'Event type'}: \n"; - - # Prediction seismic-event - if ($MC3{PREDICT_EVENT_TYPE} ne "" && $MC3{PREDICT_EVENT_TYPE} ne "NO") { - print "\n"; - print "
        \n"; - print "

        $__{'PLEASE WAIT'}

        \n"; + my ($Yc,$mc,$dc,$Hc,$Mc) = unpack("a4 a2 a2 a2 a2",$date); + + # read existing events from MC for current hour + my @mc_hlist; + my $f = "$MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$Yc$mc.txt"; + if (-e $f) { + @mc_hlist = split(/\n/,qx(grep "|$Yc-$mc-$dc|$Hc:" $f)); + } + + print "
        "; + my %MC; + my $fileMC = "$MC3{FILE_PREFIX}$Yc$mc.txt"; + my $date_deb; # starting date (relative) + my $date_nbm; # number of files + my $date_prec = my $dprec = ""; + my $date_suiv = my $dsuiv = ""; + my $idarg = ""; + + if ($dep) { + if ($id) { # read event ID from MC + set number of minute-files containing signal + 1 + my @mc_evt = qx(grep "^$id|" $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); + %MC = mcinfo($mc_evt[0],1); + $date_nbm = 1 + int(1 + ($MC{duration}*$duration_s{$MC{unit}} + $MC{second})/60); + } else { + $date_nbm = $MC3{WINDOW_LENGTH_MINUTE}; + } + $date_deb = 0; + $date_prec = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); + $dprec = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)-60)); + $date_suiv = strftime('%Y%m%d%H%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); + $dsuiv = strftime('Jump to %Y-%m-%d %H:%M',gmtime(timegm(0,$Mc,$Hc,$dc,$mc-1,$Yc-1900)+60)); + $idarg = "&id=$id"; + } else { + $date_deb = -1; + $date_nbm = 61; + $date_prec = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); + $dprec = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)-3600)); + $date_suiv = strftime('%Y%m%d%H',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); + $dsuiv = strftime('Jump to %Y-%m-%d %Hh',gmtime(timegm(0,0,$Hc,$dc,$mc-1,$Yc-1900)+3600)); + } + + # prev+next hour 'big arrows' + if (!$dep && defined($SEFRAN3{BIGARROWS})) { + print "
         
        "; + print "
         
        "; + } + + # control-panel fixed box (zoom,mctag toggle,next/prev buttons) + print "
        "; + print "Controls"; + print "
        "; + print "+\n"; + print "=\n"; + print "−\n"; + print "\n"; + print "←\n"; + print "→\n"; + print "\n"; + if ($sgramOK) { + print "
        ", + " ", + "
        \n", + ""; + } + print "
        "; + print "
        "; + + # image of channels + my $voies = "$SEFRAN3{PATH_WEB}/$Yc/$Yc$mc$dc/$SEFRAN3{PATH_IMAGES_HEADER}/$Yc$mc$dc$Hc\_voies.png"; + + # builds the list of minute images + my @liste_png; + for ($i = $date_deb; $i < $date_nbm; $i++) { + my ($Y,$m,$d,$H,$M) = split('/',strftime('%Y/%m/%d/%H/%M',gmtime(timegm(0,($dep ? "$Mc":"0"),$Hc,$dc,$mc-1,$Yc-1900) + $i*60))); + push(@liste_png,sprintf("%s/%4d/%04d%02d%02d/%s/%04d%02d%02d%02d%02d00", + $SEFRAN3{ROOT},$Y,$Y,$m,$d,$SEFRAN3{PATH_IMAGES_MINUTE},$Y,$m,$d,$H,$M)); + } + my $fin = 0; + my $reload = 0; + + if ($voies_classiques && !$dep) { + print "\n"; + } else { + print "\n"; + } + print "\n"; + print ""; + + for (reverse @mc_hlist) { + my %MC = mcinfo($_,1); + +#DL-was: if (($MC{id} > 0 || $userLevel == 4) && $userLevel >= 1 && $MC{id} != $id && ($MC{minute} - $Mc) <= $date_nbm) { + if (($MC{id} > 0 || ($userLevel == 4 && $trash == 1)) && $userLevel >= 1 && ($MC{minute} - $Mc) <= $date_nbm) { + my $deb_evt; + if ($dep) { + $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} - $Mc + $MC{second}/60)); + } else { + $deb_evt = 1 + $SEFRAN3{VALUE_PPI} + int($largeur_image*($MC{minute} + 1 + $MC{second}/60)); + } + my $dur_evt = 1 + int(0.5 + $largeur_image*$MC{duration}*$duration_s{$MC{unit}}/60); + if ($MC{id} != $id) { + print "
        \n"; + } else { + my $dlstripes = "background: repeating-linear-gradient(120deg, white, white 7px, $types{$MC{type}}{Color} 7px, $types{$MC{type}}{Color} 14px);"; + print "
        "; + } + } + } + + print "
        "; + for (@liste_png) { + my $png = qx(basename $_); chomp $png; + my ($Y,$m,$d,$H,$M,$S) = unpack("a4 a2 a2 a2 a2 a2",$png); + my $timestamp = "$Y-$m-$d $H:$M UT"; + my $png_file = "$_".($high ? "_high":"").".png"; + if ( -f $png_file ) { + my $png_web = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_MINUTE}/$png".($high ? "_high":"").".png"; + my $png_sgram = "$SEFRAN3{PATH_WEB}/$Y/$Y$m$d/$SEFRAN3{PATH_IMAGES_SGRAM}/${png}s.png"; + my $mseed = "$mseedreq&t1=$Y,$m,$d,$H,$M,0&ds=60"; + + print "$timestamp', WIDTH, 200)\"", + " shape=rect coords=\"0,0,$largeur_image,$hauteur_label_haut\" alt=\"miniSEED $png\">", + "= 2) { + print " class=\"flyhour\" onMouseOver=\"flyhour(this,'$__{'Click to start input Main Courante'}')\"", + " href=\"$prog&date=$Y$m$d$H$M&s3=$s3\" target=\"_blank\" rel=\"opener\""; + } + print " shape=rect coords=\"0,".($hauteur_label_haut + 1).",$largeur_image,".($hauteur_image - $hauteur_label_haut)."\">"; + print "" if ($sgramOK); + print ""; + } elsif ( "$Y$m$d$H$M" >= "$Ya$ma$da$Ha$Ma") { + if (!$fin) { + print "
        Now
        $Ya-$ma-$da
        $Ha:$Ma:$Sa UTC
        		"; + if (!$reload && !$dep) { + print ""; + $reload = 1; } - - # link to USGS - my $ocl = "USGS"; - $ocl = $MC3{VISIT_LINK} if (defined($MC3{VISIT_LINK})); - print " → $__{'Visit'} $ocl

        \n"; - - # comment - print "

        $__{'Comment'}:

        \n"; - - # options for validation and reset - if ($modif > 0) { - print "
        "; - if (length($MC{qml}) < 3 && $types{$type_evt}{WO2SC3} != -1) { - print "

        " - ."

        \n"; - } - # print and replay - if ($id) { - print "

        $__{'Print signal'}

        \n"; - } else { - print "\n"; - print "" : ">"; # coming in with replay ==> keep replay as a default - print "

        \n"; - } - print "        		", - "  
        \n"; - } - # downloads miniseed - print "
        ", - "
        ", - "", - " $__{'Sefran channels'}
        ", - " $__{'Sefran stations (all components)'}
        ", - " $__{'SeedLink/ArcLink all available channels (!)'}", - "
        \n"; - - print "\n"; - - # vertical tag-lines for event-start, event-end and eventS-P - print "
        START
        \n", - "
        END
        \n"; - print "
         S 
        \n"; - } - - print ""; + $fin = 1; + } + } elsif ( "$Y$m$d$H$M" >= "$Yr$mr$dr$Hr$Mr") { + print "

        In progress...
        $Y-$m-$d
        $H:$M:$S UTC
        		"; + if (!$reload && !$dep) { + print ""; + $reload = 1; + } + } else { + print "
        No image
        $Y-$m-$d
        $H:$M:$S UTC
        		"; + } + } + print "
        "; + print "
        "; + + if ($dep) { + + # default values for mcform; + # case : editing an existing id or not + my $date_evt = ($id ? "$MC{date} $MC{hour}:$MC{minute}" : "$Yc-$mc-$dc $Hc:$Mc"); + my $seconde_evt = ($id ? $MC{second} : ""); + my $type_evt = ($id ? $MC{type} : "$MC3{DEFAULT_TYPE}"); + my $amplitude_evt = ($id ? $MC{amplitude} : "$MC3{DEFAULT_AMPLITUDE}"); + my $duree_evt = ($id ? $MC{duration} : ""); + my $unite_evt = ($id ? $MC{unit} : "s"); + my $duree_sat_evt = ($id ? $MC{overscale} : 0); + my $nb_evt = ($id ? $MC{amount} : 1); + my $s_moins_p_evt = ($id ? $MC{s_minus_p} : "");$s_moins_p_evt =~ s/^NA$//; + my $station = $MC{station}; + my $unique_evt = ($id ? $MC{unique} : 0); + my $operateur = $MC{operator}; + my $comment_evt = ($id ? htmlspecialchars(l2u($MC{comment})) : ""); + + # case : 'replay mode' ('replay' and 'editing id' must be exclusive) + if ($replay && !$id) { + my @mcreplay = qx(awk -F'|' '\$1 == $replay {printf "\%s",\$0}' $MC3{ROOT}/$Yc/$MC3{PATH_FILES}/$fileMC); + my %MCreplay = mcinfo($mcreplay[0]); + $type_evt = $MCreplay{type}; + $amplitude_evt = $MCreplay{amplitude}; + } + + my $modif = 0; + + if ((isok($MC3{LEVEL2_MODIFY_ALL_EVENTS}) && $userLevel ==2) || ($userLevel == 2 && ($operateur eq "" || $operateur eq $USERS{$CLIENT}{UID} || $type_evt eq "AUTO")) || $userLevel == 4 ) { + $modif = 1; + } + + # --- mcform: edit form for Main Courante + print "
        ", + "
        ", + "", + "", + "", + "", + "", + "", + "", + "", # compatibilite MC2: nombre de fichiers + "", # pour compatibilite MC2: remplace par la version SEFRAN + "", + "", + "", + "", + "

        ".($id ? ($modif > 0 ? "$__{'Update'}":""):"$__{'Input'}")." $MC3{TITLE}

        "; + if ($id) { + print "
        "; + if ($modif) { + print ""; + } + print "
        ", + ""; + if ($userLevel == 4) { + print ""; + } + print "$__{'Event'}"; + if ($operateur eq "" || $operateur eq $MC3{SC3_USER}) { + print " $__{'not validated by operator (automatic)'}"; + } else { + print " $__{'identified by'} ".join(',',WebObs::Users::userName($operateur)).""; + } + if (length($MC{qml})>2) { + print "
        QML: $MC{qml}"; + } + print "
        "; + } + + # list of operators + print "

        $__{'Operator'}:

        "; + + # list of stations + print "

        $__{'Station of first arrival'}: "; + print "   Multiple", + "   Unique

        \n"; + + # date and time of first arrival + print "

        Date, HH:MM : "; + + # seconds of first arrival + print " $__{'Seconds'}:

        "; + + # duration + print "

        $__{'Duration'}: "; + print "\n"; + + # number of events + print "  $__{'Number of events'} =

        \n"; + + # S-P + print "

        S−P ($__{'Seconds'}): ", + "", + "", + "

        "; + + # amplitude and saturation + print "

        $__{'Max amplitude'}:

        \n"; + print "

        $__{'Overscale duration'} ($__{'Seconds'}): ", + " (0 = $__{'not overscale'})

        \n"; + + # type of event + print "

        $__{'Event type'}: \n"; + + # Prediction seismic-event + if ($MC3{PREDICT_EVENT_TYPE} ne "" && $MC3{PREDICT_EVENT_TYPE} ne "NO") { + print "\n"; + print "
        \n"; + print "

        $__{'PLEASE WAIT'}

        \n"; + } + + # link to USGS + my $ocl = "USGS"; + $ocl = $MC3{VISIT_LINK} if (defined($MC3{VISIT_LINK})); + print " → $__{'Visit'} $ocl

        \n"; + + # comment + print "

        $__{'Comment'}:

        \n"; + + # options for validation and reset + if ($modif > 0) { + print "
        "; + if (length($MC{qml}) < 3 && $types{$type_evt}{WO2SC3} != -1) { + print "

        " + ."

        \n"; + } + + # print and replay + if ($id) { + print "

        $__{'Print signal'}

        \n"; + } else { + print "\n"; + print "" : ">"; # coming in with replay ==> keep replay as a default + print "

        \n"; + } + print "        		", + "  
        \n"; + } + + # downloads miniseed + print "
        ", + "
        ", + "", + " $__{'Sefran channels'}
        ", + " $__{'Sefran stations (all components)'}
        ", + " $__{'SeedLink/ArcLink all available channels (!)'}", + "
        \n"; + + print "
        \n"; + + # vertical tag-lines for event-start, event-end and eventS-P + print "
        START
        \n", + "
        END
        \n"; + print "
         S 
        \n"; + } + + print ""; } # ---- helpers # ---------------------------------------------------------------------------- sub mcinfo { - my %MC; - - ($MC{id},$MC{date},$MC{time},$MC{type},$MC{amplitude},$MC{duration},$MC{unit},$MC{overscale},$MC{amount},$MC{s_minus_p},$MC{station},$MC{unique},$MC{sefran},$MC{qml},$MC{image},$MC{signature},$MC{comment}) = split(/\|/,$_[0]); - - ($MC{operator},$MC{timestamp}) = split('/',$MC{signature}); - $MC{firstarrival} = "$MC{date} $MC{time} UT"; - $MC{duration} ||= 10; - - my $comment = htmlspecialchars(l2u($MC{comment})); - $comment =~ s/'/\\'/g; # this is needed by overlib() - - ($MC{year},$MC{month},$MC{day}) = split(/-/,$MC{date}); - ($MC{hour},$MC{minute},$MC{second}) = split(/:/,$MC{time}); - - $MC{edit} = "&date=$MC{year}$MC{month}$MC{day}$MC{hour}$MC{minute}&id=$MC{id}"; - - $MC{info} = "":">") - ."by ".join('',WebObs::Users::userName($MC{operator}))."
        " - ."Duration: $MC{duration} $MC{unit}
        " - ."Type: $types{$MC{type}}{Name}
        " - ."Station: $MC{station}".($MC{unique} ? " (unique)":"")."
        " - .($MC{amplitude} ? "Amplitude: $nomAmp{$MC{amplitude}}
        ":"") - ."Comment: $comment" - .""; - - if ($_[1] ne "" && length($MC{qml}) > 2) { - $MC{info} .= "
        SC3 ID: $MC{qml}"; - if (not $hideloc) { - my %QML; - if ($MC3{SC3_EVENTS_ROOT} ne "" && $MC{qml} =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { - my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$MC{qml}); - %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$MC{qml}/$sc3id.last.xml"); - } - elsif ($MC{qml} =~ /:\/\//) { - my ($fdsnws_src,$evt_id) = split(/:\/\//,$MC{qml}); - my $fdsnws_url = ""; - if (defined($MC3{FDSNWS_EVENTS_URL})) { - $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; - } - if (length($fdsnws_src) > 0) { - my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; - $fdsnws_url = "$MC3{$varname}"; - } - %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); - } - $MC{origin} = ($QML{latitude} < 0 ? sprintf("%2.2f°S",-$QML{latitude}):sprintf("%2.2f°N",$QML{latitude})) - ." / ".($QML{longitude} < 0 ? sprintf("%2.2f°W",-$QML{longitude}):sprintf("%2.2f°E",$QML{longitude})) - .($QML{depth} ? " / ".sprintf("%1.1f km",$QML{depth}):""); - - $MC{info} .= "
        Quality: $QML{phases} phases / M":"red>A").($QML{status} ne "" ? " ($QML{status})":"")."
        " - ."Time: $QML{time}
        " - ."Origin: $MC{origin}
        " - .($QML{magtype} && $QML{magnitude} ? "$QML{magtype} = $QML{magnitude}":""); - } - } - - return (%MC); + my %MC; + + ($MC{id},$MC{date},$MC{time},$MC{type},$MC{amplitude},$MC{duration},$MC{unit},$MC{overscale},$MC{amount},$MC{s_minus_p},$MC{station},$MC{unique},$MC{sefran},$MC{qml},$MC{image},$MC{signature},$MC{comment}) = split(/\|/,$_[0]); + + ($MC{operator},$MC{timestamp}) = split('/',$MC{signature}); + $MC{firstarrival} = "$MC{date} $MC{time} UT"; + $MC{duration} ||= 10; + + my $comment = htmlspecialchars(l2u($MC{comment})); + $comment =~ s/'/\\'/g; # this is needed by overlib() + + ($MC{year},$MC{month},$MC{day}) = split(/-/,$MC{date}); + ($MC{hour},$MC{minute},$MC{second}) = split(/:/,$MC{time}); + + $MC{edit} = "&date=$MC{year}$MC{month}$MC{day}$MC{hour}$MC{minute}&id=$MC{id}"; + + $MC{info} = "":">") + ."by ".join('',WebObs::Users::userName($MC{operator}))."
        " + ."Duration: $MC{duration} $MC{unit}
        " + ."Type: $types{$MC{type}}{Name}
        " + ."Station: $MC{station}".($MC{unique} ? " (unique)":"")."
        " + .($MC{amplitude} ? "Amplitude: $nomAmp{$MC{amplitude}}
        ":"") + ."Comment: $comment" + .""; + + if ($_[1] ne "" && length($MC{qml}) > 2) { + $MC{info} .= "
        SC3 ID: $MC{qml}"; + if (not $hideloc) { + my %QML; + if ($MC3{SC3_EVENTS_ROOT} ne "" && $MC{qml} =~ /[0-9]{4}\/[0-9]{2}\/[0-9]{2}\/.+/) { + my ($qmly,$qmlm,$qmld,$sc3id) = split(/\//,$MC{qml}); + %QML = qmlorigin("$MC3{SC3_EVENTS_ROOT}/$MC{qml}/$sc3id.last.xml"); + } + elsif ($MC{qml} =~ /:\/\//) { + my ($fdsnws_src,$evt_id) = split(/:\/\//,$MC{qml}); + my $fdsnws_url = ""; + if (defined($MC3{FDSNWS_EVENTS_URL})) { + $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; + } + if (length($fdsnws_src) > 0) { + my $varname = "FDSNWS_EVENTS_URL_$fdsnws_src"; + $fdsnws_url = "$MC3{$varname}"; + } + %QML = qmlfdsn("${fdsnws_url}&format=xml&eventid=$evt_id"); + } + $MC{origin} = ($QML{latitude} < 0 ? sprintf("%2.2f°S",-$QML{latitude}):sprintf("%2.2f°N",$QML{latitude})) + ." / ".($QML{longitude} < 0 ? sprintf("%2.2f°W",-$QML{longitude}):sprintf("%2.2f°E",$QML{longitude})) + .($QML{depth} ? " / ".sprintf("%1.1f km",$QML{depth}):""); + + $MC{info} .= "
        Quality: $QML{phases} phases / M":"red>A").($QML{status} ne "" ? " ($QML{status})":"")."
        " + ."Time: $QML{time}
        " + ."Origin: $MC{origin}
        " + .($QML{magtype} && $QML{magnitude} ? "$QML{magtype} = $QML{magnitude}":""); + } + } + + return (%MC); } __END__ diff --git a/CODE/cgi-bin/showBOJAP.pl b/CODE/cgi-bin/showBOJAP.pl index e827c8a7..56e36537 100755 --- a/CODE/cgi-bin/showBOJAP.pl +++ b/CODE/cgi-bin/showBOJAP.pl @@ -99,20 +99,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -126,6 +126,7 @@ =head1 Query string parameters my @csv; my $s = ""; my $i = 0; + #D my %stationsBojap; #D my @codesBojap; @@ -141,12 +142,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamUnite = ("ppm|en ppm","mmol|en mmol/l"); my @cleParamSite; @@ -156,31 +157,32 @@ =head1 Query string parameters my $nbRap = 0; my @rapCalc; -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "Tout"; -$QryParm->{'site'} ||= "Tout"; -$QryParm->{'affiche'} ||= ""; -$QryParm->{'unite'} ||= "ppm"; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "Tout"; +$QryParm->{'site'} ||= "Tout"; +$QryParm->{'affiche'} ||= ""; +$QryParm->{'unite'} ||= "ppm"; # ---- a site requested as {name} means "all nodes for proc 'name'" # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } $i = 0; for (@rapports) { - $i++; - my $rapn = "rap$i"; - #djl-was: if ($valParams =~ /$rapn/) { - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } + $i++; + my $rapn = "rap$i"; + + #djl-was: if ($valParams =~ /$rapn/) { + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } } # ---- Lecture du fichier data dans tableau @lignes @@ -196,67 +198,67 @@ =head1 Query string parameters # ---- html page setup # push(@html,"Content-type: text/html\n\n", - "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n\n", - "\n", - "
        \n", - "\n", - "\n"); + "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n\n", + "\n", + "
        \n", + "\n", + "\n"); # ---- Debut du formulaire pour la selection de l'affichage # push(@html,"
        conf('CGI_SHOW')."\" method=\"get\">", - "

        ", - "Sélectionner: \n"); +for ("Tout|Tout",reverse(@cleParamAnnee)) { + my ($val,$cle)=split (/\|/,$_); + if ("$val" eq "$QryParm->{'annee'}") { push(@html,"\n"); } + else { push(@html,"\n"); } } push(@html,"\n", - ""); +for ("Tout|Toute l'année",@cleParamMois) { + my ($val,$cle)=split (/\|/,$_); + if ("$val" eq "$QryParm->{'mois'}") { + push(@html,"\n"); + $afficheMois = $cle; + } else { + push(@html,"\n"); + } } push(@html,"\n", - ""); +for ("Tout|Tous les sites",@NODESSelList) { + my ($val,$cle)=split (/\|/,$_); + if ("$val" eq "$QryParm->{'site'}") { + push(@html,"\n"); + $afficheSite = "$cle ($val)"; + } else { + push(@html,"\n"); + } } push(@html,"\n", - ""); +for (@cleParamUnite) { + my ($val,$cle) = split (/\|/,$_); + if ("$val" eq "$QryParm->{'unite'}") { push(@html,"\n"); } + else { push(@html,"\n"); } } push(@html,"", - " "); + " "); if ($displayOnly ne 1) { - push(@html,"conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + push(@html,"conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); } push(@html,"
        \nRapports calculés: "); $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - $i++; - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - push(@html,"$nhtm/$dhtm  "); + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + $i++; + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + push(@html,"$nhtm/$dhtm  "); } push(@html,"

        \n"); push(@html,"

        ".$FORM->conf('TITLE')."

        "); @@ -270,133 +272,133 @@ =head1 Query string parameters my $unite; my $fmt = "%0.2f"; if ($QryParm->{'unite'} eq "ppm") { - $unite = "ppm = mg/l"; + $unite = "ppm = mg/l"; } else { - $unite = "mmol/l"; + $unite = "mmol/l"; } my $aliasSite; $entete = "
        PériodeSiteSolution initialeMasse échantillon (g)Concentrations ($unite) Calculs
        DuAuNb
        jours        		H20
        (ml)        		KOH
        (mol/l)        		M1M2M3M4TotalCl-CO2-SO4--Flux Cl
        (g/j)        		Flux C
        (g/j)        		Flux S
        (g/j)        		Flux H2O
        (g/j)        		Solution initialeMasse échantillon (g)Concentrations ($unite) Calculs
        DuAuNb
        jours        		H20
        (ml)        		KOH
        (mol/l)        		M1M2M3M4TotalCl-CO2-SO4--Flux Cl
        (g/j)        		Flux C
        (g/j)        		Flux S
        (g/j)        		Flux H2O
        (g/j)
        $nhtm
        $dthm
        $nhtm
        $dthm
        $rapv[$iv]
        $modif$date1$date2$nj$lien$h2o$koh$m1$m2$m3$m4$mtot$cCl_mmol$cCO2_mmol$cSO4_mmol$cCl$cCO2$cSO4$f_Cl$f_C$f_S$f_H2O"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."
        $rapv[$iv]
        $modif$date1$date2$nj$lien$h2o$koh$m1$m2$m3$m4$mtot$cCl_mmol$cCO2_mmol$cSO4_mmol$cCl$cCO2$cSO4$f_Cl$f_C$f_S$f_H2O"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."
        $entete\n$texte\n$entete\n
        "); + push(@html,"$entete\n$texte\n$entete\n
        "); } # Time to display (or download csv) # push(@html,"
        \n\n\n"); if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; + print @html; } __END__ diff --git a/CODE/cgi-bin/showDISTANCE.pl b/CODE/cgi-bin/showDISTANCE.pl index cfc59de8..c292eb93 100755 --- a/CODE/cgi-bin/showDISTANCE.pl +++ b/CODE/cgi-bin/showDISTANCE.pl @@ -88,20 +88,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -148,10 +148,10 @@ =head1 Query string parameters # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/csv\n\n"); @@ -159,62 +159,62 @@ =head1 Query string parameters # ---- start html if not csv output requested if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
        Recherche des données, merci de patienter.
        ", - "
        \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "
        \n", + "\n", + "\n"; } # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print("
        conf('CGI_SHOW')."\" method=\"get\">", - "

        ", - "Sélectionner: \n", - "\n", - "", - " "); - if ($editOK) { - print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); - } - print "

        \n", - "

        ".$FORM->conf('TITLE')."

        \n", - "

        Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
        ", - "Sites sélectionnés: $afficheSite
        "; + print("

        conf('CGI_SHOW')."\" method=\"get\">", + "

        ", + "Sélectionner: \n", + "\n", + "", + " "); + if ($editOK) { + print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + } + print "

        \n", + "

        ".$FORM->conf('TITLE')."

        \n", + "

        Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
        ", + "Sites sélectionnés: $afficheSite
        "; } # ---- Lecture du fichier data dans tableau @lignes @@ -238,113 +238,114 @@ =head1 Query string parameters $entete = "

        DateSiteAEMDInfos TourelleMesures de distance: D0 (m) + dn (mm)Moyenne (m)
        Patm
        (mmHg)        		Tair
        (°C)        		H.R.
        (%)        		NébulVitreD0
        (m)"; + ."        		AEMDInfos TourelleMesures de distance: D0 (m) + dn (mm)Moyenne (m)
        Patm
        (mmHg)        		Tair
        (°C)        		H.R.
        (%)        		NébulVitreD0
        (m)"; for ("01".."20") { $entete = $entete."        		d$_x2σ
        $modif$date $heure$lien$aemd$pAtm$tAir$HR$nebul$vitre$d0$d[$_]".sprintf("%1.3f",$DM).""; - } elsif ($DS > 0.02 ) { - $texte .= ""; - } else { - $texte .= ""; - } - $texte .= sprintf("%1.3f",$DS).""; - $txt = "$date;$heure;$site;$aliasSite;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;$DM;$DS;"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."
        $modif$date $heure$lien$aemd$pAtm$tAir$HR$nebul$vitre$d0$d[$_]".sprintf("%1.3f",$DM).""; + } elsif ($DS > 0.02 ) { + $texte .= ""; + } else { + $texte .= ""; + } + $texte .= sprintf("%1.3f",$DS).""; + $txt = "$date;$heure;$site;$aliasSite;$aemd;$pAtm;$tAir;$HR;$nebul;$vitre;$DM;$DS;"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."
        $entete\n$texte\n$entete\n
        ", - "

        Types de Distancemètres: "); - for (@types) { - my ($tpi,$tpn) = split(/\|/,$_); - push(@html,"$tpi = $tpn, "); - } - push(@html,"\n

        Nébulosité: "); - for (@meteo) { - my ($tpi,$tpn) = split(/\|/,$_); - push(@html,"$tpi = $tpn, "); - } - push(@html,"

        \n"); + push(@html,"$entete\n$texte\n$entete\n
        ", + "

        Types de Distancemètres: "); + for (@types) { + my ($tpi,$tpn) = split(/\|/,$_); + push(@html,"$tpi = $tpn, "); + } + push(@html,"\n

        Nébulosité: "); + for (@meteo) { + my ($tpi,$tpn) = split(/\|/,$_); + push(@html,"$tpi = $tpn, "); + } + push(@html,"

        \n"); } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/showEAUX.pl b/CODE/cgi-bin/showEAUX.pl index 6ac00e91..f2128ea1 100755 --- a/CODE/cgi-bin/showEAUX.pl +++ b/CODE/cgi-bin/showEAUX.pl @@ -128,21 +128,21 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (sort keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # ---- DateTime inits ---------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $day = strftime('%d',@tod); -my $month = strftime('%m',@tod); +my $day = strftime('%d',@tod); +my $month = strftime('%m',@tod); my $year = strftime('%Y',@tod); my $endDate = strftime('%F',@tod); my $delay = $FORM->conf('DEFAULT_DAYS') // 30; @@ -171,12 +171,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$year) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamUnite = ("ppm|en ppm","mmol|en mmol/l"); my @cleParamSite; @@ -186,18 +186,18 @@ =head1 Query string parameters my $nbRap = 0; my @rapCalc; -$QryParm->{'y1'} //= $y1; -$QryParm->{'m1'} //= $m1; -$QryParm->{'d1'} //= $d1; -$QryParm->{'y2'} //= $year; -$QryParm->{'m2'} //= $month; -$QryParm->{'d2'} //= $day; -$QryParm->{'node'} //= "All"; -$QryParm->{'iode'} //= ""; -$QryParm->{'sio2'} //= ""; -$QryParm->{'isotopes'} //= ""; -$QryParm->{'affiche'} //= ""; -$QryParm->{'unite'} //= "ppm"; +$QryParm->{'y1'} //= $y1; +$QryParm->{'m1'} //= $m1; +$QryParm->{'d1'} //= $d1; +$QryParm->{'y2'} //= $year; +$QryParm->{'m2'} //= $month; +$QryParm->{'d2'} //= $day; +$QryParm->{'node'} //= "All"; +$QryParm->{'iode'} //= ""; +$QryParm->{'sio2'} //= ""; +$QryParm->{'isotopes'} //= ""; +$QryParm->{'affiche'} //= ""; +$QryParm->{'unite'} //= "ppm"; if ($QryParm->{'unite'} eq "ppm") {$unite = "ppm = mg/l"} else {$unite = "mmol/l"} $startDate = "$QryParm->{'y1'}-$QryParm->{'m1'}-$QryParm->{'d1'}"; @@ -207,20 +207,20 @@ =head1 Query string parameters # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } $i = 0; for (@rapports) { - $i++; - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } + $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } } # ---- @@ -230,87 +230,87 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
        Recherche des données, merci de patienter.
        ", - "
        \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "
        \n", + "\n", + "\n"; } # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'affiche'} ne "csv") { - print "
        conf('CGI_SHOW')."\" method=\"get\">", - "

        ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  \n", - "", - " ", - " "); - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('return_url' => $return_url); - print qq(); - } - print("
        \n"); - print("{'iode'} ne ""? " checked":"").">Iode  "); - print("{'sio2'} ne ""? " checked":"").">SiO2  "); - print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); - print("  \n$__{'Ratios'}: "); - - $i = 0; - for (@rapports) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - $i++; - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print("$nhtm/$dhtm  "); - } - print "

        \n", - "

        ".$FORM->conf('TITLE')."

        \n", - "

        "; + print "

        conf('CGI_SHOW')."\" method=\"get\">", + "

        ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  \n", + "", + " ", + " "); + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('return_url' => $return_url); + print qq(); + } + print("
        \n"); + print("{'iode'} ne ""? " checked":"").">Iode  "); + print("{'sio2'} ne ""? " checked":"").">SiO2  "); + print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); + print("  \n$__{'Ratios'}: "); + + $i = 0; + for (@rapports) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + $i++; + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print("$nhtm/$dhtm  "); + } + print "

        \n", + "

        ".$FORM->conf('TITLE')."

        \n", + "

        "; } # ---- Read the data file @@ -330,185 +330,186 @@ =head1 Query string parameters $entete = "

        DateSite
        (Type)        		Mesures sur siteCations ($unite)Anions ($unite)AutresIsotopes Calculs
        T air
        (°C)        		T eau
        (°C)        		pHDébit
        (l/min)        		Cond
        (µS)        		Niveau
        (m)        		Li+Na+K+Mg++Ca++F-Cl-Br-NO3-SO4--HCO3-I-".($QryParm->{'unite'} ne "mmol" ? "
        (ppb)":"")."        		SiO2".($QryParm->{'unite'} ne "mmol" ? "
        (ppb)":"")."        		δ13Cδ18OδDCond25
        (μS)        		NICB
        (%)        		Site
        (Type)        		Mesures sur siteCations ($unite)Anions ($unite)AutresIsotopes Calculs
        T air
        (°C)        		T eau
        (°C)        		pHDébit
        (l/min)        		Cond
        (µS)        		Niveau
        (m)        		Li+Na+K+Mg++Ca++F-Cl-Br-NO3-SO4--HCO3-I-".($QryParm->{'unite'} ne "mmol" ? "
        (ppb)":"")."        		SiO2".($QryParm->{'unite'} ne "mmol" ? "
        (ppb)":"")."        		δ13Cδ18OδDCond25
        (μS)        		NICB
        (%)
        $nhtm
        $dthm
        $nhtm
        $dthm
        $rapv[$iv]
        $modif$date $heure$lien $type$tAir$tSource$pH$debit$cond$niveau"; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= "$cLi$cNa$cK$cMg$cCa$cF$cCl$cBr$cNO3$cSO4$cHCO3$cI$cSiO2$d13C$d18O$dD$cond25"; - } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= ""; - #$texte = $texte."$so4_cl$hco3_cl$ca_cl"; - $txt = $txt."$d13C;$d18O;$dD;$cond25;$nicb;\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."
        $rapv[$iv]
        $modif$date $heure$lien $type$tAir$tSource$pH$debit$cond$niveau"; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= "$cLi$cNa$cK$cMg$cCa$cF$cCl$cBr$cNO3$cSO4$cHCO3$cI$cSiO2$d13C$d18O$dD$cond25"; + } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= ""; + +#$texte = $texte."$so4_cl$hco3_cl$ca_cl"; + $txt = $txt."$d13C;$d18O;$dD;$cond25;$nicb;\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."
        $entete\n$texte\n$entete\n
        ", - "

        Types of sites: "); - for (sort(keys(%types))) { - push(@html,"$_ = $types{$_}{name}, "); - } - push(@html,"

        "); + push(@html,"$entete\n$texte\n$entete\n
        ", + "

        Types of sites: "); + for (sort(keys(%types))) { + push(@html,"$_ = $types{$_}{name}, "); + } + push(@html,"

        "); } push(@html,@notes); if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/showEXTENSO.pl b/CODE/cgi-bin/showEXTENSO.pl index c452c8c2..acebb067 100755 --- a/CODE/cgi-bin/showEXTENSO.pl +++ b/CODE/cgi-bin/showEXTENSO.pl @@ -91,18 +91,18 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -144,23 +144,23 @@ =head1 Query string parameters # ---- Get most recent date, needed when using default dates range my (@dd) = split(/\|/,$lignes[$#lignes - 1]); my $lastDate = $dd[1]; -my ($lastY,$lastM,$lastD) = split(/-/,$lastDate); +my ($lastY,$lastM,$lastD) = split(/-/,$lastDate); # get query-string parameters # --------------------------------------------------------------- if ($QP->{y1} && $QP->{m1} && $QP->{d1} && $QP->{y2} && $QP->{m2} && $QP->{d2} ) { - $dateStart = "$QP->{y1}-$QP->{m1}-$QP->{d1}" ; - $dateEnd = "$QP->{y2}-$QP->{m2}-$QP->{d2}"; - my $nbJours = sprintf("%1.0f",(qx(date -d "$dateEnd" +%s) - qx(date -d "$dateStart" +%s))/86400 + 1); - $afficheDates = "$dateStart à $dateEnd ($nbJours jours)"; + $dateStart = "$QP->{y1}-$QP->{m1}-$QP->{d1}" ; + $dateEnd = "$QP->{y2}-$QP->{m2}-$QP->{d2}"; + my $nbJours = sprintf("%1.0f",(qx(date -d "$dateEnd" +%s) - qx(date -d "$dateStart" +%s))/86400 + 1); + $afficheDates = "$dateStart à $dateEnd ($nbJours jours)"; } else { - my $u = $FORM->conf('DELAY'); - $dateEnd = $lastDate; - $dateStart = qx(date -d "$dateEnd $u days ago" +"%Y-%m-%d"); - chomp($dateStart); - ($QP->{y1},$QP->{m1},$QP->{d1}) = split(/-/,$dateStart); - ($QP->{y2},$QP->{m2},$QP->{d2}) = split(/-/,$dateEnd); - $afficheDates = "$dateStart à $dateEnd (défaut = ".$FORM->conf('DELAY')." derniers jours de mesures)"; + my $u = $FORM->conf('DELAY'); + $dateEnd = $lastDate; + $dateStart = qx(date -d "$dateEnd $u days ago" +"%Y-%m-%d"); + chomp($dateStart); + ($QP->{y1},$QP->{m1},$QP->{d1}) = split(/-/,$dateStart); + ($QP->{y2},$QP->{m2},$QP->{d2}) = split(/-/,$dateEnd); + $afficheDates = "$dateStart à $dateEnd (défaut = ".$FORM->conf('DELAY')." derniers jours de mesures)"; } $QP->{'site'} ||= "Tout"; @@ -171,10 +171,10 @@ =head1 Query string parameters # my @gridsites; if ($QP->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -182,21 +182,21 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QP->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
        Recherche des données, merci de patienter.
        ", - "
        \n", - "\n", - "\n"; - - # Javascript for selection's form - print <<"FIN"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "
        \n", + "\n", + "\n"; + + # Javascript for selection's form + print <<"FIN"; \n", + "\n", + + print <<"FIN"; \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "$titrePage\n", + "", + "\n"; + + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "\n", + "
        \n", + "\n", + "\n", + "\n"; } # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print "
        conf('CGI_SHOW')."\" method=\"get\">", - "

        ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  \n", - " ", - " "; - if ($clientAuth > 1) { - print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; - } - print("
        \n"); - print "Sampling type:   "); - print("{'radon'} ne ""? " checked":"").">Rn  "); - print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); - print "

        \n", - "

        ".$FORM->conf('TITLE')."

        \n", - "

        "; + print "

        conf('CGI_SHOW')."\" method=\"get\">", + "

        ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  \n", + " ", + " "; + if ($clientAuth > 1) { + print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; + } + print("
        \n"); + print "Sampling type:   "); + print("{'radon'} ne ""? " checked":"").">Rn  "); + print("{'isotopes'} ne ""? " checked":"").">$__{'Isotopes'}  "); + print "

        \n", + "

        ".$FORM->conf('TITLE')."

        \n", + "

        "; } # ---- Read the data file @@ -283,95 +283,95 @@ =head1 Query string parameters $entete = ""; if ($clientAuth > 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."DateSite" - ."On-site measurementsTypeConcentrations (%)" - .($QryParm->{'radon'} ne "" ? "Rn
        (cp/mn)":"") - .($QryParm->{'isotopes'} ne "" ? "Isotopes":"") - ."S/C\n" - ."T (°C)pHFlux" - ."H2HeCOCH4N2H2SArCO2SO2O2" - .($QryParm->{'isotopes'} ne ""? "δ13Cδ18O":""); - + ."On-site measurementsTypeConcentrations (%)" + .($QryParm->{'radon'} ne "" ? "Rn
        (cp/mn)":"") + .($QryParm->{'isotopes'} ne "" ? "Isotopes":"") + ."S/C\n" + ."T (°C)pHFlux" + ."H2HeCOCH4N2H2SArCO2SO2O2" + .($QryParm->{'isotopes'} ne ""? "δ13Cδ18O":""); + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$site,$tFum,$pH,$debit,$Rn,$type,$H2,$He,$CO,$CH4,$N2,$H2S,$Ar,$CO2,$SO2,$O2,$d13C,$d18O,$rem,$val) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,u2l("$date;$heure;Code Site;$site;$tFum;$pH;$debit;$type;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;S/C;\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) - && ($QryParm->{'ampoule'} eq "" || $type eq $QryParm->{'ampoule'}) - && ($id > 0 || $clientAuth == 4) - && ($date le $endDate) && ($date ge $startDate)) { - - my $S_C = ""; - if (($CO2 != 0) && ($type ne "NaOH")) { - $S_C = sprintf("%1.2f",($SO2 + $H2S)/$CO2); - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$date $heure$lien" - ."$tFum$pH$debit$types{$type}{name}" - ."$H2$He$CO$CH4" - ."$N2$H2S$Ar$CO2" - ."$SO2$O2" - .($QryParm->{'radon'} ne "" ? "$Rn":"") - .($QryParm->{'isotopes'} ne "" ? "$d13C$d18O":"") - ."$S_C"; - $txt = "$date;$heure;$site;$aliasSite;$tFum;$pH;$debit;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;$S_C"; - $txt = $txt."\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $rem = l2u($rem); - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$site,$tFum,$pH,$debit,$Rn,$type,$H2,$He,$CO,$CH4,$N2,$H2S,$Ar,$CO2,$SO2,$O2,$d13C,$d18O,$rem,$val) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,u2l("$date;$heure;Code Site;$site;$tFum;$pH;$debit;$type;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;S/C;\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) + && ($QryParm->{'ampoule'} eq "" || $type eq $QryParm->{'ampoule'}) + && ($id > 0 || $clientAuth == 4) + && ($date le $endDate) && ($date ge $startDate)) { + + my $S_C = ""; + if (($CO2 != 0) && ($type ne "NaOH")) { + $S_C = sprintf("%1.2f",($SO2 + $H2S)/$CO2); + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$date $heure$lien" + ."$tFum$pH$debit$types{$type}{name}" + ."$H2$He$CO$CH4" + ."$N2$H2S$Ar$CO2" + ."$SO2$O2" + .($QryParm->{'radon'} ne "" ? "$Rn":"") + .($QryParm->{'isotopes'} ne "" ? "$d13C$d18O":"") + ."$S_C"; + $txt = "$date;$heure;$site;$aliasSite;$tFum;$pH;$debit;$H2;$He;$CO;$CH4;$N2;$H2S;$Ar;$CO2;$SO2;$O2;$Rn;$d13C;$d18O;$S_C"; + $txt = $txt."\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $rem = l2u($rem); + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Number of records = $nbLignesRetenues / $nbData.

        \n", - "

        Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&oule=$QryParm->{'ampoule'}\">$fileCSV

        \n"); + "

        Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&oule=$QryParm->{'ampoule'}\">$fileCSV

        \n"); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
        ", - "

        Types d'Ampoules: "); - for (keys(%types)) { - push(@html,"$types{$_}{name} = $_, "); - } - push(@html,"\n

        Débits: "); - for (keys(%debits)) { - push(@html,"$debits{$_} = $_, "); - } - push(@html,"

        \n"); + push(@html,"$entete\n$texte\n$entete\n
        ", + "

        Types d'Ampoules: "); + for (keys(%types)) { + push(@html,"$types{$_}{name} = $_, "); + } + push(@html,"\n

        Débits: "); + for (keys(%debits)) { + push(@html,"$debits{$_} = $_, "); + } + push(@html,"

        \n"); } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/showGENFORM.pl b/CODE/cgi-bin/showGENFORM.pl index d5c44b0a..3c6406d9 100755 --- a/CODE/cgi-bin/showGENFORM.pl +++ b/CODE/cgi-bin/showGENFORM.pl @@ -1,6 +1,5 @@ #!/usr/bin/perl - =head1 NAME showGENFORM.pl @@ -62,7 +61,6 @@ =head1 Query string parameters use Locale::TextDomain('webobs'); use WebObs::Form; - # Keep the URL where the user should be returned after edition # (this will keep the filters selected by the user) my $return_url = $cgi->url(-query_string => 1); @@ -79,8 +77,8 @@ =head1 Query string parameters # ---- DateTime inits ---------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $day = strftime('%d',@tod); -my $month = strftime('%m',@tod); +my $day = strftime('%d',@tod); +my $month = strftime('%m',@tod); my $year = strftime('%Y',@tod); my $today = strftime('%F',@tod); my $default_days = $FORM{DEFAULT_DAYS} // 30; @@ -88,31 +86,31 @@ =head1 Query string parameters # ---- get CGI parameters my $QryParm = $cgi->Vars; -$QryParm->{'y1'} //= $y1; -$QryParm->{'m1'} //= $m1; -$QryParm->{'d1'} //= $d1; -$QryParm->{'y2'} //= $year; -$QryParm->{'m2'} //= $month; -$QryParm->{'d2'} //= $day; -$QryParm->{'node'} //= ""; +$QryParm->{'y1'} //= $y1; +$QryParm->{'m1'} //= $m1; +$QryParm->{'d1'} //= $d1; +$QryParm->{'y2'} //= $year; +$QryParm->{'m2'} //= $month; +$QryParm->{'d2'} //= $day; +$QryParm->{'node'} //= ""; $QryParm->{'trash'} //= "0"; -$QryParm->{'dump'} //= ""; -$QryParm->{'debug'} //= ""; +$QryParm->{'dump'} //= ""; +$QryParm->{'debug'} //= ""; -my $re = $QryParm->{'filter'}; +my $re = $QryParm->{'filter'}; my %Ns; my @NODESSelList; my %Ps = $F->procs; for my $p (sort keys(%Ps)) { - if ($QryParm->{'node'} =~ /^$|^PROC\.$p(\.|$)/) { - push(@NODESSelList,"PROC.$p|-- {PROC.$p} $Ps{$p} --"); - my %N = $F->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"PROC.$p.$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); - } + if ($QryParm->{'node'} =~ /^$|^PROC\.$p(\.|$)/) { + push(@NODESSelList,"PROC.$p|-- {PROC.$p} $Ps{$p} --"); + my %N = $F->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"PROC.$p.$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); + } } my @validity = split(/[, ]/, ($FORM{VALIDITY_COLORS} ? $FORM{VALIDITY_COLORS}:"#66FF66,#FFD800,#FFAAAA")); @@ -121,12 +119,12 @@ =head1 Query string parameters my @formulas; my @thresh; foreach (sort keys %FORM) { - if ($_ =~ /^OUTPUT.*_TYPE/ && $FORM{$_} =~ /^formula/) { - push(@formulas, (split /_TYPE/, $_)[0]); - } - if ($_ =~ /^(IN|OUT)PUT.*_THRESHOLD/) { - push(@thresh, (split /_THRESHOLD/, $_)[0]); - } + if ($_ =~ /^OUTPUT.*_TYPE/ && $FORM{$_} =~ /^formula/) { + push(@formulas, (split /_TYPE/, $_)[0]); + } + if ($_ =~ /^(IN|OUT)PUT.*_THRESHOLD/) { + push(@thresh, (split /_THRESHOLD/, $_)[0]); + } } # ---- specific FORMS inits ---------------------------------- @@ -146,36 +144,35 @@ =head1 Query string parameters my $delay = datediffdays($startDate,$endDate); # ---- a site requested as PROC.name means "all nodes for proc 'name'" - + my @procnodes; if ($QryParm->{'node'} =~ /^PROC\.([^.]*)$/) { - my %tmpN = $F->nodes($1); - for (keys(%tmpN)) { - push(@procnodes,"$_"); - } + my %tmpN = $F->nodes($1); + for (keys(%tmpN)) { + push(@procnodes,"$_"); + } } if ($QryParm->{'node'} =~ /^PROC\.[^.]*\.(.*)$/) { - push(@procnodes,"$1"); + push(@procnodes,"$1"); } - # ---- start html if not CSV output if ($QryParm->{'dump'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM{TITLE}."\n", - "", - "\n"; - - print "\n", - "\n", - "
        $__{'Searching for data, please wait.'}
        \n", - "
        \n", - "\n", - "\n"; - - print <<"EOF"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM{TITLE}."\n", + "", + "\n"; + + print "\n", + "\n", + "
        $__{'Searching for data, please wait.'}
        \n", + "
        \n", + "\n", + "\n"; + + print <<"EOF"; EOF } else { - push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/csv\n\n"); + push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/csv\n\n"); } # ---- Read the data file @@ -215,20 +212,20 @@ =head1 Query string parameters # make an hash of hash of input type lists my %lists; foreach my $k (@rownames) { - my $list = $FORM{uc("$k")."_TYPE"}; - if ($list =~ /^list:/) { - my %l = extract_list($list,$form); - $lists{$k} = {%l}; - } + my $list = $FORM{uc("$k")."_TYPE"}; + if ($list =~ /^list:/) { + my %l = extract_list($list,$form); + $lists{$k} = {%l}; + } } # get the requested data my $filter = "((sdate BETWEEN '$startDate' AND '$endDate') OR (edate BETWEEN '$startDate' AND '$endDate'))"; $filter .= " AND trash = false" if (!$QryParm->{'trash'}); -$filter .= " AND node IN ('".join("','",@procnodes)."')" if ($#procnodes >= 0); +$filter .= " AND node IN ('".join("','",@procnodes)."')" if ($#procnodes >= 0); foreach (keys %lists) { - my $sel_list = $QryParm->{$_}; - $filter .= " AND $_ = \"$sel_list\"" if ($sel_list ne ""); + my $sel_list = $QryParm->{$_}; + $filter .= " AND $_ = \"$sel_list\"" if ($sel_list ne ""); } $filter .= " AND comment REGEXP '$re'" if ($re ne ""); $stmt = qq(SELECT * FROM $tbl WHERE $filter ORDER BY edate DESC;); @@ -237,7 +234,7 @@ =head1 Query string parameters my @rows; while(my @row = $sth->fetchrow_array()) { - push(@rows, \@row); + push(@rows, \@row); } $dbh->disconnect(); @@ -250,100 +247,100 @@ =head1 Query string parameters my @field_names; foreach(@fieldsets) { - push(@fs_names, $FORM{"$_\_NAME"}); - my @fieldset; - for (my $i = 0; $i <= $FORM{"$_\_CELLS"}; $i++) { - my @fields; - foreach (split(/,/, $FORM{sprintf("$_\_C%02d",$i)})) { - my ($size, $default) = extract_type($FORM{$_."_TYPE"}); - if ($size ne "0" && ! ($_ =~ /^OUTPUT/ && $FORM{$_."_TYPE"} =~ /^text/)) { - push(@fields, $_); - } - } - push(@fieldset, @fields); - } - push(@field_names, \@fieldset); + push(@fs_names, $FORM{"$_\_NAME"}); + my @fieldset; + for (my $i = 0; $i <= $FORM{"$_\_CELLS"}; $i++) { + my @fields; + foreach (split(/,/, $FORM{sprintf("$_\_C%02d",$i)})) { + my ($size, $default) = extract_type($FORM{$_."_TYPE"}); + if ($size ne "0" && ! ($_ =~ /^OUTPUT/ && $FORM{$_."_TYPE"} =~ /^text/)) { + push(@fields, $_); + } + } + push(@fieldset, @fields); + } + push(@field_names, \@fieldset); } # ---- Form for display selection # if ($QryParm->{'dump'} ne "csv") { - print "
        ", - ""; - print "

        ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  "; - print " "; - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); - $form_url->query_form('form' => $form, 'return_url' => $return_url, 'action' => 'new'); - print qq(); - } - print "
        \n"; - print " "; - if ($re ne "") { - print ""; - } - print " \n"; - foreach my $i (sort keys %lists) { - if (isok($FORM{uc($i)."_FILT"})) { - my @key = keys %{$lists{$i}}; - print "".$FORM{uc($i)."_NAME"}.": \n"; - } - } - foreach (@fieldsets) { - if (isok($FORM{$_.'_TOGGLE'})) { - my $fs = lc($_); - print " {$fs} ? " checked":"")."> $FORM{$_.'_NAME'}"; - } - } - - if ($clientAuth > 1) { - print " {'trash'} ? " checked":"")."> $__{'Trash'}"; - } else { - print " "; - } - print "

        \n", - "

        ".$FORM{TITLE}."$editForm

        \n", - "

        "; + print "

        ", + ""; + print "

        ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  "; + print " "; + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); + $form_url->query_form('form' => $form, 'return_url' => $return_url, 'action' => 'new'); + print qq(); + } + print "
        \n"; + print " "; + if ($re ne "") { + print ""; + } + print " \n"; + foreach my $i (sort keys %lists) { + if (isok($FORM{uc($i)."_FILT"})) { + my @key = keys %{$lists{$i}}; + print "".$FORM{uc($i)."_NAME"}.": \n"; + } + } + foreach (@fieldsets) { + if (isok($FORM{$_.'_TOGGLE'})) { + my $fs = lc($_); + print " {$fs} ? " checked":"")."> $FORM{$_.'_NAME'}"; + } + } + + if ($clientAuth > 1) { + print " {'trash'} ? " checked":"")."> $__{'Trash'}"; + } else { + print " "; + } + print "

        \n", + "

        ".$FORM{TITLE}."$editForm

        \n", + "

        "; } # ---- Displaying data @@ -360,151 +357,153 @@ =head1 Query string parameters my @colnam2; my %colspan; if ($starting_date) { - $colspan{"Sampling Date"} = 2; - push(@colnam2,("Start","End")); - $csvTxt .= '"'.join('","', @colnam2, @colnam[1,2]).'"'; + $colspan{"Sampling Date"} = 2; + push(@colnam2,("Start","End")); + $csvTxt .= '"'.join('","', @colnam2, @colnam[1,2]).'"'; } else { - $csvTxt .= '"'.join('","', @colnam).'"'; + $csvTxt .= '"'.join('","', @colnam).'"'; } for (my $i = 0; $i <= $#fs_names; $i++) { - my $fs = $fieldsets[$i]; - my $showfs = ((!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}) ? "1":"0"); - push(@colnam, $fs_names[$i]) if ($showfs); - my $nb_fields = $#{$field_names[$i]}; - $colspan{$fs_names[$i]} = $nb_fields+1; - for (my $j = 0; $j <= $nb_fields; $j++) { - my $field = $field_names[$i][$j]; - my $name_field = htm2frac($FORM{"$field\_NAME"}); - my $unit_field = $FORM{"$field\_UNIT"}; - push(@colnam2, "$name_field".($unit_field ne "" ? " ($unit_field)":"")) if ($showfs); - $name_field =~ s/(|<\/su[bp]>|\&[^;]*;)//g; - $csvTxt .= ',"'.u2l($name_field).'"'; - } + my $fs = $fieldsets[$i]; + my $showfs = ((!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}) ? "1":"0"); + push(@colnam, $fs_names[$i]) if ($showfs); + my $nb_fields = $#{$field_names[$i]}; + $colspan{$fs_names[$i]} = $nb_fields+1; + for (my $j = 0; $j <= $nb_fields; $j++) { + my $field = $field_names[$i][$j]; + my $name_field = htm2frac($FORM{"$field\_NAME"}); + my $unit_field = $FORM{"$field\_UNIT"}; + push(@colnam2, "$name_field".($unit_field ne "" ? " ($unit_field)":"")) if ($showfs); + $name_field =~ s/(|<\/su[bp]>|\&[^;]*;)//g; + $csvTxt .= ',"'.u2l($name_field).'"'; + } } $csvTxt .= "\n"; $header = "".($clientAuth > 1 ? "\n":""); -foreach(@colnam) { - $header .= "$_\n"; +foreach(@colnam) { + $header .= "$_\n"; } $header .= "\n"; foreach(@colnam2) { - $header .= "".$_."\n"; + $header .= "".$_."\n"; } $header .= "\n"; for (my $j = 0; $j <= $#rows; $j++) { - my ($id, $trash, $site, $edate0, $edate1, $sdate0, $sdate1, $opers, $rem, $ts0, $user) = ($rows[$j][0],$rows[$j][1],$rows[$j][2],$rows[$j][3],$rows[$j][4],$rows[$j][5],$rows[$j][6],$rows[$j][7],$rows[$j][-3],$rows[$j][-2],$rows[$j][-1]); - - # makes a hash of all fields values (input and output) - my %fields; - # stores input db rows - for (my $i = 8; $i <= $#{$rows[$j]}; $i++) { - $fields{$rownames[$i]} = $rows[$j][$i]; - } - # stores formulas - foreach (@formulas) { - my ($formula, $size, @x) = extract_formula($FORM{$_."_TYPE"}); - my $nan = 0; - foreach (@x) { - my $f = lc($_); - $formula =~ s/$_/\$fields{$f}/g; - } - my $res = eval($formula); - if ($res ne "") { - if ($size > 0) { - $fields{lc($_)} = roundsd($res, $size - 3); # results is rounded with $size-3 digits - } else { - $fields{lc($_)} = $res; # hidden formula - } - } else { - $fields{lc($_)} = ""; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $edate = simplify_date($edate0,$edate1); - my $sdate = simplify_date($sdate0,$sdate1); - - my $nameSite = htmlspecialchars(getNodeString(node=>$site,style=>'html')); - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $nodelink = "$aliasSite"; - } else { - $nodelink = "$aliasSite"; - } - my @operators = split(/,/,$opers); - my @nameOper; - foreach (@operators) { - push(@nameOper, "$_: ".join('',WebObs::Users::userName($_))); - } - my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); - $form_url->query_form('form' => $form, 'id' => $id, 'return_url' => $return_url, 'action' => 'edit'); - $edit = qq(); - $delete = qq(); - - $text .= ""; - if ($clientAuth > 1) { - $text .= "$edit"; - } - $text .= ($starting_date ? "$sdate":"")."$edate"; - $text .= "$nodelink \n"; - $text .= "',@nameOper)."')\">".join(', ',@operators)."\n"; - $csvTxt .= "$id,$sdate,$edate,\"$aliasSite\",\"$opers\","; - for (my $f = 0; $f <= $#fieldsets; $f++) { - my $fs = $fieldsets[$f]; - my $nb_fields = $#{$field_names[$f]}; - for (my $n = 0; $n <= $nb_fields; $n++) { - my $Field = $field_names[$f][$n]; - my $field = lc($Field); - my $opt; - my $val = $fields{$field}; - my $hlp; - if (defined $lists{$field}) { - if (ref $lists{$field}{$fields{$field}}) { - my %v = %{$lists{$field}{$fields{$field}}}; # list is a HoH - $hlp = "$fields{$field}: $v{name}"; - if ($v{icon}) { - $val = ""; - } - } else { - $hlp = "$fields{$field}: $lists{$field}{$fields{$field}}"; - } - $hlp = "$__{'unknown key list!'}" if ($val eq ""); - $opt = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$hlp')\""; - } - if (grep(/^$field$/i, @formulas)) { - $opt = " class=\"tdResult\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$field:')\""; - } - if (grep(/^$Field$/, @thresh) ) { - my @tv = split(/[, ]/,$FORM{$Field."_THRESHOLD"}); - if (abs($fields{$field}) >= $tv[0] && abs($fields{$field}) < $tv[1]) { - $opt .= " style=\"background-color:$validity[1]\""; - } elsif (abs($fields{$field}) >= $tv[1]) { - $opt .= " style=\"background-color:$validity[2]\""; - } - } - $text .= "$val\n" if (!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}); - $csvTxt .= "$fields{$field},"; - } - } - $csvTxt .= ",\"".u2l($rem)."\"\n"; - my $remTxt = ""; - if ($rem ne "") { - $remTxt = ""; - } - $text .= "$remTxt\n"; + my ($id, $trash, $site, $edate0, $edate1, $sdate0, $sdate1, $opers, $rem, $ts0, $user) = ($rows[$j][0],$rows[$j][1],$rows[$j][2],$rows[$j][3],$rows[$j][4],$rows[$j][5],$rows[$j][6],$rows[$j][7],$rows[$j][-3],$rows[$j][-2],$rows[$j][-1]); + + # makes a hash of all fields values (input and output) + my %fields; + + # stores input db rows + for (my $i = 8; $i <= $#{$rows[$j]}; $i++) { + $fields{$rownames[$i]} = $rows[$j][$i]; + } + + # stores formulas + foreach (@formulas) { + my ($formula, $size, @x) = extract_formula($FORM{$_."_TYPE"}); + my $nan = 0; + foreach (@x) { + my $f = lc($_); + $formula =~ s/$_/\$fields{$f}/g; + } + my $res = eval($formula); + if ($res ne "") { + if ($size > 0) { + $fields{lc($_)} = roundsd($res, $size - 3); # results is rounded with $size-3 digits + } else { + $fields{lc($_)} = $res; # hidden formula + } + } else { + $fields{lc($_)} = ""; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $edate = simplify_date($edate0,$edate1); + my $sdate = simplify_date($sdate0,$sdate1); + + my $nameSite = htmlspecialchars(getNodeString(node=>$site,style=>'html')); + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $nodelink = "$aliasSite"; + } else { + $nodelink = "$aliasSite"; + } + my @operators = split(/,/,$opers); + my @nameOper; + foreach (@operators) { + push(@nameOper, "$_: ".join('',WebObs::Users::userName($_))); + } + my $form_url = URI->new("/cgi-bin/formGENFORM.pl"); + $form_url->query_form('form' => $form, 'id' => $id, 'return_url' => $return_url, 'action' => 'edit'); + $edit = qq(); + $delete = qq(); + + $text .= ""; + if ($clientAuth > 1) { + $text .= "$edit"; + } + $text .= ($starting_date ? "$sdate":"")."$edate"; + $text .= "$nodelink \n"; + $text .= "',@nameOper)."')\">".join(', ',@operators)."\n"; + $csvTxt .= "$id,$sdate,$edate,\"$aliasSite\",\"$opers\","; + for (my $f = 0; $f <= $#fieldsets; $f++) { + my $fs = $fieldsets[$f]; + my $nb_fields = $#{$field_names[$f]}; + for (my $n = 0; $n <= $nb_fields; $n++) { + my $Field = $field_names[$f][$n]; + my $field = lc($Field); + my $opt; + my $val = $fields{$field}; + my $hlp; + if (defined $lists{$field}) { + if (ref $lists{$field}{$fields{$field}}) { + my %v = %{$lists{$field}{$fields{$field}}}; # list is a HoH + $hlp = "$fields{$field}: $v{name}"; + if ($v{icon}) { + $val = ""; + } + } else { + $hlp = "$fields{$field}: $lists{$field}{$fields{$field}}"; + } + $hlp = "$__{'unknown key list!'}" if ($val eq ""); + $opt = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$hlp')\""; + } + if (grep(/^$field$/i, @formulas)) { + $opt = " class=\"tdResult\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$field:')\""; + } + if (grep(/^$Field$/, @thresh) ) { + my @tv = split(/[, ]/,$FORM{$Field."_THRESHOLD"}); + if (abs($fields{$field}) >= $tv[0] && abs($fields{$field}) < $tv[1]) { + $opt .= " style=\"background-color:$validity[1]\""; + } elsif (abs($fields{$field}) >= $tv[1]) { + $opt .= " style=\"background-color:$validity[2]\""; + } + } + $text .= "$val\n" if (!isok($FORM{$fs.'_TOGGLE'}) || $QryParm->{lc($fs)}); + $csvTxt .= "$fields{$field},"; + } + } + $csvTxt .= ",\"".u2l($rem)."\"\n"; + my $remTxt = ""; + if ($rem ne "") { + $remTxt = ""; + } + $text .= "$remTxt\n"; } if ($QryParm->{'debug'}) { - print("

        y1 = ".$QryParm->{'y1'}.", m1 = ".$QryParm->{'m1'}.", d1 = ".$QryParm->{'d1'}."

        \n"); - print("

        startDate = $startDate, endDate = $endDate, default days = $FORM{DEFAULT_DAYS}

        \n"); - print("

        Columns = ".join(',',@rownames)."

        \n"); - print("

        Formulas = ".join(',',@formulas)."

        \n"); - print("

        Filter = $filter

        \n"); + print("

        y1 = ".$QryParm->{'y1'}.", m1 = ".$QryParm->{'m1'}.", d1 = ".$QryParm->{'d1'}."

        \n"); + print("

        startDate = $startDate, endDate = $endDate, default days = $FORM{DEFAULT_DAYS}

        \n"); + print("

        Columns = ".join(',',@rownames)."

        \n"); + print("

        Formulas = ".join(',',@formulas)."

        \n"); + print("

        Filter = $filter

        \n"); } push(@html,"

        $__{'Genform code'}: FORM.$form
        \n"); push(@html,"$__{'Date interval'} = $delay days.
        \n"); @@ -512,44 +511,42 @@ =head1 Query string parameters push(@html,"

        $__{'Download a CSV text file of these data'}: {'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&trash=$QryParm->{'trash'}&form=$form\">$fileCSV

        \n"); if ($text ne "") { - push(@html,"$header\n$text\n$header\n
        \n"); + push(@html,"$header\n$text\n$header\n
        \n"); } if ($QryParm->{'dump'} eq "csv") { - push(@csv,l2u($csvTxt)); - print @csv; + push(@csv,l2u($csvTxt)); + print @csv; } else { - print @html; - print "\n
        \n\n\n"; } - - sub simplify_date { - my $date0 = shift; - my $date1 = shift; - my ($y0,$m0,$d0,$H0,$M0) = split(/[-: ]/,$date0); - my ($y1,$m1,$d1,$H1,$M1) = split(/[-: ]/,$date1); - my $date = "$y1-$m1-$d1 $H1:$M1"; - if ($date0 eq $date1 || $date1 eq "") { return $date0; } - if ($y1 ne $y0) { $date = "$y0-$y1"; } - elsif ($m1 ne $m0) { $date = "$y1"; } - elsif ($d1 ne $d0) { $date = "$y1-$m1"; } - elsif ($H1 ne $H0) { $date = "$y1-$m1-$d1"; } - elsif ($M1 ne $M0) { $date = "$y1-$m1-$d1 $H1"; } - return $date; + my $date0 = shift; + my $date1 = shift; + my ($y0,$m0,$d0,$H0,$M0) = split(/[-: ]/,$date0); + my ($y1,$m1,$d1,$H1,$M1) = split(/[-: ]/,$date1); + my $date = "$y1-$m1-$d1 $H1:$M1"; + if ($date0 eq $date1 || $date1 eq "") { return $date0; } + if ($y1 ne $y0) { $date = "$y0-$y1"; } + elsif ($m1 ne $m0) { $date = "$y1"; } + elsif ($d1 ne $d0) { $date = "$y1-$m1"; } + elsif ($H1 ne $H0) { $date = "$y1-$m1-$d1"; } + elsif ($M1 ne $M0) { $date = "$y1-$m1-$d1 $H1"; } + return $date; } # Open an SQLite connection to the forms database sub connectDbForms { - return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; + return DBI->connect("dbi:SQLite:$WEBOBS{SQL_FORMS}", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $WEBOBS{SQL_FORMS}: $DBI::errstr"; } __END__ diff --git a/CODE/cgi-bin/showGRID.pl b/CODE/cgi-bin/showGRID.pl index 268f83b6..5ace91f1 100755 --- a/CODE/cgi-bin/showGRID.pl +++ b/CODE/cgi-bin/showGRID.pl @@ -76,7 +76,6 @@ =head1 Query string parameters use WebObs::Mapping; use Locale::TextDomain('webobs'); - # ---- init general-use variables on the way and quit if something's wrong # my $cgi = new CGI; @@ -90,37 +89,37 @@ =head1 Query string parameters my $theiaAuth = isok($WEBOBS{THEIA_USER_FLAG}); my @GID = split(/[\.\/]/, trim(checkParam($cgi->param('grid'), - qr{^(VIEW|PROC)(\.|/)|[a-zA-Z0-9]+$}, "grid") // '')); + qr{^(VIEW|PROC)(\.|/)|[a-zA-Z0-9]+$}, "grid") // '')); my $usrNodes = checkParam($cgi->param('nodes'), qr/^[a-zA-Z]*$/, 'nodes') - // $GRIDS{DEFAULT_NODES_FILTER}; + // $GRIDS{DEFAULT_NODES_FILTER}; my $usrCoord = checkParam($cgi->param('coord'), qr/^[a-zA-Z]*$/, 'coord') - // $GRIDS{DEFAULT_COORDINATES}; + // $GRIDS{DEFAULT_COORDINATES}; my $usrProject = checkParam($cgi->param('project'), qr/^(on|off)?$/, 'project') - // $GRIDS{DEFAULT_PROJECT_FILTER}; + // $GRIDS{DEFAULT_PROJECT_FILTER}; my $usrProcparam = checkParam($cgi->param('procparam'), - qr/^(on|off)?$/, 'procparam') - // $GRIDS{DEFAULT_PROCPARAM_FILTER}; + qr/^(on|off)?$/, 'procparam') + // $GRIDS{DEFAULT_PROCPARAM_FILTER}; my $usrSortby = checkParam($cgi->param('sortby'), qr/^[a-z]*$/, 'sortby') - // "event"; + // "event"; my $usrMap = checkParam($cgi->param('map'), qr/^[0-9]*$/, 'map') // ''; my $usrInvalid = checkParam($cgi->param('invalid'), qr/^(on|off)?$/, 'invalid') // "off"; if (scalar(@GID) == 2) { - ($GRIDType, $GRIDName) = @GID; - my %G; - if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } - elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } - if (%G) { - %GRID = %{$G{$GRIDName}} ; - if ( WebObs::Users::clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $editOK = 1; - } - if ( WebObs::Users::clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $admOK = 1; - } - } else { die "You cannot display $GRIDType.$GRIDName"} - } else { die "Couldn't get $GRIDType.$GRIDName configuration." } + ($GRIDType, $GRIDName) = @GID; + my %G; + if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } + elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } + if (%G) { + %GRID = %{$G{$GRIDName}} ; + if ( WebObs::Users::clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + if ( WebObs::Users::clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $editOK = 1; + } + if ( WebObs::Users::clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $admOK = 1; + } + } else { die "You cannot display $GRIDType.$GRIDName"} + } else { die "Couldn't get $GRIDType.$GRIDName configuration." } } else { die "No valid GRID requested (NOT gridtype.gridname)." } # ---- good, passed all checkings above @@ -131,13 +130,13 @@ =head1 Query string parameters my $procOUTG; my %authUsers; if ($isProc) { - %authUsers = WebObs::Users::resListAuth(type=>'authprocs',name=>$GRIDName); - $procOUTG = '1' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}" ); - $procOUTG = 'events' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_EVENTS}" ); - @procTS = split(/,/,$GRID{TIMESCALELIST}); + %authUsers = WebObs::Users::resListAuth(type=>'authprocs',name=>$GRIDName); + $procOUTG = '1' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}" ); + $procOUTG = 'events' if ( -d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_EVENTS}" ); + @procTS = split(/,/,$GRID{TIMESCALELIST}); } else { - %authUsers = WebObs::Users::resListAuth(type=>'authviews',name=>$GRIDName); - $usrProcparam = ''; + %authUsers = WebObs::Users::resListAuth(type=>'authviews',name=>$GRIDName); + $usrProcparam = ''; } my @domain = split(/\|/,$GRID{DOMAIN}); @@ -152,13 +151,13 @@ =head1 Query string parameters my $localCS = $UTM{GEODETIC_DATUM_LOCAL_NAME}; my $showType = (defined($GRIDS{SHOW_TYPE}) - && ($GRIDS{SHOW_TYPE} eq 'N') - || (defined($GRID{TYPE}) && $GRID{TYPE} eq "")) - ? 0 : 1; + && ($GRIDS{SHOW_TYPE} eq 'N') + || (defined($GRID{TYPE}) && $GRID{TYPE} eq "")) + ? 0 : 1; my $showOwnr = (defined($GRIDS{SHOW_OWNER}) - && ($GRIDS{SHOW_OWNER} eq 'N') - || (defined($GRID{OWNCODE}) && $GRID{OWNCODE} eq "")) - ? 0 : 1; + && ($GRIDS{SHOW_OWNER} eq 'N') + || (defined($GRID{OWNCODE}) && $GRID{OWNCODE} eq "")) + ? 0 : 1; my $today = strftime("%Y-%m-%d", localtime); @@ -171,19 +170,19 @@ =head1 Query string parameters my $statusDB = $NODES{SQL_DB_STATUS} || "$WEBOBS{PATH_DATA_DB}/NODESSTATUS.db"; my $statusNODES; if (-e $statusDB) { - my $dbh = DBI->connect("dbi:SQLite:$statusDB", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) || die "Error connecting to $statusDB: $DBI::errstr"; - $statusNODES = $dbh->selectall_arrayref( - "select * from status where NODE like ? order by UPDATED asc", - undef, "%$grid%"); - if (@$statusNODES == 0) { - $overallStatus = 0; - } + my $dbh = DBI->connect("dbi:SQLite:$statusDB", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) || die "Error connecting to $statusDB: $DBI::errstr"; + $statusNODES = $dbh->selectall_arrayref( + "select * from status where NODE like ? order by UPDATED asc", + undef, "%$grid%"); + if (@$statusNODES == 0) { + $overallStatus = 0; + } } else { - $overallStatus = 0; + $overallStatus = 0; } # ---- Start HTML page @@ -218,11 +217,11 @@ =head1 Query string parameters $ilinks .= " | "; $ilinks .= " | + .($WEBOBS{OSM_WIDTH_VALUE}+15).",height=" + .($WEBOBS{OSM_HEIGHT_VALUE}+15).",toolbar=no,menubar=no,location=no')\"> "; if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - $ilinks .= " | \"KML\"\n"; } @@ -245,142 +244,152 @@ =head1 Query string parameters my $fileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDType.$GRIDName"."$GRIDS{DESCRIPTION_SUFFIX}"; my $legacyfileDesc = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDName"."$GRIDS{DESCRIPTION_SUFFIX}"; if (-e $legacyfileDesc) { - copy($legacyfileDesc, $fileDesc); + copy($legacyfileDesc, $fileDesc); } if (-e $fileDesc) { - @desc = readFile($fileDesc); + @desc = readFile($fileDesc); } $htmlcontents = "
           "; - $htmlcontents .= "$__{'Purpose'}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= "

        "; - if ($#desc >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@desc))."

        \n" } - $htmlcontents .= "
        "; +$htmlcontents .= "$__{'Purpose'}"; +if ($editOK == 1) { $htmlcontents .= "  " } +$htmlcontents .= "

        "; +if ($#desc >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@desc))."

        \n" } +$htmlcontents .= "
        "; print $htmlcontents; - # ---- GRID's characteristics # print "
        "; $htmlcontents = ""; $htmlcontents .= "
           "; - $htmlcontents .= "$__{'Specifications'} $go2top"; - $htmlcontents .= "
        "; - # should 'nodes' be called differently (than 'nodes'!) ? - my $snm = defined($GRID{NODE_NAME}) ? $GRID{NODE_NAME} : "$__{'node'}"; - $htmlcontents .= "\n"; + +# ----------- +# only for PROCs: link to output pages and time scale parameters +if ($isProc) { + if (grep(/^FID_/,keys(%GRID))) { + $htmlcontents .= "\n"; + } + if ($procOUTG) { + my $urn = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName"; + $htmlcontents .= "\n"; + } + $htmlcontents .= "\n"; +} +$htmlcontents .= "
          "; - # ----------- - foreach (@domain) { - $htmlcontents .= "
        • $__{'Domain'}: $DOMAINS{$_}{NAME}
          • \n"; - } - # ----------- - $htmlcontents .= "
        • $__{'Description'}: $GRID{DESCRIPTION}
          • \n" if ($GRID{DESCRIPTION}); - # ----------- - $htmlcontents .= "
        • $__{'Grid code'}: $grid
          • \n"; +$htmlcontents .= "$__{'Specifications'} $go2top"; +$htmlcontents .= "
          "; + +# should 'nodes' be called differently (than 'nodes'!) ? +my $snm = defined($GRID{NODE_NAME}) ? $GRID{NODE_NAME} : "$__{'node'}"; +$htmlcontents .= "\n"; - # ----------- - # only for PROCs: link to output pages and time scale parameters - if ($isProc) { - if (grep(/^FID_/,keys(%GRID))) { - $htmlcontents .= "\n"; - } - if ($procOUTG) { - my $urn = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName"; - $htmlcontents .= "\n"; - } - $htmlcontents .= "\n"; - } - $htmlcontents .= "
            "; + +# ----------- +foreach (@domain) { + $htmlcontents .= "
          • $__{'Domain'}: $DOMAINS{$_}{NAME}
            • \n"; +} + +# ----------- +$htmlcontents .= "
          • $__{'Description'}: $GRID{DESCRIPTION}
            • \n" if ($GRID{DESCRIPTION}); + +# ----------- +$htmlcontents .= "
          • $__{'Grid code'}: $grid
            • \n"; + +# ----------- +if ($showOwnr && defined($GRID{OWNCODE})) { + $htmlcontents .= "
          • $__{'Owner'}: ".(defined($OWNRS{$GRID{OWNCODE}}) ? $OWNRS{$GRID{OWNCODE}}:$GRID{OWNCODE})."
            • \n" +} +if ($showType && $GRID{TYPE} ne "") { + $htmlcontents .= "
          • $__{'Type'}: $GRID{TYPE}
            • \n"; +} + +# ----------- +# only for PROCs +if ($isProc) { + + # 'old' ddb-key superseeded: use FORM (FORMS) definitions instead! + if (defined($GRID{'FORM'})) { + my %FORM = readCfg("$WEBOBS{'PATH_FORMS'}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); + if (%FORM) { + my $urnData = "/cgi-bin/".($FORM{'CGI_SHOW'} !~ /GENFORM/ ? "$FORM{'CGI_SHOW'}?form=$GRID{'FORM'}&node={$GRIDName}" : "showGENFORM.pl?form=$GRID{'FORM'}&node=PROC.$GRIDName"); + my $txtData = (defined($FORM{'TITLE'})) ? $FORM{'TITLE'} : ""; + $htmlcontents .= "
          • $__{'Access to data'}: $txtData
            • \n"; + } + } else { + + # ----------- + $htmlcontents .= "
          • $__{'Default data format'}: " + .($GRID{RAWFORMAT} // '')."
            • \n"; + $htmlcontents .= "
          • $__{'Default data source'}: " + .($GRID{RAWDATA} // '')."
            • \n"; + if (defined($GRID{URNDATA})) { + my $urnData = "$GRID{URNDATA}"; + $htmlcontents .= "
          • $__{'Access to rawdata'}: $urnData
            • \n"; + } + } + # ----------- - if ($showOwnr && defined($GRID{OWNCODE})) { - $htmlcontents .= "
          • $__{'Owner'}: ".(defined($OWNRS{$GRID{OWNCODE}}) ? $OWNRS{$GRID{OWNCODE}}:$GRID{OWNCODE})."
            • \n" - } - if ($showType && $GRID{TYPE} ne "") { - $htmlcontents .= "
          • $__{'Type'}: $GRID{TYPE}
            • \n"; - } - # ----------- - # only for PROCs - if ($isProc) { - # 'old' ddb-key superseeded: use FORM (FORMS) definitions instead! - if (defined($GRID{'FORM'})) { - my %FORM = readCfg("$WEBOBS{'PATH_FORMS'}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); - if (%FORM) { - my $urnData = "/cgi-bin/".($FORM{'CGI_SHOW'} !~ /GENFORM/ ? "$FORM{'CGI_SHOW'}?form=$GRID{'FORM'}&node={$GRIDName}" : "showGENFORM.pl?form=$GRID{'FORM'}&node=PROC.$GRIDName"); - my $txtData = (defined($FORM{'TITLE'})) ? $FORM{'TITLE'} : ""; - $htmlcontents .= "
          • $__{'Access to data'}: $txtData
            • \n"; - } - } else { - # ----------- - $htmlcontents .= "
          • $__{'Default data format'}: " - .($GRID{RAWFORMAT} // '')."
            • \n"; - $htmlcontents .= "
          • $__{'Default data source'}: " - .($GRID{RAWDATA} // '')."
            • \n"; - if (defined($GRID{URNDATA})) { - my $urnData = "$GRID{URNDATA}"; - $htmlcontents .= "
          • $__{'Access to rawdata'}: $urnData
            • \n"; - } - } - # ----------- - if (defined($GRID{EVENTS_FILE})) { - $htmlcontents .= "
          • $__{'Events File(s)'}:"; - foreach (split(/,/,$GRID{EVENTS_FILE})) { - my $evtFile = basename("$_"); - my $dir = dirname("$_"); - my $loc = ""; - $loc = "DATA" if ($dir =~ /^$WEBOBS{ROOT_DATA}/); - $loc = "CONF" if ($dir =~ /^$WEBOBS{ROOT_CONF}/); - # will be editable only if located in DATA/ or CONF/ (xedit policy) - if ($loc ne "" && $editOK == 1) { - $htmlcontents .= " $loc/$evtFile"; - } else { - $htmlcontents .= " $evtFile"; - } - } - $htmlcontents .= "
            • \n"; - } - } - # ----------- - if (defined($GRID{URL})) { - my @links = split(/;/,$GRID{URL}); - foreach (@links) { - my @txt = split(/,/,$_); - push(@txt,$txt[0]) if (index($_, ",") == -1); - $htmlcontents .= "
          • $__{'External link'}: $txt[0]<\/A>
            • \n"; - } - } - $htmlcontents .= "
          		\n"; - foreach (grep(/^FID_/,sort(keys(%GRID)))) { - $htmlcontents .= "\n"; - } - $htmlcontents .= "
          $__{'Nodes Default FIDs'}
          $_$GRID{$_}
          		\n"; - if ($procOUTG eq "events") { - $htmlcontents .= "\n"; - } else { - foreach my $g ("",split(/,/,$GRID{SUMMARYLIST})) { - my $outg = join('',map {$_ = ""} split(/,/,$GRID{TIMESCALELIST})); - $htmlcontents .= "$outg\n"; - } - } - if ($theiaAuth) { - $htmlcontents .= ""; - } - $htmlcontents .= "
          $__{'Proc Graphs'}".join("",@procTS)."
          Events
          ".($g eq ""?"Overview":"$g")."
          $__{'Send to Theia'}\n"; - $htmlcontents .= join('', map { checkingTS($_,$GRID{THEIA_SELECTED_TS}) } @procTS); - $htmlcontents .= "
          		\n"; - foreach ("Decimate","Cumulate","DateStr","MarkerSize","LineWidth","Status") { - my @tsp = split(/,/,$GRID{uc($_)."LIST"}); - my $cells; - if ($#tsp < 0) { - $cells = "$cells\n"; - } - $htmlcontents .= "
          $__{'Proc Param.'}".join("",@procTS)."
          $__{'undefined'}"; - } else { - push(@tsp, ' ' x ($#procTS-$#tsp)) if ($#tsp < $#procTS); - $cells = "".join("",@tsp).""; - } - $htmlcontents .= "
          $_
          \n"; - $htmlcontents .= "
          "; -print $htmlcontents; + if (defined($GRID{EVENTS_FILE})) { + $htmlcontents .= "
        • $__{'Events File(s)'}:"; + foreach (split(/,/,$GRID{EVENTS_FILE})) { + my $evtFile = basename("$_"); + my $dir = dirname("$_"); + my $loc = ""; + $loc = "DATA" if ($dir =~ /^$WEBOBS{ROOT_DATA}/); + $loc = "CONF" if ($dir =~ /^$WEBOBS{ROOT_CONF}/); + + # will be editable only if located in DATA/ or CONF/ (xedit policy) + if ($loc ne "" && $editOK == 1) { + $htmlcontents .= " $loc/$evtFile"; + } else { + $htmlcontents .= " $evtFile"; + } + } + $htmlcontents .= "
          • \n"; + } +} +# ----------- +if (defined($GRID{URL})) { + my @links = split(/;/,$GRID{URL}); + foreach (@links) { + my @txt = split(/,/,$_); + push(@txt,$txt[0]) if (index($_, ",") == -1); + $htmlcontents .= "
        • $__{'External link'}: $txt[0]<\/A>
          • \n"; + } +} +$htmlcontents .= "
        		\n"; + foreach (grep(/^FID_/,sort(keys(%GRID)))) { + $htmlcontents .= "\n"; + } + $htmlcontents .= "
        $__{'Nodes Default FIDs'}
        $_$GRID{$_}
        		\n"; + if ($procOUTG eq "events") { + $htmlcontents .= "\n"; + } else { + foreach my $g ("",split(/,/,$GRID{SUMMARYLIST})) { + my $outg = join('',map {$_ = ""} split(/,/,$GRID{TIMESCALELIST})); + $htmlcontents .= "$outg\n"; + } + } + if ($theiaAuth) { + $htmlcontents .= ""; + } + $htmlcontents .= "
        $__{'Proc Graphs'}".join("",@procTS)."
        Events
        ".($g eq ""?"Overview":"$g")."
        $__{'Send to Theia'}\n"; + $htmlcontents .= join('', map { checkingTS($_,$GRID{THEIA_SELECTED_TS}) } @procTS); + $htmlcontents .= "
        		\n"; + foreach ("Decimate","Cumulate","DateStr","MarkerSize","LineWidth","Status") { + my @tsp = split(/,/,$GRID{uc($_)."LIST"}); + my $cells; + if ($#tsp < 0) { + $cells = "$cells\n"; + } + $htmlcontents .= "
        $__{'Proc Param.'}".join("",@procTS)."
        $__{'undefined'}"; + } else { + push(@tsp, ' ' x ($#procTS-$#tsp)) if ($#tsp < $#procTS); + $cells = "".join("",@tsp).""; + } + $htmlcontents .= "
        $_
        \n"; +$htmlcontents .= "
        "; +print $htmlcontents; # ---- Now the GRID's NODE(s) # ---- first, submenu line for selections (list Active nodes, All,..., Coordinates type, etc....) @@ -388,291 +397,296 @@ =head1 Query string parameters print "
        "; $htmlcontents = ""; $htmlcontents .= "
           "; - $htmlcontents .= "$nbNodes $snm(s) $go2top"; - $htmlcontents .= "
        "; - - $htmlcontents .= "

        "; - - my $procParm = ''; - if ($isProc) { - $procParm = "&procparam=$usrProcparam"; - } - - # -- Nodes list submenu Nodes - $htmlcontents .= "$__{'Nodes'} [ "; - $htmlcontents .= ($usrNodes eq "active" ? "$__{'Active'}":"$__{'Active'}"); - $htmlcontents .= " | "; - $htmlcontents .= ($usrNodes eq "inactive" ? "$__{'Inactive'}":"$__{'Inactive'}"); - $htmlcontents .= " | "; - $htmlcontents .= ($usrNodes eq "all" ? "$__{'All'}":"$__{'All'}"); - if ( $admOK ) { - $htmlcontents .= " | ".($usrInvalid eq "on" ? "$__{'Hide invalid'}" - :"$__{'Show invalid'}"); - } - $htmlcontents .= " ] "; - - # -- Nodes list submenu Coordinates - $htmlcontents .= "- $__{Coordinates} [ " - .($usrCoord eq "latlon" ? "Lat/Lon":"Lat/Lon")." | " - .($usrCoord eq "utm" ? "UTM":"UTM"); - if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { - $htmlcontents .= " | ".($usrCoord eq "local" ? "$localCS":"$localCS"); - } - $htmlcontents .= " | " - .($usrCoord eq "xyz" ? "XYZ":"XYZ"); - $htmlcontents .= " ] - $__{Export} ["; - $htmlcontents .= " TXT |"; - $htmlcontents .= " CSV"; - if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - $htmlcontents .= " | KML"; - } - $htmlcontents .= " ] "; - - # -- Nodes list submenu Proc paramaters - if ($isProc) { - $htmlcontents .= "- $__{'Proc parameters'} [ " - .($usrProcparam eq "on" ? "On" :"On")." | " - .($usrProcparam ne "on" ? "Off":"Off")." ] "; - } - - # -- Nodes list submenu Project - if ( $CLIENT ne 'guest' ) { - $htmlcontents .= "- $__{Project} [ " - .($usrProject eq "on" ? "On" :"On")." | " - .($usrProject eq "off" ? "Off":"Off")." ] "; - } - $htmlcontents .= "

        \n"; - - # ---- then, the Nodes' table - # - my $nbValides = 0; - my $nbNonValides = 0; - my $tcolor; - my %NODE; - my $newNODE = ""; - - #$htmlcontents .= ""; - $htmlcontents .= "
        "; - $htmlcontents .= ""; - $htmlcontents .= ($editOK ? "":"") - ."" - ."" - ."" - .""; - if ($CLIENT ne 'guest') { - $htmlcontents .= ""; - $htmlcontents .= "" if ($usrProject eq "on"); - } - $htmlcontents .= "" if ($usrProcparam eq 'on'); - $htmlcontents .= "" if ($procOUTG); - if ($overallStatus) { - my @tsp = split(/,/,$GRID{"STATUSLIST"}); - $htmlcontents .= ""; - } - $htmlcontents .= "\n"; - if ($usrCoord eq "utm") { - $htmlcontents .= ""; - } elsif ($usrCoord eq "local") { - $htmlcontents .= ""; - } elsif ($usrCoord eq "xyz") { - $htmlcontents .= ""; - } else { - $htmlcontents .= ""; - } - $htmlcontents .= ""; - $htmlcontents .= "" if ($usrProcparam eq 'on'); - if ($procOUTG eq "events") { - $htmlcontents .= ""; - } elsif ($procOUTG) { - $htmlcontents .= ""; - } - if ($overallStatus) { - $htmlcontents .= ""; - } - $htmlcontents .= "\n"; - - for (@{$GRID{NODESLIST}}) { - my $displayNode = 1; - my $NODEName = $_; - my $NODENameLower = lc($NODEName); - - my %N = readNode($NODEName); - %NODE = %{$N{$NODEName}}; - - if (%NODE) { - - # is VALID ? do we display INVALID ? - if (!isok($NODE{VALID})) { - $tcolor="node-disabled"; - if ($usrInvalid ne "on") { - $nbNonValides++; - $displayNode = 0; - } - } else { - $tcolor="node-active"; - $nbValides++; - } - - # is NOT active if already 'ended' OR not yet 'installed' ? do we display ? - if (isok($NODE{VALID}) && ($NODE{END_DATE} ne "NA" && $NODE{END_DATE} lt $today) || ($NODE{INSTALL_DATE} ne "NA" && $NODE{INSTALL_DATE} gt $today)) { - $tcolor="node-inactive"; - if ($usrNodes eq "active") { - $displayNode = 0; - } - } else { - if ($usrNodes eq "inactive") { - $displayNode = 0; - } - } - - # trick: execute display logic even if we don't display, but html-comment out first - $htmlcontents .= (!$displayNode ? "":""); - } - } - $htmlcontents .= "
        ".($admOK ? $newNODE:"")."$__{'Alias'}$__{'Name'}$__{'Coordinates'}$__{'Lifetime and Validity'}" - ."$__{'Type'}$__{'Nb
        Evnt'}        		$__{'Project'}$__{'Proc Parameters'}$__{'Proc Graphs'}$__{'Proc Status'} (".$procTS[first { $tsp[$_] eq '1' } reverse(0..$#tsp)].")
        UTM Eastern (m)UTM Northern (m)$__{'Elev.'} (m)Local TM Eastern (m)Local TM Northern (m)$__{'Elev.'} (m)X (m)Y (m)Z (m)$__{'Lat.'} (WGS84)$__{'Lon.'} (WGS84)$__{'Elev.'} (m)$__{'Start / Installation'}$__{'End / Stop'}$__{'FID'}$__{'Raw Format'}$__{'Chan.'}Events".join("",@procTS)."$__{'Last Data'} (TZ $GRID{TZ})$__{'Sampl.'}$__{'Status'}
        "; - $htmlcontents .= "
        "; -print $htmlcontents; +$htmlcontents .= "$nbNodes $snm(s) $go2top"; +$htmlcontents .= "
        "; + +$htmlcontents .= "

        "; +my $procParm = ''; +if ($isProc) { + $procParm = "&procparam=$usrProcparam"; +} + +# -- Nodes list submenu Nodes +$htmlcontents .= "$__{'Nodes'} [ "; +$htmlcontents .= ($usrNodes eq "active" ? "$__{'Active'}":"$__{'Active'}"); +$htmlcontents .= " | "; +$htmlcontents .= ($usrNodes eq "inactive" ? "$__{'Inactive'}":"$__{'Inactive'}"); +$htmlcontents .= " | "; +$htmlcontents .= ($usrNodes eq "all" ? "$__{'All'}":"$__{'All'}"); +if ( $admOK ) { + $htmlcontents .= " | ".($usrInvalid eq "on" ? "$__{'Hide invalid'}" + :"$__{'Show invalid'}"); +} +$htmlcontents .= " ] "; + +# -- Nodes list submenu Coordinates +$htmlcontents .= "- $__{Coordinates} [ " + .($usrCoord eq "latlon" ? "Lat/Lon":"Lat/Lon")." | " + .($usrCoord eq "utm" ? "UTM":"UTM"); +if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { + $htmlcontents .= " | ".($usrCoord eq "local" ? "$localCS":"$localCS"); +} +$htmlcontents .= " | " + .($usrCoord eq "xyz" ? "XYZ":"XYZ"); +$htmlcontents .= " ] - $__{Export} ["; +$htmlcontents .= " TXT |"; +$htmlcontents .= " CSV"; +if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { + $htmlcontents .= " | KML"; +} +$htmlcontents .= " ] "; + +# -- Nodes list submenu Proc paramaters +if ($isProc) { + $htmlcontents .= "- $__{'Proc parameters'} [ " + .($usrProcparam eq "on" ? "On" :"On")." | " + .($usrProcparam ne "on" ? "Off":"Off")." ] "; +} + +# -- Nodes list submenu Project +if ( $CLIENT ne 'guest' ) { + $htmlcontents .= "- $__{Project} [ " + .($usrProject eq "on" ? "On" :"On")." | " + .($usrProject eq "off" ? "Off":"Off")." ] "; +} +$htmlcontents .= "

        \n"; + +# ---- then, the Nodes' table +# +my $nbValides = 0; +my $nbNonValides = 0; +my $tcolor; +my %NODE; +my $newNODE = ""; + +#$htmlcontents .= ""; +$htmlcontents .= "
        "; +$htmlcontents .= ""; +$htmlcontents .= ($editOK ? "":"") + ."" + ."" + ."" + .""; +if ($CLIENT ne 'guest') { + $htmlcontents .= ""; + $htmlcontents .= "" if ($usrProject eq "on"); +} +$htmlcontents .= "" if ($usrProcparam eq 'on'); +$htmlcontents .= "" if ($procOUTG); +if ($overallStatus) { + my @tsp = split(/,/,$GRID{"STATUSLIST"}); + $htmlcontents .= ""; +} +$htmlcontents .= "\n"; +if ($usrCoord eq "utm") { + $htmlcontents .= ""; +} elsif ($usrCoord eq "local") { + $htmlcontents .= ""; +} elsif ($usrCoord eq "xyz") { + $htmlcontents .= ""; +} else { + $htmlcontents .= ""; +} +$htmlcontents .= ""; +$htmlcontents .= "" if ($usrProcparam eq 'on'); +if ($procOUTG eq "events") { + $htmlcontents .= ""; +} elsif ($procOUTG) { + $htmlcontents .= ""; +} +if ($overallStatus) { + $htmlcontents .= ""; +} +$htmlcontents .= "\n"; + +for (@{$GRID{NODESLIST}}) { + my $displayNode = 1; + my $NODEName = $_; + my $NODENameLower = lc($NODEName); + + my %N = readNode($NODEName); + %NODE = %{$N{$NODEName}}; + + if (%NODE) { + + # is VALID ? do we display INVALID ? + if (!isok($NODE{VALID})) { + $tcolor="node-disabled"; + if ($usrInvalid ne "on") { + $nbNonValides++; + $displayNode = 0; + } + } else { + $tcolor="node-active"; + $nbValides++; + } + + # is NOT active if already 'ended' OR not yet 'installed' ? do we display ? + if (isok($NODE{VALID}) && ($NODE{END_DATE} ne "NA" && $NODE{END_DATE} lt $today) || ($NODE{INSTALL_DATE} ne "NA" && $NODE{INSTALL_DATE} gt $today)) { + $tcolor="node-inactive"; + if ($usrNodes eq "active") { + $displayNode = 0; + } + } else { + if ($usrNodes eq "inactive") { + $displayNode = 0; + } + } + +# trick: execute display logic even if we don't display, but html-comment out first + $htmlcontents .= (!$displayNode ? "":""); + } +} +$htmlcontents .= "
        ".($admOK ? $newNODE:"")."$__{'Alias'}$__{'Name'}$__{'Coordinates'}$__{'Lifetime and Validity'}" + ."$__{'Type'}$__{'Nb
        Evnt'}        		$__{'Project'}$__{'Proc Parameters'}$__{'Proc Graphs'}$__{'Proc Status'} (".$procTS[first { $tsp[$_] eq '1' } reverse(0..$#tsp)].")
        UTM Eastern (m)UTM Northern (m)$__{'Elev.'} (m)Local TM Eastern (m)Local TM Northern (m)$__{'Elev.'} (m)X (m)Y (m)Z (m)$__{'Lat.'} (WGS84)$__{'Lon.'} (WGS84)$__{'Elev.'} (m)$__{'Start / Installation'}$__{'End / Stop'}$__{'FID'}$__{'Raw Format'}$__{'Chan.'}Events".join("",@procTS)."$__{'Last Data'} (TZ $GRID{TZ})$__{'Sampl.'}$__{'Status'}
        "; +$htmlcontents .= "
        "; +print $htmlcontents; # ---- now the grid's MAPs # only 1 map : *.png and its corresponding *.map @@ -681,40 +695,40 @@ =head1 Query string parameters my $mapfile = $grid."_map".$usrMap; if ( -e "$MAPpath/$mapfile.png" ) { - my @maps; - my $i = 0; - my @htmlarea; - ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - if (opendir(my $dh, $MAPpath)) { - @maps = grep { /.*_map\d*.png/ } readdir($dh); - closedir($dh); - } - print "
        "; - print ""; - print "
           "; - print "$__{'Location'} $go2top"; - print "
        "; - print "

        $__{Maps} [ "; - foreach (sort @maps) { - print "| " if ($i++); - my @v = split(/_map|\./,$_); - if ("$mapfile.png" eq $_) { - print "MAP$v[2] "; - } elsif ( $v[2] eq "" || exists $GRID{"MAP$v[2]_XYLIM"} ) { - print "MAP$v[2] "; - } - } - print " ] - Export [ PNG | EPS"; - if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - print " | KML"; - } - print " ]

        \n"; - print "

        \n"; - if (-e "$MAPpath/$grid"."_map.map") { - @htmlarea = readFile("$MAPpath/$mapfile.map"); - print "@htmlarea\n"; - } - print "
        \n"; + my @maps; + my $i = 0; + my @htmlarea; + ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + if (opendir(my $dh, $MAPpath)) { + @maps = grep { /.*_map\d*.png/ } readdir($dh); + closedir($dh); + } + print "
        "; + print ""; + print "
           "; + print "$__{'Location'} $go2top"; + print "
        "; + print "

        $__{Maps} [ "; + foreach (sort @maps) { + print "| " if ($i++); + my @v = split(/_map|\./,$_); + if ("$mapfile.png" eq $_) { + print "MAP$v[2] "; + } elsif ( $v[2] eq "" || exists $GRID{"MAP$v[2]_XYLIM"} ) { + print "MAP$v[2] "; + } + } + print " ] - Export [ PNG | EPS"; + if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { + print " | KML"; + } + print " ]

        \n"; + print "

        \n"; + if (-e "$MAPpath/$grid"."_map.map") { + @htmlarea = readFile("$MAPpath/$mapfile.map"); + print "@htmlarea\n"; + } + print "
        \n"; } # ----- Protocole @@ -723,19 +737,19 @@ =head1 Query string parameters my $legacyfileProtocole = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDName"."$GRIDS{PROTOCOLE_SUFFIX}"; my @protocole = (""); if (-e $legacyfileProtocole) { - copy($legacyfileProtocole, $fileProtocole); + copy($legacyfileProtocole, $fileProtocole); } if (-e $fileProtocole) { - @protocole = readFile($fileProtocole); + @protocole = readFile($fileProtocole); } print "
        "; print "\n"; $htmlcontents = "
           "; - $htmlcontents .= "$__{'Information'}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= " $go2top

        "; - if ($#protocole >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@protocole))."

        \n" } - $htmlcontents .= "
        "; +$htmlcontents .= "$__{'Information'}"; +if ($editOK == 1) { $htmlcontents .= "  " } +$htmlcontents .= " $go2top

        "; +if ($#protocole >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@protocole))."

        \n" } +$htmlcontents .= "
        "; print $htmlcontents; # ---- Project @@ -760,7 +774,7 @@ =head1 Query string parameters if ($editOK) { print "  " } print " $go2top

        "; print " $__{'Sort by'} [ ".($usrSortby ne "event" ? "$__{'Event'}":"$__{'Event'}")." | " - .($usrSortby ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
        \n"; + .($usrSortby ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
        \n"; my $htmlEvents = ($usrSortby =~ /event/i) ? eventsShow("events","$GRIDType.$GRIDName", $editOK) : eventsShow("date","$GRIDType.$GRIDName", $editOK); print $htmlEvents; print "
        "; @@ -771,19 +785,19 @@ =head1 Query string parameters my $legacyfileBib = "$WEBOBS{PATH_GRIDS_DOCS}/$GRIDName"."$GRIDS{BIBLIO_SUFFIX}"; my @bib = (""); if (-e $legacyfileBib) { - copy($legacyfileBib, $fileBib); + copy($legacyfileBib, $fileBib); } if (-e $fileBib) { - @bib = readFile($fileBib); + @bib = readFile($fileBib); } print "
        "; print "\n"; $htmlcontents = "
           "; - $htmlcontents .= "$__{'References'}"; - if ($editOK == 1) { $htmlcontents .= "  " } - $htmlcontents .= " $go2top

        "; - if ($#bib >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@bib))."

        \n" } - $htmlcontents .= "
        "; +$htmlcontents .= "$__{'References'}"; +if ($editOK == 1) { $htmlcontents .= "  " } +$htmlcontents .= " $go2top

        "; +if ($#bib >= 0) { $htmlcontents .= "

        ".WebObs::Wiki::wiki2html(join("",@bib))."

        \n" } +$htmlcontents .= "
        "; print $htmlcontents; # ----- Authorization access ------ @@ -796,19 +810,19 @@ =head1 Query string parameters print "\n\n"; sub checkingTS { - if ( $_[0] eq $_[1] ) { - return ""; - } else { - return ""; - } + if ( $_[0] eq $_[1] ) { + return ""; + } else { + return ""; + } } sub checkingNODELIST { - if ( $_[1] =~ /$_[0]/ ) { - return ""; - } else { - return ""; - } + if ( $_[1] =~ /$_[0]/ ) { + return ""; + } else { + return ""; + } } __END__ diff --git a/CODE/cgi-bin/showNODE.pl b/CODE/cgi-bin/showNODE.pl index eedbba4b..83218628 100755 --- a/CODE/cgi-bin/showNODE.pl +++ b/CODE/cgi-bin/showNODE.pl @@ -37,7 +37,6 @@ =head1 Query string parameters =cut - use strict; use warnings; use Time::Local; @@ -68,6 +67,7 @@ =head1 Query string parameters my $fileProjet=""; my $fileProjetName=""; my $fileMap=""; + #OLD:my @listeFileInterventions; my @listeDocumentsHsV=(""); my $pathVisu=""; @@ -87,29 +87,29 @@ =head1 Query string parameters my $QryParm = $cgi->Vars; my @NID = split(/[\.\/]/, trim($QryParm->{'node'})); if (scalar(@NID) == 3) { - ($GRIDType, $GRIDName, $NODEName) = @NID; - %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); - if ("@{$allNodeGrids{$NODEName}}" =~ /\b$GRIDType\.$GRIDName\b/) { - my %G; - my %S = readNode($NODEName); - %NODE = %{$S{$NODEName}}; - if (%NODE) { - if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } - elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } - if (%G) { - %GRID = %{$G{$GRIDName}} ; - if ( clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $RESOURCE = "auth".lc($GRIDType)."s/$GRIDName"; - if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $editOK = 1; - } - if ( clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - $editOK = 2; - } - } else { die "You cannot view $NODEName in $GRIDType.$GRIDName context"} - } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } - } else { die "$__{'Could not read'} $__{'Node Configuration'}"} - } else { die "$GRIDType.$GRIDName.$NODEName $__{'unknown'}" } + ($GRIDType, $GRIDName, $NODEName) = @NID; + %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); + if ("@{$allNodeGrids{$NODEName}}" =~ /\b$GRIDType\.$GRIDName\b/) { + my %G; + my %S = readNode($NODEName); + %NODE = %{$S{$NODEName}}; + if (%NODE) { + if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } + elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } + if (%G) { + %GRID = %{$G{$GRIDName}} ; + if ( clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $RESOURCE = "auth".lc($GRIDType)."s/$GRIDName"; + if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $editOK = 1; + } + if ( clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + $editOK = 2; + } + } else { die "You cannot view $NODEName in $GRIDType.$GRIDName context"} + } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } + } else { die "$__{'Could not read'} $__{'Node Configuration'}"} + } else { die "$GRIDType.$GRIDName.$NODEName $__{'unknown'}" } } else { die "$__{'Not a fully qualified node name (gridtype.gridname.nodename)'}" } # ---- Looking for THEIA user flag @@ -148,8 +148,8 @@ =head1 Query string parameters my $fdsn = trim($NODE{"$GRIDType.$GRIDName.FDSN_NETWORK_CODE"} // $NODE{FDSN_NETWORK_CODE}); my $fid = $NODE{"$GRIDType.$GRIDName.FID"} // $NODE{FID}; my $fids = join(" - ", map { my $v; ($v = $_) =~ s/$GRIDType\.$GRIDName\.//; - "$v: $NODE{$_} "; } - sort grep(/$GRIDType\.$GRIDName\.FID_|^FID_/, keys(%NODE))); + "$v: $NODE{$_} "; } + sort grep(/$GRIDType\.$GRIDName\.FID_|^FID_/, keys(%NODE))); my $rawformat = $NODE{"$GRIDType.$GRIDName.RAWFORMAT"} // $NODE{RAWFORMAT}; my $rawdata = $NODE{"$GRIDType.$GRIDName.RAWDATA"} // $NODE{RAWDATA}; $rawdata =~ s/\$FID/$fid/g; @@ -162,8 +162,8 @@ =head1 Query string parameters if ($statusDB eq "") { $statusDB = "$WEBOBS{PATH_DATA_DB}/NODESSTATUS.db" }; my $statusNODE; if (-e $statusDB) { - $statusNODE = qx(sqlite3 $statusDB "select * from status where NODE like '%$QryParm->{'node'}%';"); - chomp($statusNODE); + $statusNODE = qx(sqlite3 $statusDB "select * from status where NODE like '%$QryParm->{'node'}%';"); + chomp($statusNODE); } $GRID{UTM_LOCAL} //= ''; @@ -226,23 +226,23 @@ =head1 Query string parameters print ""; print "
        \n"; print "

        $nodeName".($editOK ? " ":"") - .($editOK > 1 ? " ":"") - ."

        \n"; + .($editOK > 1 ? " ":"") + ."\n"; print "

        »» ["; if (uc($GRIDType) eq 'VIEW' || uc($GRIDType) eq 'PROC') { - print " $DOMAINS{$GRID{DOMAIN}}{NAME} / " - ."$GRID{NAME} |"; + print " $DOMAINS{$GRID{DOMAIN}}{NAME} / " + ."$GRID{NAME} |"; } print " $__{Project} | $__{Events} " - ."| ]

        "; + ."| ]

        "; print "        		".qrcode($WEBOBS{QRCODE_SIZE})."
        \n"; my %CLBS = readCfg("$WEBOBS{ROOT_CODE}/etc/clb.conf"); print "
        " - ."" - .""; + ."" + .""; # ---- start of node table ---------------------------------------------------- # @@ -253,32 +253,31 @@ =head1 Query string parameters print "Grids"; print "$QryParm->{'node'}"; for (@{$allNodeGrids{$NODEName}}) { - my $fullnode = "$_.$NODEName"; - print "
        $fullnode" if ($fullnode ne $QryParm->{'node'}); + my $fullnode = "$_.$NODEName"; + print "
        $fullnode" if ($fullnode ne $QryParm->{'node'}); } print "\n"; - # Row "type" ------------------------------------------------------------------ # print ""; if ($editOK) { - print "Type"; + print "Type"; } else { - print "Type"; + print "Type"; } print "$NODE{TYPE}\n"; # Row "GNSS 9-code" ---------------------------------------------------- # if ($NODE{GNSS_9CHAR}) { - print ""; - if ($editOK) { - print "GNSS 9-code"; - } else { - print "GNSS 9-code"; - } - print "$NODE{GNSS_9CHAR}\n"; + print ""; + if ($editOK) { + print "GNSS 9-code"; + } else { + print "GNSS 9-code"; + } + print "$NODE{GNSS_9CHAR}\n"; } # Row "Lifetime" ---------------------------------------------------- @@ -288,366 +287,364 @@ =head1 Query string parameters my $txt = "$__{'Lifetime'}"; print "".($editOK ? "$txt":$txt).""; print "" - ."$__{'Started on'}: ".($installDate ne "NA" ? "$installDate":"?") - ." / ".($endDate ne "NA" ? "$__{'Ended on'}: $endDate":"Active") - ."\n"; + ."$__{'Started on'}: ".($installDate ne "NA" ? "$installDate":"?") + ." / ".($endDate ne "NA" ? "$__{'Ended on'}: $endDate":"Active") + ."\n"; # Row "coordinates" and localization map -------------------------------------- # if (!($NODE{LAT_WGS84}=="" && $NODE{LON_WGS84}=="" && $NODE{ALTITUDE}=="")) { - my $lat = $NODE{LAT_WGS84}; - my $lon = $NODE{LON_WGS84}; - my $alt = $NODE{ALTITUDE}; - my ($e_utm,$n_utm,$utmzone) = geo2utm($lat,$lon); - my $e_utml; - my $n_utml; - my $utml0; - my $utml1; - my $utml2; - if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { - ($e_utml,$n_utml) = geo2utml($lat,$lon,$alt); - $utml0 = "
        $UTM{GEODETIC_DATUM_LOCAL_NAME}:"; - $utml1 = sprintf("
        %6.0f",$e_utml); - $utml2 = sprintf("
        %6.0f",$n_utml); - } - my $txt = $__{'Location'}; - - # ---- link to OpenStreetMap - # ------------------------ - my $map = "" - .""; - - # --- link KML Google Earth - # ------------------------- - if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { - $map .= " \"KML\"\n"; - } - - # ---- link to interactive map - IGN (A. Bosson) - # ---------------------------------------------- - if ($WEBOBS{IGN_MAPI_LINK} eq 1) { - $map .= " \"".l2u($WEBOBS{IGN_MAPI_LINK_INFO})."\"\n"; - } - - print "".($editOK ? "$txt":$txt).""; - print ""; - print "" - ."" - ."" - .""; - my $alat = abs($lat); - my $alon = abs($lon); - print "\n" - ."" - .sprintf("",$alat,int($alat),($alat-int($alat))*60,$alat,($alat-int($alat))*60,($alat*60-int($alat*60))*60) - .sprintf("",$alon,int($alon),($alon-int($alon))*60,$alon,($alon-int($alon))*60,($alon*60-int($alon*60))*60) - ."" - ."" - .sprintf("",$e_utm,$n_utm) - ."
        $__{'Date'}$__{'Type'}$__{'Lat.'} ".($lat >= 0 ? "N":"S")." (WGS84)$__{'Lon.'} ".($lon >= 0 ? "E":"W")." (WGS84)$__{'Alt.'} (m)Transverse Mercator$__{'East'} (m)$__{'North'} (m)
        $NODE{POS_DATE}".u2l($typePos{$NODE{POS_TYPE}})." %9.6f °
        %02d ° %07.4f '
        %02d ° %02d ' %05.2f \"        		 %9.6f °
        %02d ° %07.4f '
        %02d ° %02d ' %05.2f \"        		$NODE{ALTITUDE}UTM$utmzone WGS84:$utml0%6.0f$utml1%6.0f$utml2$map
        \n"; - print "
        "; - if (-e $fileMap) { - my $tmp = basename($fileMap); - print ""; - } - # ---- Neighbour nodes - # ---------------------------------------------- - if ($NODES{NEIGHBOUR_NODES_MAX} > 0) { - # loads all existing nodes - my %dist; - my %deniv; - my %bear; - my %proj; - for (keys(%allNodes)) { - my %N = %{$allNodes{$_}}; - if (isok($N{VALID}) && (!isok($NODES{NEIGHBOUR_NODES_ACTIVE_ONLY}) || (($N{END_DATE} ge $today || $N{END_DATE} eq "NA") - && ($N{INSTALL_DATE} le $today || $N{INSTALL_DATE} eq "NA")))) { - ($dist{$_},$bear{$_}) = greatcircle($lat,$lon,$N{LAT_WGS84},$N{LON_WGS84}); - if ($alt != 0 && $N{ALTITUDE} != 0) { - $deniv{$_} = $N{ALTITUDE} - $alt; - $dist{$_} = sqrt($dist{$_}**2 + ($deniv{$_}/1000)**2); - } - $proj{$_} = $N{PROJECT}; - } - } - print "\n"; - } - print "
        \"$__{'Location" - ."" - ."\n"; - my $n = 1; - foreach (sort { $dist{$a} <=> $dist{$b} or $a cmp $b } keys %dist) { - if ($_ ne $NODEName) { - my $d = ($dist{$_}<1 ? sprintf("%8.0f m",1000*$dist{$_}):sprintf("%7.3f km",$dist{$_})); - my $p = ($proj{$_} ? " ":""); - print "" - ."" - ."\n"; - last if ($n++ == $NODES{NEIGHBOUR_NODES_MAX}); - } - } - print "
        $__{'Distance (beeline)'}$__{'Elev. gain'}$__{'Neighbour nodes'}
        $d".sprintf("%+1.0f m ",$deniv{$_})."".getNodeString(node=>$_, link=>'node')."$p
        \n\n"; + my $lat = $NODE{LAT_WGS84}; + my $lon = $NODE{LON_WGS84}; + my $alt = $NODE{ALTITUDE}; + my ($e_utm,$n_utm,$utmzone) = geo2utm($lat,$lon); + my $e_utml; + my $n_utml; + my $utml0; + my $utml1; + my $utml2; + if (defined($GRID{UTM_LOCAL}) && -e $GRID{UTM_LOCAL} ) { + ($e_utml,$n_utml) = geo2utml($lat,$lon,$alt); + $utml0 = "
        $UTM{GEODETIC_DATUM_LOCAL_NAME}:"; + $utml1 = sprintf("
        %6.0f",$e_utml); + $utml2 = sprintf("
        %6.0f",$n_utml); + } + my $txt = $__{'Location'}; + + # ---- link to OpenStreetMap + # ------------------------ + my $map = "" + .""; + + # --- link KML Google Earth + # ------------------------- + if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { + $map .= " \"KML\"\n"; + } + + # ---- link to interactive map - IGN (A. Bosson) + # ---------------------------------------------- + if ($WEBOBS{IGN_MAPI_LINK} eq 1) { + $map .= " \"".l2u($WEBOBS{IGN_MAPI_LINK_INFO})."\"\n"; + } + + print "".($editOK ? "$txt":$txt).""; + print ""; + print "" + ."" + ."" + .""; + my $alat = abs($lat); + my $alon = abs($lon); + print "\n" + ."" + .sprintf("",$alat,int($alat),($alat-int($alat))*60,$alat,($alat-int($alat))*60,($alat*60-int($alat*60))*60) + .sprintf("",$alon,int($alon),($alon-int($alon))*60,$alon,($alon-int($alon))*60,($alon*60-int($alon*60))*60) + ."" + ."" + .sprintf("",$e_utm,$n_utm) + ."
        $__{'Date'}$__{'Type'}$__{'Lat.'} ".($lat >= 0 ? "N":"S")." (WGS84)$__{'Lon.'} ".($lon >= 0 ? "E":"W")." (WGS84)$__{'Alt.'} (m)Transverse Mercator$__{'East'} (m)$__{'North'} (m)
        $NODE{POS_DATE}".u2l($typePos{$NODE{POS_TYPE}})." %9.6f °
        %02d ° %07.4f '
        %02d ° %02d ' %05.2f \"        		 %9.6f °
        %02d ° %07.4f '
        %02d ° %02d ' %05.2f \"        		$NODE{ALTITUDE}UTM$utmzone WGS84:$utml0%6.0f$utml1%6.0f$utml2$map
        \n"; + print "
        "; + if (-e $fileMap) { + my $tmp = basename($fileMap); + print ""; + } + + # ---- Neighbour nodes + # ---------------------------------------------- + if ($NODES{NEIGHBOUR_NODES_MAX} > 0) { + + # loads all existing nodes + my %dist; + my %deniv; + my %bear; + my %proj; + for (keys(%allNodes)) { + my %N = %{$allNodes{$_}}; + if (isok($N{VALID}) && (!isok($NODES{NEIGHBOUR_NODES_ACTIVE_ONLY}) || (($N{END_DATE} ge $today || $N{END_DATE} eq "NA") + && ($N{INSTALL_DATE} le $today || $N{INSTALL_DATE} eq "NA")))) { + ($dist{$_},$bear{$_}) = greatcircle($lat,$lon,$N{LAT_WGS84},$N{LON_WGS84}); + if ($alt != 0 && $N{ALTITUDE} != 0) { + $deniv{$_} = $N{ALTITUDE} - $alt; + $dist{$_} = sqrt($dist{$_}**2 + ($deniv{$_}/1000)**2); + } + $proj{$_} = $N{PROJECT}; + } + } + print "\n"; + } + print "
        \"$__{'Location" + ."" + ."\n"; + my $n = 1; + foreach (sort { $dist{$a} <=> $dist{$b} or $a cmp $b } keys %dist) { + if ($_ ne $NODEName) { + my $d = ($dist{$_}<1 ? sprintf("%8.0f m",1000*$dist{$_}):sprintf("%7.3f km",$dist{$_})); + my $p = ($proj{$_} ? " ":""); + print "" + ."" + ."\n"; + last if ($n++ == $NODES{NEIGHBOUR_NODES_MAX}); + } + } + print "
        $__{'Distance (beeline)'}$__{'Elev. gain'}$__{'Neighbour nodes'}
        $d".sprintf("%+1.0f m ",$deniv{$_})."".getNodeString(node=>$_, link=>'node')."$p
        \n\n"; } - # Row "transmission" type and link to relay / data acquisition # if ($NODE{TRANSMISSION} ne "NA" && $NODE{TRANSMISSION} ne "") { - my @trans = split(/ |,|\|/,$NODE{TRANSMISSION}); - chomp(@trans); - my $txt = $__{'Transmission'}; - print "".($editOK ? "$txt":$txt).""; - my ($utype,$ujunk) = split(/\|/,$typeTele{$trans[0]}{name}); - print ""; - for (@trans[1 .. $#trans]) { - my $distelev = ""; - my $nodelink = "$_ ($__{'unknown'})"; - if (exists $allNodes{$_}) { - my %N = %{$allNodes{$_}}; - if (!($N{LAT_WGS84}=="" && $N{LON_WGS84}=="")) { - my ($dist,$bear) = greatcircle($NODE{LAT_WGS84},$NODE{LON_WGS84},$N{LAT_WGS84},$N{LON_WGS84}); - my $deniv = ""; - if ($NODE{ALTITUDE} != 0 && $N{ALTITUDE} != 0) { - $deniv = $N{ALTITUDE} - $NODE{ALTITUDE}; - $dist = sqrt($dist**2 + ($deniv/1000)**2); - } - my $d = ($dist<1 ? sprintf("%8.0f m",1000*$dist):sprintf("%7.3f km",$dist)); - $distelev = "" - .""; - } - $nodelink = getNodeString(node=>$_,link=>'node').($N{PROJECT} ? " ":""); - } - print "$distelev\n"; - } - print "
        Type: ".u2l($utype)."
          $d(Δh ".sprintf("%+1.0f m",$deniv).") 
        $nodelink
        \n"; - print "\n"; + my @trans = split(/ |,|\|/,$NODE{TRANSMISSION}); + chomp(@trans); + my $txt = $__{'Transmission'}; + print "".($editOK ? "$txt":$txt).""; + my ($utype,$ujunk) = split(/\|/,$typeTele{$trans[0]}{name}); + print ""; + for (@trans[1 .. $#trans]) { + my $distelev = ""; + my $nodelink = "$_ ($__{'unknown'})"; + if (exists $allNodes{$_}) { + my %N = %{$allNodes{$_}}; + if (!($N{LAT_WGS84}=="" && $N{LON_WGS84}=="")) { + my ($dist,$bear) = greatcircle($NODE{LAT_WGS84},$NODE{LON_WGS84},$N{LAT_WGS84},$N{LON_WGS84}); + my $deniv = ""; + if ($NODE{ALTITUDE} != 0 && $N{ALTITUDE} != 0) { + $deniv = $N{ALTITUDE} - $NODE{ALTITUDE}; + $dist = sqrt($dist**2 + ($deniv/1000)**2); + } + my $d = ($dist<1 ? sprintf("%8.0f m",1000*$dist):sprintf("%7.3f km",$dist)); + $distelev = "" + .""; + } + $nodelink = getNodeString(node=>$_,link=>'node').($N{PROJECT} ? " ":""); + } + print "$distelev\n"; + } + print "
        Type: ".u2l($utype)."
          $d(Δh ".sprintf("%+1.0f m",$deniv).") 
        $nodelink
        \n"; + print "\n"; } - # Row "proc": codes, status, data... ----------------- # if (uc($GRIDType) eq 'PROC') { - print ""; - if ($editOK) { print "Proc" } - else { print "Proc" } - printf ""; - - # --- parameters - my $txt = "$__{'Parameters'}"; - if ($editOK > 1) { print "$txt" } - elsif ($editOK) { print "$txt" } - else { print "$txt" } - print ""; - #print "ID: $NODEName"; - print "FID: ".($fid ne "" ? "$fid":"$__{undefined}")."\n"; - print "
        Network: $fdsn ($FDSN{$fdsn})\n" if ($fdsn ne ""); - print "
        $fids" if ($fids ne ""); - print "
        Raw Format: $rawFormats{$rawformat}{supfmt} / $rawformat ($rawFormats{$rawformat}{name})" if ($rawformat ne ""); - print "
        Raw Data Source: $rawdata" if ($rawdata ne ""); - print "\n"; - - # --- description - print "$__{'Description'}$desc\n"; - - # --- status - print "$__{'Status'}" - .""; # Date de l'analyse de l'etat - if ($endDate eq "NA") { - print ""; - print ""; - } - } - print "
        "; - print "Acquisition Period: ".($acqrate ne "" ? "$acqrate days":"not set")."
        "; - print "Acquisition Delay: ".($acqdelay ne "" ? "$acqdelay days":"not set")."
        "; - if ($statusNODE ne "") { - my @status = split(/\|/,$statusNODE); - my $bgcolEt = ""; - my $bgcolA = ""; - if ($status[1] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolEt = "status-standby"; $status[1] = "Standby"; } # grey/gray - elsif ($status[1] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolEt = "status-critical"; $status[1] .= "%"; } - elsif ($status[1] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolEt = "status-ok"; $status[1] .= "%"; } - else { $bgcolEt="status-warning"; $status[1] .= "%"; } - if ($status[2] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolA = "status-standby"; $status[2] = "Standby"; } - elsif ($status[2] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolA = "status-critical"; $status[2] .= "%"; } - elsif ($status[2] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolA = "status-ok"; $status[2] .= "%"; } - else { $bgcolA="status-warning"; $status[2] .= "%"; } - print "        		$__{'Last status check on'} $status[4]$__{'Sampl.'}: $status[2]$__{'Status'}: $status[1]
        \n"; - - # data (data & graphs from proc) - my $OUTG = ""; - if (-d "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName" ) { - $OUTG = "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName"; - } - my (@glist) = map { "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/$NODENameLower\_$_.png" } @procTS; - my (@dlist) = map { "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/$NODENameLower\_$_.txt" } @procTS; - - print "$__{'Data'}"; - if ($OUTG ne "" && isok($NODE{VALID}) && ($GRID{'URLDATA'} ne "" || $GRID{'FORM'} ne "" || $#glist >= 0 || $#dlist >= 0)) { - print "\n"; - print "
        "; - if ($GRID{'FORM'} ne "") { - %FORM = readCfg("$WEBOBS{PATH_FORMS}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); - my $txt = $FORM{TITLE} // "$__{'Data bank'}"; - my $url = "/cgi-bin/$FORM{CGI_SHOW}"; - print "$__{'Form'}: $txt
        "; - } - if ($GRID{'URLDATA'} ne "") { - my $rep = "$GRID{'RAWDATA'}"; - print "$__{'Raw data'}: $rep
        "; - if ($#dlist >= 0) { - print "$__{'ASCII data file(s)'}"; - for (@dlist) { - my $z = basename $_; - print "$z "; # ??? type# - } - print "
        "; - } - } - if ($#glist >= 0) { - print "$__{'Outputs'}: $GRIDName
        "; - } - print "        		"; - for (@glist) { - my $tmp = basename $_; - chomp($tmp); - my ($name,$ext) = split(/\./,$tmp); - my ($node,$time) = split(/_/,$name); - my $vignette = "PROC.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}/$name.jpg"; - if (-e "$WEBOBS{ROOT_OUTG}/$vignette") { - $vignette = "$WEBOBS{URN_OUTG}/$vignette"; - my $tmp2 = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName&ts=$time&g=$node"; - my $message = "$__{'Click to enlarge'}
        "; - $message = $message."Image=$tmp
        "; - print "\"$vignette\""; - } - } - print "
        \n"; - } - print "\n"; - - # channels (calibration file) - my %carCLB = readCLB("$GRIDType.$GRIDName.$NODEName"); - print ""; - my $txt = $__{'Channels'}; - if ($editOK) { - if (scalar(keys %carCLB) > 0) { - print "$txt"; - } else { - print "$txt"; - } - } else { - print "$txt"; - } - print ""; - if (scalar(keys %carCLB) > 0) { - my @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); - my %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); - unless ( isok($theiaAuth) ) { delete($fieldCLB{"THEIA_CATEGORY"}); } - my @params; - foreach my $k (sort { $fieldCLB{$a}{'_SO_'} <=> $fieldCLB{$b}{'_SO_'} } keys %fieldCLB) { push(@params, $k); } - - print ""; - foreach my $k ( @params ) { - print ""; - } - print "\n"; - my @select = split(/,/,$chanlist); - my $dateCLB = ""; - my $sepCLB; - foreach my $k (sort keys %carCLB) { - my @chpCLB; - foreach my $p ( @params ) { push(@chpCLB, $carCLB{$k}{$p}) } - if ($#chpCLB < $#params) { - push(@chpCLB, ("") x ($#params - $#chpCLB)); - } - pop(@chpCLB) if ( !$theiaAuth && $#chpCLB > $#params ); - if ($dateCLB ne "" && $dateCLB ne $chpCLB[0]) { - $sepCLB = "\n"; - print $sepCLB; - } - $dateCLB = $chpCLB[0]; - my $active = "style=\"".($chpCLB[2] ~~ @select || $chanlist == "" ? "font-weight:bold":"color:gray")."\""; - print ""; - } - print "$sepCLB
        ",$fieldCLB{$k}{"Name"}."
        ".join("",@chpCLB)."
        \n"; - print "
        @clbNote"; - } else { - print "no channel defined"; - } - print "\n"; + print ""; + if ($editOK) { print "Proc" } + else { print "Proc" } + printf ""; + + # --- parameters + my $txt = "$__{'Parameters'}"; + if ($editOK > 1) { print "$txt" } + elsif ($editOK) { print "$txt" } + else { print "$txt" } + print ""; + + #print "ID: $NODEName"; + print "FID: ".($fid ne "" ? "$fid":"$__{undefined}")."\n"; + print "
        Network: $fdsn ($FDSN{$fdsn})\n" if ($fdsn ne ""); + print "
        $fids" if ($fids ne ""); + print "
        Raw Format: $rawFormats{$rawformat}{supfmt} / $rawformat ($rawFormats{$rawformat}{name})" if ($rawformat ne ""); + print "
        Raw Data Source: $rawdata" if ($rawdata ne ""); + print "\n"; + + # --- description + print "$__{'Description'}$desc\n"; + + # --- status + print "$__{'Status'}" + .""; # Date de l'analyse de l'etat + if ($endDate eq "NA") { + print ""; + print ""; + } + } + print "
        "; + print "Acquisition Period: ".($acqrate ne "" ? "$acqrate days":"not set")."
        "; + print "Acquisition Delay: ".($acqdelay ne "" ? "$acqdelay days":"not set")."
        "; + if ($statusNODE ne "") { + my @status = split(/\|/,$statusNODE); + my $bgcolEt = ""; + my $bgcolA = ""; + if ($status[1] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolEt = "status-standby"; $status[1] = "Standby"; } # grey/gray + elsif ($status[1] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolEt = "status-critical"; $status[1] .= "%"; } + elsif ($status[1] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolEt = "status-ok"; $status[1] .= "%"; } + else { $bgcolEt="status-warning"; $status[1] .= "%"; } + if ($status[2] == $NODES{STATUS_STANDBY_VALUE}) { $bgcolA = "status-standby"; $status[2] = "Standby"; } + elsif ($status[2] < $NODES{STATUS_THRESHOLD_CRITICAL}) { $bgcolA = "status-critical"; $status[2] .= "%"; } + elsif ($status[2] >= $NODES{STATUS_THRESHOLD_WARNING}) { $bgcolA = "status-ok"; $status[2] .= "%"; } + else { $bgcolA="status-warning"; $status[2] .= "%"; } + print "        		$__{'Last status check on'} $status[4]$__{'Sampl.'}: $status[2]$__{'Status'}: $status[1]
        \n"; + + # data (data & graphs from proc) + my $OUTG = ""; + if (-d "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName" ) { + $OUTG = "$WEBOBS{ROOT_OUTG}/PROC.$GRIDName"; + } + my (@glist) = map { "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/$NODENameLower\_$_.png" } @procTS; + my (@dlist) = map { "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/$NODENameLower\_$_.txt" } @procTS; + + print "$__{'Data'}"; + if ($OUTG ne "" && isok($NODE{VALID}) && ($GRID{'URLDATA'} ne "" || $GRID{'FORM'} ne "" || $#glist >= 0 || $#dlist >= 0)) { + print "\n"; + print "
        "; + if ($GRID{'FORM'} ne "") { + %FORM = readCfg("$WEBOBS{PATH_FORMS}/$GRID{'FORM'}/$GRID{'FORM'}.conf"); + my $txt = $FORM{TITLE} // "$__{'Data bank'}"; + my $url = "/cgi-bin/$FORM{CGI_SHOW}"; + print "$__{'Form'}: $txt
        "; + } + if ($GRID{'URLDATA'} ne "") { + my $rep = "$GRID{'RAWDATA'}"; + print "$__{'Raw data'}: $rep
        "; + if ($#dlist >= 0) { + print "$__{'ASCII data file(s)'}"; + for (@dlist) { + my $z = basename $_; + print "$z "; # ??? type# + } + print "
        "; + } + } + if ($#glist >= 0) { + print "$__{'Outputs'}: $GRIDName
        "; + } + print "        		"; + for (@glist) { + my $tmp = basename $_; + chomp($tmp); + my ($name,$ext) = split(/\./,$tmp); + my ($node,$time) = split(/_/,$name); + my $vignette = "PROC.$GRIDName/$WEBOBS{PATH_OUTG_GRAPHS}/$name.jpg"; + if (-e "$WEBOBS{ROOT_OUTG}/$vignette") { + $vignette = "$WEBOBS{URN_OUTG}/$vignette"; + my $tmp2 = "/cgi-bin/showOUTG.pl?grid=PROC.$GRIDName&ts=$time&g=$node"; + my $message = "$__{'Click to enlarge'}
        "; + $message = $message."Image=$tmp
        "; + print "\"$vignette\""; + } + } + print "
        \n"; + } + print "\n"; + + # channels (calibration file) + my %carCLB = readCLB("$GRIDType.$GRIDName.$NODEName"); + print ""; + my $txt = $__{'Channels'}; + if ($editOK) { + if (scalar(keys %carCLB) > 0) { + print "$txt"; + } else { + print "$txt"; + } + } else { + print "$txt"; + } + print ""; + if (scalar(keys %carCLB) > 0) { + my @clbNote = wiki2html(join("",readFile($CLBS{NOTES}))); + my %fieldCLB = readCfg($CLBS{FIELDS_FILE}, "sorted"); + unless ( isok($theiaAuth) ) { delete($fieldCLB{"THEIA_CATEGORY"}); } + my @params; + foreach my $k (sort { $fieldCLB{$a}{'_SO_'} <=> $fieldCLB{$b}{'_SO_'} } keys %fieldCLB) { push(@params, $k); } + + print ""; + foreach my $k ( @params ) { + print ""; + } + print "\n"; + my @select = split(/,/,$chanlist); + my $dateCLB = ""; + my $sepCLB; + foreach my $k (sort keys %carCLB) { + my @chpCLB; + foreach my $p ( @params ) { push(@chpCLB, $carCLB{$k}{$p}) } + if ($#chpCLB < $#params) { + push(@chpCLB, ("") x ($#params - $#chpCLB)); + } + pop(@chpCLB) if ( !$theiaAuth && $#chpCLB > $#params ); + if ($dateCLB ne "" && $dateCLB ne $chpCLB[0]) { + $sepCLB = "\n"; + print $sepCLB; + } + $dateCLB = $chpCLB[0]; + my $active = "style=\"".($chpCLB[2] ~~ @select || $chanlist == "" ? "font-weight:bold":"color:gray")."\""; + print ""; + } + print "$sepCLB
        ",$fieldCLB{$k}{"Name"}."
        ".join("",@chpCLB)."
        \n"; + print "
        @clbNote"; + } else { + print "no channel defined"; + } + print "\n"; } - # Row "installation" # my $RinfoInstallFile = "installation.txt"; my $infoInstallFile = "$NODES{PATH_NODES}/$NODEName/$RinfoInstallFile"; my @infosInstallNode = (""); if ((-e $infoInstallFile) && (-s $infoInstallFile != 0)) { - @infosInstallNode = grep(!/^$/,readFile($infoInstallFile)); + @infosInstallNode = grep(!/^$/,readFile($infoInstallFile)); } if ($editOK || $#infosInstallNode >=0) { - print ""; - my $txt = $__{'Installation'}; - print ($editOK ? "$txt":$txt); - print "".wiki2html(join("",@infosInstallNode))."\n"; + print ""; + my $txt = $__{'Installation'}; + print ($editOK ? "$txt":$txt); + print "".wiki2html(join("",@infosInstallNode))."\n"; } # Row "M3G" # if ( $NODE{GNSS_9CHAR} && $NODE{M3G_AVAIABLE} ) { - print ""; - my $txt = $__{'M3G GNSS Metadata'}; - my $gnss9char = $NODE{GNSS_9CHAR}; - my $gmlfile = "$NODES{PATH_NODES}/$NODEName/$gnss9char.xml"; - my $m3g_url_sitelog = $WEBOBS{'M3G_EXPORTLOG'}.$gnss9char; - my $m3g_url_gml = $WEBOBS{'M3G_EXPORTXML'}.$gnss9char; - my @rec; - my $txt_rec = "Receiver history feature"; - my @ant; - my $txt_ant = "Antenna history feature"; - - my $m3g_link_sitelog = "Download $gnss9char sitelog on your local disk"; - my $m3g_link_gml = "Download $gnss9char GeodesyML on your local disk"; - - if (-e $gmlfile) { - @rec = gml2mmdtable($gmlfile,"gnssrec"); - chomp(@rec); - $txt_rec = join("\n",@rec); - @ant = gml2mmdtable($gmlfile,"gnssant"); - chomp(@ant); - $txt_ant = join("\n",@ant); - } - - #### get geodesyML from M3G - my $GetGml = "/cgi-bin/get_gml_m3g.pl"; - my $m3g_xml = "Import GNSS metadata from M3G"; - - if ($editOK) { - print "$txt"; - } else { - print "M3G GNSS Metadata"; - } #print "".join("
        ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml,$txt_rec,$txt_ant)."\n"; - print "".join("
        ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml)."
        \n"; - print "
        Receiver history featureAntenna history feature
        ".wiki2html($txt_rec)."".wiki2html($txt_ant)."
        "; + print ""; + my $txt = $__{'M3G GNSS Metadata'}; + my $gnss9char = $NODE{GNSS_9CHAR}; + my $gmlfile = "$NODES{PATH_NODES}/$NODEName/$gnss9char.xml"; + my $m3g_url_sitelog = $WEBOBS{'M3G_EXPORTLOG'}.$gnss9char; + my $m3g_url_gml = $WEBOBS{'M3G_EXPORTXML'}.$gnss9char; + my @rec; + my $txt_rec = "Receiver history feature"; + my @ant; + my $txt_ant = "Antenna history feature"; + + my $m3g_link_sitelog = "Download $gnss9char sitelog on your local disk"; + my $m3g_link_gml = "Download $gnss9char GeodesyML on your local disk"; + + if (-e $gmlfile) { + @rec = gml2mmdtable($gmlfile,"gnssrec"); + chomp(@rec); + $txt_rec = join("\n",@rec); + @ant = gml2mmdtable($gmlfile,"gnssant"); + chomp(@ant); + $txt_ant = join("\n",@ant); + } + + #### get geodesyML from M3G + my $GetGml = "/cgi-bin/get_gml_m3g.pl"; + my $m3g_xml = "Import GNSS metadata from M3G"; + + if ($editOK) { + print "$txt"; + } else { + print "M3G GNSS Metadata"; + } #print "".join("
        ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml,$txt_rec,$txt_ant)."\n"; + print "".join("
        ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml)."
        \n"; + print "
        Receiver history featureAntenna history feature
        ".wiki2html($txt_rec)."".wiki2html($txt_ant)."
        "; } - - # Row "infos" # my $RinfoFile = "info.txt"; my $infoFile = "$NODES{PATH_NODES}/$NODEName/$RinfoFile"; my @txt = (""); if ((-e $infoFile) && (-s $infoFile != 0)) { - @txt = readFile("$infoFile"); + @txt = readFile("$infoFile"); } if ($editOK) { - print "$__{Information}".wiki2html(join("",@txt))."\n"; + print "$__{Information}".wiki2html(join("",@txt))."\n"; } elsif ($#txt >= 0) { - print "$__{Information}".wiki2html(join("",@txt))."\n"; + print "$__{Information}".wiki2html(join("",@txt))."\n"; } # Row "access" @@ -656,15 +653,14 @@ =head1 Query string parameters my $accessFile="$NODES{PATH_NODES}/$NODEName/$RaccessFile"; @txt = (""); if ((-e $accessFile) && (-s $accessFile != 0)) { - @txt = readFile("$accessFile"); + @txt = readFile("$accessFile"); } if ($editOK) { - print "$__{Access}".wiki2html(join("",@txt))."\n"; + print "$__{Access}".wiki2html(join("",@txt))."\n"; } elsif ($#txt >= 0) { - print "$__{Access}".wiki2html(join("",@txt))."\n"; + print "$__{Access}".wiki2html(join("",@txt))."\n"; } - # Rows "Features" # my @listeFinaleCarFiles=(""); @@ -675,43 +671,44 @@ =head1 Query string parameters # first insert 'parent' features from $NODES{FILE_NODES2NODES} for NODEName my $pseudoFileName = ""; for my $key_link (keys %node2node) { - my @children_node_list = split(/\|/,$node2node{$key_link}); - for (@children_node_list) { - if ( $_ eq $NODEName ) { - my @data = split(/\|/,$key_link); - my $parent_node = $data[0]; - my $feature = $data[1]; - $pseudoFileName = "ISOF:$feature"; - $lienNode{$pseudoFileName} .= (exists($lienNode{$pseudoFileName}) ? "
        ":"").getNodeString(node=>$parent_node, link=>'node'); - } - } + my @children_node_list = split(/\|/,$node2node{$key_link}); + for (@children_node_list) { + if ( $_ eq $NODEName ) { + my @data = split(/\|/,$key_link); + my $parent_node = $data[0]; + my $feature = $data[1]; + $pseudoFileName = "ISOF:$feature"; + $lienNode{$pseudoFileName} .= (exists($lienNode{$pseudoFileName}) ? "
        ":"").getNodeString(node=>$parent_node, link=>'node'); + } + } } push(@listeFinaleCarFiles,keys(%lienNode)) ; # now add features defined in the $NODEName cnf file my @listeCarFiles=split(/\||,/,$NODE{FILES_FEATURES}); for (@listeCarFiles) { - my $carFileName = $_; - my $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; - my $key_link = $NODEName."|".$carFileName; - $lienNode{$carFileName} = ""; - $lien_car = 0; - if ( exists($node2node{$key_link}) ) { - my @liste_liens=split(/\|/,$node2node{$key_link}); - for (@liste_liens) { - if ( length($_) > 0 ) { - $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "
        ").getNodeString(node=>$_, style=>'html', link=>'features').""; - } - } - if ( $lienNode{$carFileName} ne "" ) { - $lienNode{$carFileName} .= "

        "; - } - $lien_car = 1; - } - #FB-was: if ((-e $carFile && (-s $carFile || $editOK)) || $lien_car == 1) { - if ((-e $carFile || $editOK) || $lien_car == 1) { - push(@listeFinaleCarFiles,$carFileName); - } + my $carFileName = $_; + my $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; + my $key_link = $NODEName."|".$carFileName; + $lienNode{$carFileName} = ""; + $lien_car = 0; + if ( exists($node2node{$key_link}) ) { + my @liste_liens=split(/\|/,$node2node{$key_link}); + for (@liste_liens) { + if ( length($_) > 0 ) { + $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "
        ").getNodeString(node=>$_, style=>'html', link=>'features').""; + } + } + if ( $lienNode{$carFileName} ne "" ) { + $lienNode{$carFileName} .= "

        "; + } + $lien_car = 1; + } + + #FB-was: if ((-e $carFile && (-s $carFile || $editOK)) || $lien_car == 1) { + if ((-e $carFile || $editOK) || $lien_car == 1) { + push(@listeFinaleCarFiles,$carFileName); + } } # 2) build output from 'final' list of features @@ -719,37 +716,37 @@ =head1 Query string parameters my @carNode; my $carFile; if ($lignes > 0) { - print ""; - if ($editOK) { - print "$__{Features}"; - } else { - print "$__{Features}"; - } - print ""; - @listeFinaleCarFiles = grep(!/^$/, @listeFinaleCarFiles); - for (@listeFinaleCarFiles) { - my $carFileName = $_; - if ( /^ISOF:/ ) { - @carNode = $lienNode{$_}; - s/^ISOF://g; - $carFileName = $_." of"; - } else { - $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; - @carNode = readFile($carFile); - if ( "@carNode" eq "") { - @carNode = (" "); - } - @carNode = (wiki2html(join("",@carNode))); - } - print "" if ($_ ne $listeFinaleCarFiles[0]); - if ($editOK && !($carFileName =~ / of$/)) { - print "$carFileName\n"; - } else { - print "$carFileName\n"; - } - my $lien = (exists($lienNode{$carFileName}) ? $lienNode{$carFileName}:""); - print "$lien@carNode\n"; - } + print ""; + if ($editOK) { + print "$__{Features}"; + } else { + print "$__{Features}"; + } + print ""; + @listeFinaleCarFiles = grep(!/^$/, @listeFinaleCarFiles); + for (@listeFinaleCarFiles) { + my $carFileName = $_; + if ( /^ISOF:/ ) { + @carNode = $lienNode{$_}; + s/^ISOF://g; + $carFileName = $_." of"; + } else { + $carFile = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; + @carNode = readFile($carFile); + if ( "@carNode" eq "") { + @carNode = (" "); + } + @carNode = (wiki2html(join("",@carNode))); + } + print "" if ($_ ne $listeFinaleCarFiles[0]); + if ($editOK && !($carFileName =~ / of$/)) { + print "$carFileName\n"; + } else { + print "$carFileName\n"; + } + my $lien = (exists($lienNode{$carFileName}) ? $lienNode{$carFileName}:""); + print "$lien@carNode\n"; + } } # ---- PHOTOS,SCHEMAS,DOCUMENTS common stuff @@ -762,115 +759,124 @@ =head1 Query string parameters # Row "PHOTOS" ---------------------------------------------------------------- # $Fpath = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_PHOTOS}"; + #FB-was: ( $Furn = $Fpath) =~ s/$WEBOBS{ROOT_SITE}/../g; ( $Furn = $Fpath) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; $Tpath = "$Fpath/$NODES{SPATH_THUMBNAILS}"; qx(mkdir -p $Tpath) if (!-d $Tpath); my @listePhotos = <$Fpath/*.{jpg,jpeg,JPG,JPEG,HEIC}*> ; + #DL-was:my $uploadPHOTOS = "$WEBOBS{CGI_UPLOAD}?node=$GRIDType.$GRIDName.$NODEName&doc=$NODES{SPATH_PHOTOS}"; my $uploadPHOTOS = "$WEBOBS{CGI_UPLOAD}?object=$GRIDType.$GRIDName.$NODEName&doc=SPATH_PHOTOS"; if ($editOK) { - print "$__{Photos}"; + print "$__{Photos}"; } elsif ($#listePhotos >= 0) { - print "$__{Photos}"; + print "$__{Photos}"; } chomp(@listePhotos); if ($#listePhotos >= 0) { - for (@listePhotos) { - $Fn = basename($_); - $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); - ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); - #FB-was: ( $Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; - ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $olmsg = htmlspecialchars(__x("Click to enlarge
        Image={image}
        Date=$Fts
        Size=$Fwh",image=>$Fn)); - print "\"".__x('Image$Furn."/".$Fn)."\">\n"; - #print "\"".__x('Image$Furn."/".$Fn)."\">\n"; - } + for (@listePhotos) { + $Fn = basename($_); + $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); + ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); + + #FB-was: ( $Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; + ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $olmsg = htmlspecialchars(__x("Click to enlarge
        Image={image}
        Date=$Fts
        Size=$Fwh",image=>$Fn)); + print "\"".__x('Image$Furn."/".$Fn)."\">\n"; + +#print "\"".__x('Image$Furn."/".$Fn)."\">\n"; + } } if ($editOK || $#listePhotos >= 0) { - print "\n"; + print "\n"; } # Row "SCHEMES" --------------------------------------------------------------- # $Fpath = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_SCHEMES}"; + #FB-was: ($Furn = $Fpath) =~ s/$WEBOBS{ROOT_SITE}/../g; ( $Furn = $Fpath) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; $Tpath = "$Fpath/$NODES{SPATH_THUMBNAILS}"; qx(mkdir -p $Tpath) if (!-d $Tpath); my @listeSchemas = <$Fpath/*.*> ; + #DL-was:my $uploadSCHEMAS = "$WEBOBS{CGI_UPLOAD}?node=$GRIDType.$GRIDName.$NODEName&doc=$NODES{SPATH_SCHEMES}"; my $uploadSCHEMAS = "$WEBOBS{CGI_UPLOAD}?object=$GRIDType.$GRIDName.$NODEName&doc=SPATH_SCHEMES"; if ($editOK) { - print "$__{Diagrams}"; + print "$__{Diagrams}"; } elsif ($#listeSchemas >= 0) { - print "$__{Diagrams}"; + print "$__{Diagrams}"; } chomp(@listeSchemas); if ($#listeSchemas >= 0) { - for (@listeSchemas) { - $Fn = basename($_); - print ""; - if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { - $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); - if ($TFn ne "") { - #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; - ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); - ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $olmsg = htmlspecialchars(__x("Click to enlarge
        Image={image}
        Size=$Fwh",image=>$Fn)); - print "\"".__x('Image$Furn."/".$Fn)."\">"; - } else { print "$Fn
        " } - } else { print "$Fn
        " } - print "        \n"; - } + for (@listeSchemas) { + $Fn = basename($_); + print ""; + if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { + $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); + if ($TFn ne "") { + + #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; + ($Fts,$Fwh) = split(/\|/,getImageInfo($_)); + ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $olmsg = htmlspecialchars(__x("Click to enlarge
        Image={image}
        Size=$Fwh",image=>$Fn)); + print "\"".__x('Image$Furn."/".$Fn)."\">"; + } else { print "$Fn
        " } + } else { print "$Fn
        " } + print "        \n"; + } } if ($editOK || $#listeSchemas >= 0) { - print "\n"; + print "\n"; } # Row "DOCUMENTS" ------------------------------------------------------------- # $Fpath = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_DOCUMENTS}"; + #FB-was: ($Furn = $Fpath) =~ s/$WEBOBS{ROOT_SITE}/../g; ( $Furn = $Fpath) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; $Tpath = "$Fpath/$NODES{SPATH_THUMBNAILS}"; qx(mkdir -p $Tpath) if (!-d $Tpath); my @listeDocuments = <$Fpath/*.*> ; + #DL-was:my $uploadDOCUMENTS = "$WEBOBS{CGI_UPLOAD}?node=$GRIDType.$GRIDName.$NODEName&doc=$NODES{SPATH_DOCUMENTS}"; my $uploadDOCUMENTS = "$WEBOBS{CGI_UPLOAD}?object=$GRIDType.$GRIDName.$NODEName&doc=SPATH_DOCUMENTS"; if ($editOK) { - print "$__{Documents}"; + print "$__{Documents}"; } elsif ($#listeDocuments >= 0) { - print "$__{Documents}"; + print "$__{Documents}"; } chomp(@listeDocuments); if ($#listeDocuments >= 0) { - for (@listeDocuments) { - $Fn = basename($_); - print ""; - if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { - $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); - if ($TFn ne "") { - #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; - ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $olmsg = htmlspecialchars(__x("Click to download
        File={file}",file=>$Fn)); - print "\"".__x('Image$Furn."/".$Fn)."\">"; - } else { print "$Fn
        "; } - } else { print "$Fn
        "; } - print "        \n"; - } + for (@listeDocuments) { + $Fn = basename($_); + print ""; + if ($NODES{THUMBNAILS_ON} eq 'ALL' ) { + $TFn = makeThumbnail($_, "x$NODES{THUMBNAILS_PIXV}", $Tpath, $NODES{THUMBNAILS_EXT}); + if ($TFn ne "") { + + #FB-was: ($Turn = $TFn) =~ s/$WEBOBS{ROOT_SITE}/../g; + ( $Turn = $TFn) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $olmsg = htmlspecialchars(__x("Click to download
        File={file}",file=>$Fn)); + print "\"".__x('Image$Furn."/".$Fn)."\">"; + } else { print "$Fn
        "; } + } else { print "$Fn
        "; } + print "        \n"; + } } if ($editOK || $#listeDocuments >= 0) { - print "\n"; + print "\n"; } # # ---- end of node table ------------------------------------------------------ print ""; - # ---- Project ---------------------------------------------------------------- # print "
        \n"; @@ -890,7 +896,7 @@ =head1 Query string parameters if ($editOK) { print "  " } print " $go2top

        "; print " $__{'Sort by'} [ ".($sortBy ne "event" ? "$__{'Event'}":"$__{'Event'}")." | " - .($sortBy ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
        \n"; + .($sortBy ne "date" ? "$__{'Date'}":"$__{'Date'}")." ]
        \n"; my $htmlEvents = ($sortBy =~ /event/i) ? eventsShow("events","$GRIDType.$GRIDName.$NODEName", $editOK) : eventsShow("date","$GRIDType.$GRIDName.$NODEName", $editOK); print $htmlEvents; print "
        "; @@ -898,7 +904,6 @@ =head1 Query string parameters # --- we're done !!!! print "

        \n\n\n"; - __END__ =pod diff --git a/CODE/cgi-bin/showNODES.pl b/CODE/cgi-bin/showNODES.pl index 4efc585b..ef065243 100755 --- a/CODE/cgi-bin/showNODES.pl +++ b/CODE/cgi-bin/showNODES.pl @@ -29,16 +29,16 @@ =head1 DESCRIPTION # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } # get all GRIDs with a minimum read auth my @T; for (sort(WebObs::Grids::listViewNames())) { - push(@T, "VIEW.$_") if (clientHasRead(type=>"authviews",name=>"$_")); + push(@T, "VIEW.$_") if (clientHasRead(type=>"authviews",name=>"$_")); } for (sort(WebObs::Grids::listProcNames())) { - push(@T, "PROC.$_") if (clientHasRead(type=>"authprocs",name=>"$_")); + push(@T, "PROC.$_") if (clientHasRead(type=>"authprocs",name=>"$_")); }; # get all NODE IDs with grid association @@ -83,39 +83,39 @@ =head1 DESCRIPTION # ---- build matrix as a print "
        "; print "
        \n"; - print ""; - my $oddeven = "even"; my $what = 'view'; - $row = ""; - for (@T) { - $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; - $row .= ""; - $oddeven = $oddeven eq "even" ? "odd" : "even"; - } - print "$row\n"; - print "\n"; - - print ""; - for my $node (sort keys(%N)) { - my $oddeven = "even"; - $row = ""; - if (@{$N{$node}}) { - for (@T) { - $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; - if ($_ ~~ @{$N{$node}}) { - my $link = "\"$NODES{CGI_SHOW}?node=$_.$node\""; - $row .= "" - } - else { - $row .= "" - } - $oddeven = $oddeven eq "even" ? "odd" : "even"; - } - } else { - $row .= "\n"; - } - print $row; - } - print ""; +print ""; +my $oddeven = "even"; my $what = 'view'; +$row = ""; +for (@T) { + $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; + $row .= ""; + $oddeven = $oddeven eq "even" ? "odd" : "even"; +} +print "$row\n"; +print "\n"; + +print ""; +for my $node (sort keys(%N)) { + my $oddeven = "even"; + $row = ""; + if (@{$N{$node}}) { + for (@T) { + $what = ($_ =~ m/^VIEW./) ? 'view' : 'proc'; + if ($_ ~~ @{$N{$node}}) { + my $link = "\"$NODES{CGI_SHOW}?node=$_.$node\""; + $row .= "" + } + else { + $row .= "" + } + $oddeven = $oddeven eq "even" ? "odd" : "even"; + } + } else { + $row .= "\n"; + } + print $row; +} +print ""; print "
        $_
        $node○∅
        $_
        $node○∅
        "; print "\n"; diff --git a/CODE/cgi-bin/showNOVAC.pl b/CODE/cgi-bin/showNOVAC.pl index 2096f543..d0b76f8f 100755 --- a/CODE/cgi-bin/showNOVAC.pl +++ b/CODE/cgi-bin/showNOVAC.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showNOVAC.pl @@ -99,20 +100,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -138,31 +139,31 @@ =head1 Query string parameters my @cleParamAnnee = ("Old|Old"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my $titrePage = $FORM->conf('TITLE'); my @option = (); -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "All"; -$QryParm->{'site'} ||= "All"; -$QryParm->{'affiche'} ||= ""; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "All"; +$QryParm->{'site'} ||= "All"; +$QryParm->{'affiche'} ||= ""; # ---- a site requested as {name} means "all nodes for grid (proc) 'name'" # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -172,8 +173,8 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n + print $cgi->header(-charset=>'utf-8'); + print "\n \n \n $titrePage\n @@ -192,57 +193,57 @@ =head1 Query string parameters # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print "\n + print "\n
        conf('CGI_SHOW')."\" method=\"get\">\n

        \n Select: \n \n \n \n "; - if ($editOK) { - print "\n + if ($editOK) { + print "\n conf('CGI_FORM')."'\" value=\"new record\"/>"; - } - print "\n + } + print "\n

        \n
        \n

        $titrePage

        \n @@ -269,8 +270,9 @@ =head1 Query string parameters $tableHeader = ""; if ($editOK) { - $tableHeader = $tableHeader.""; + $tableHeader = $tableHeader.""; } + # ------------------------------------------------------------ # ---- start of specific NOVAC form code --------------------- # ------------------------------------------------------------ @@ -286,47 +288,48 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,u2l("$date;Code Site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans")); - } - elsif (($_ ne "") - && (($QryParm->{'site'} eq "All") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "All") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Old") && ($date lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "All") || ($QryParm->{'mois'} eq substr($date,5,2)))) { - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($editOK) { - $texte = $texte."$modif"; - } - $texte = $texte."$date$lien$flux1" - ."$flux2$windSpeed" - ."$windSpeedSource$windDirection" - ."$windDirectionSource$compassDirection" - ."$coneAngle$tilt" - ."$plumeHeight$plumeHeightSource" - ."$offset$plumeCentre" - ."$plumeEdge1$plumeEdge2" - ."$plumeCompleteness$geomError" - ."$spectrometerError$scatteringError" - ."$windError$nbValidScans"; - $texte = $texte.""; - $txt = "$date;$site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$site,$flux1,$flux2,$windSpeed,$windSpeedSource,$windDirection,$windDirectionSource,$compassDirection,$coneAngle,$tilt,$plumeHeight,$plumeHeightSource,$offset,$plumeCentre,$plumeEdge1,$plumeEdge2,$plumeCompleteness,$geomError,$spectrometerError,$scatteringError,$windError,$nbValidScans) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,u2l("$date;Code Site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans")); + } + elsif (($_ ne "") + && (($QryParm->{'site'} eq "All") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "All") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Old") && ($date lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "All") || ($QryParm->{'mois'} eq substr($date,5,2)))) { + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($editOK) { + $texte = $texte."$modif"; + } + $texte = $texte."$date$lien$flux1" + ."$flux2$windSpeed" + ."$windSpeedSource$windDirection" + ."$windDirectionSource$compassDirection" + ."$coneAngle$tilt" + ."$plumeHeight$plumeHeightSource" + ."$offset$plumeCentre" + ."$plumeEdge1$plumeEdge2" + ."$plumeCompleteness$geomError" + ."$spectrometerError$scatteringError" + ."$windError$nbValidScans"; + $texte = $texte.""; + $txt = "$date;$site;$flux1;$flux2;$windSpeed;$windSpeedSource;$windDirection;$windDirectionSource;$compassDirection;$coneAngle;$tilt;$plumeHeight;$plumeHeightSource;$offset;$plumeCentre;$plumeEdge1;$plumeEdge2;$plumeCompleteness;$geomError;$spectrometerError;$scatteringError;$windError;$nbValidScans"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } + # ------------------------------------------------------------ # ---- end of specific NOVAC HTML code ----------------------- # ------------------------------------------------------------ @@ -339,7 +342,7 @@ =head1 Query string parameters

        \n"); if ($texte ne "") { - push(@html,"\n + push(@html,"\n \n $tableHeader\n $texte\n @@ -348,10 +351,10 @@ =head1 Query string parameters } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n + print @html; + print "\n \n diff --git a/CODE/cgi-bin/showOUTG.pl b/CODE/cgi-bin/showOUTG.pl index 51860986..8d8569e9 100755 --- a/CODE/cgi-bin/showOUTG.pl +++ b/CODE/cgi-bin/showOUTG.pl @@ -55,6 +55,7 @@ =head1 DESCRIPTION use Locale::TextDomain('webobs'); use POSIX qw/setlocale LC_ALL strftime/; + #use Encode; #my ($strftime_encoding)= setlocale(LC_ALL); #sub strftime2 { # try to return an utf8 value from strftime @@ -73,21 +74,20 @@ =head1 DESCRIPTION my $QryParm = $cgi->Vars; my @GID = split(/[\.\/]/, trim($QryParm->{'grid'})); - # ---- what grid do we have to process ? any showstoppers ? if (scalar(@GID) == 2) { - ($GRIDType, $GRIDName) = @GID; - if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } - elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } - if (%G) { - %GRID = %{$G{$GRIDName}} ; - if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"$GRIDName") || WebObs::Users::clientHasRead(type=>"authviews",name=>"$GRIDName") ) { - $RESOURCE = "authmisc/$GRIDName"; - if (-d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName" ) { - $OUTG = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName"; - } else { die "$__{'No outputs for'} $GRIDType.$GRIDName" } - } else { die "$__{'Not authorized'} $GRIDName (read)"} - } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } + ($GRIDType, $GRIDName) = @GID; + if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } + elsif (uc($GRIDType) eq 'PROC') { %G = readProc($GRIDName) } + if (%G) { + %GRID = %{$G{$GRIDName}} ; + if ( WebObs::Users::clientHasRead(type=>"authprocs",name=>"$GRIDName") || WebObs::Users::clientHasRead(type=>"authviews",name=>"$GRIDName") ) { + $RESOURCE = "authmisc/$GRIDName"; + if (-d "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName" ) { + $OUTG = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName"; + } else { die "$__{'No outputs for'} $GRIDType.$GRIDName" } + } else { die "$__{'Not authorized'} $GRIDName (read)"} + } else { die "$__{'Could not read'} $GRIDType.$GRIDName configuration" } } else { die "$__{'Not a valid GRID requested (NOT gridtype.gridname)'}" } # ---- good, passed all validity/authorization checkings above @@ -99,29 +99,32 @@ =head1 DESCRIPTION if ($GRIDType eq 'VIEW' && $QryParm->{'ts'} eq '') { $QryParm->{'ts'} = 'map' } if ($QryParm->{'g'} =~ s!^lastevent(\b|$)!!) { - # "^lastevent" was removed from 'g': - # replace it with the directory the 'lastevent' symlink links to. - my $lastevent_dir = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/lastevent"); - # Remove ^$OUTG/events/ from the path to only keep "yyyy/mm/dd/eventid" - my $OUTGabs = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}"); - $lastevent_dir =~ s!$OUTGabs/!!; - # Replace 'g' with this link and append the remaining of the original 'g', if any - # (so that both g=lastevent and g=lastevent/b3 work). - $QryParm->{'g'} = $lastevent_dir.$QryParm->{'g'}; + + # "^lastevent" was removed from 'g': + # replace it with the directory the 'lastevent' symlink links to. + my $lastevent_dir = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/lastevent"); + + # Remove ^$OUTG/events/ from the path to only keep "yyyy/mm/dd/eventid" + my $OUTGabs = abs_path("$OUTG/$WEBOBS{PATH_OUTG_EVENTS}"); + $lastevent_dir =~ s!$OUTGabs/!!; + +# Replace 'g' with this link and append the remaining of the original 'g', if any +# (so that both g=lastevent and g=lastevent/b3 work). + $QryParm->{'g'} = $lastevent_dir.$QryParm->{'g'}; } # ---- initialize 'timescales' definitions my %TIMESCALES = ( - xxx => 'Manual', - r => 'Reference', - all => 'All Data', - s => 'second', - h => 'hour', - d => 'day', - w => 'week', - m => 'month', - y => 'year', -); + xxx => 'Manual', + r => 'Reference', + all => 'All Data', + s => 'second', + h => 'hour', + d => 'day', + w => 'week', + m => 'month', + y => 'year', + ); # ---- get the list of nodes currently belonging to grid # ---- and the list of possible summary grid's summary filenames @@ -137,7 +140,7 @@ =head1 DESCRIPTION print ""; if ($QryParm->{'refresh'} gt 0) { - print "{'refresh'}\">"; + print "{'refresh'}\">"; } print ""; print ""; @@ -159,333 +162,337 @@ =head1 DESCRIPTION my $baseurl = "/cgi-bin/showOUTG.pl?grid=$GRIDType.$GRIDName&refresh=$QryParm->{'refresh'}&header=$QryParm->{'header'}"; print "
        "; - # build $tslist = the list of defined timescales for proc from proc's configuration file - # and $tsSelected = index of the one currently selected (defaults to first item of $tslist) - my @tslist = split(/,/, $GRID{TIMESCALELIST}); - my $tsSelected = 0 ; - my $tsHtml = ""; - for my $i (0..$#tslist) { - my $ts = $tslist[$i]; - my $tsName = $ts; - # for backward compatibility (replaces some of old "timescales.conf" definitions) - $ts =~ s/a$|an$|yr$/y/; - $ts =~ s/j$/d/; - my $n = 1*substr($ts,0,-1); - if ($n > 0) { - $tsName = "$n $TIMESCALES{substr($ts,-1)}".($n > 1 ? "s":""); - } elsif (substr($ts,0,1) eq "r") { - my $r = 1*substr($ts,1); - $tsName = "$TIMESCALES{r}".($r > 0 ? " $r":""); - } elsif (defined($TIMESCALES{$ts})) { - $tsName = $TIMESCALES{$ts}; - } - if ($QryParm->{'ts'} eq $tslist[$i] ) { - $tsSelected = $i; - $tsHtml .= " $tsName |"; - } else { - $tsHtml .= " {'g'}\">$tsName |"; - } - } - chop($tsHtml); - print "»» [ ".ucfirst(lc($GRIDType))." "; - if ($QryParm->{'ts'} eq 'map' ) { - print "| Map "; - } elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_MAPS}") { - print "| Map "; - } - if ($QryParm->{'ts'} eq 'events' ) { - print "| Events "; - } elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { - print "| Events "; - } - if (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { - (my $EVTurn = $OUTG) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - print "| All files "; - - # build @nlist = the list of available nodes in events/*/*/*/ subdirectories - my (@ilist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????/*/*/*"; - my @nlist; - foreach (sort(keys(%DefinedNodes))) { - if (grep(/$_/i,@ilist)) { - push(@nlist,$_); - if ($QryParm->{'g'} =~ /$_/) { - print "| $DefinedNodes{$_}{ALIAS} "; - } else { - print "| $DefinedNodes{$_}{ALIAS} "; - } - } - } - } - if ($#tslist >= 0 && -d "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}") { - print "| Time scales: $tsHtml "; - } - print " | ]\n"; - - # build @elist = the list of available .eps graphs for timescale $tslist[$tsSelected] - my (@elist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.eps"; - - # build @slist = the list of available .svg graphs for timescale $tslist[$tsSelected] - my (@slist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.svg"; - - # build @plist = the list of available .pdf graphs for timescale $tslist[$tsSelected] - my (@plist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.pdf"; - - # build @dlist = the list of available data/**.* for timescale $tslist[$tsSelected] - my (@dlist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_$tslist[$tsSelected]*.*"; - - # build @ylist = the list of available events/* years - my (@ylist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????"; - - - # build @glist = the list of available .png graphs for timescale $tslist[$tsSelected] - # $glistHtml is the corresponding string of html hrefs to these graphs - # with each nodenames replaced with their alias if it is defined - my (@glist) = sort glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.png"; - my $glistHtml = ""; - if ($QryParm->{'ts'} eq 'events' ) { - if ($QryParm->{'g'} eq "") { - $QryParm->{'g'} = $ylist[$#ylist]; - $QryParm->{'g'} =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; - } - foreach (@ylist) { - my $year = $_; - $year =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; - if ($QryParm->{'g'} eq $year) { - $glistHtml .= " $year |"; - } else { - $glistHtml .= " $year |"; - } - } - } else { - my $lnk = "$baseurl&ts=$tslist[$tsSelected]&g="; - $glistHtml .= " Overview | "; - $glistHtml .= ($QryParm->{'g'} ne "col" ? "Column":"Column")." |"; - for my $fpath (@glist) { - my $gname = $fpath; - $gname =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_$tslist[$tsSelected].*$/$1/; - $gname =~ s/^$/SUMMARY/; - my $gbase = $gname; - $gbase =~ s/(.*)_.*$/$1/; - my $gmenu = $gname; - if ($gname ne 'SUMMARY' && !(grep( /^$gbase$/i, @SummaryList)) ) { - if ( grep( /^$gname$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc - my $alias = getNodeString(node=>uc($gname), style=>'alias'); - $gmenu = $alias if ( $alias ne '' && $alias ne '-' ); - } else { # it's a node file, but node NOT currently in proc == stale node that survived the housekeeping above - $gmenu = 'STALE'; - } - } - if ( $gmenu ne 'STALE' ) { - if ($QryParm->{'g'} eq $gname) { - $glistHtml .= " $gmenu |"; - } else { - $glistHtml .= " $gmenu |"; - } - } - } - } - chop($glistHtml); - if ($QryParm->{'ts'} ne 'map' ) { - print "
        [ ".$glistHtml." ]\n"; - } + .($QryParm->{'header'} eq 'no' ? " display:none":"")."'>"; + +# build $tslist = the list of defined timescales for proc from proc's configuration file +# and $tsSelected = index of the one currently selected (defaults to first item of $tslist) +my @tslist = split(/,/, $GRID{TIMESCALELIST}); +my $tsSelected = 0 ; +my $tsHtml = ""; +for my $i (0..$#tslist) { + my $ts = $tslist[$i]; + my $tsName = $ts; + +# for backward compatibility (replaces some of old "timescales.conf" definitions) + $ts =~ s/a$|an$|yr$/y/; + $ts =~ s/j$/d/; + my $n = 1*substr($ts,0,-1); + if ($n > 0) { + $tsName = "$n $TIMESCALES{substr($ts,-1)}".($n > 1 ? "s":""); + } elsif (substr($ts,0,1) eq "r") { + my $r = 1*substr($ts,1); + $tsName = "$TIMESCALES{r}".($r > 0 ? " $r":""); + } elsif (defined($TIMESCALES{$ts})) { + $tsName = $TIMESCALES{$ts}; + } + if ($QryParm->{'ts'} eq $tslist[$i] ) { + $tsSelected = $i; + $tsHtml .= " $tsName |"; + } else { + $tsHtml .= " {'g'}\">$tsName |"; + } +} +chop($tsHtml); +print "»» [ ".ucfirst(lc($GRIDType))." "; +if ($QryParm->{'ts'} eq 'map' ) { + print "| Map "; +} elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_MAPS}") { + print "| Map "; +} +if ($QryParm->{'ts'} eq 'events' ) { + print "| Events "; +} elsif (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { + print "| Events "; +} +if (-d "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}") { + (my $EVTurn = $OUTG) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + print "| All files "; + + # build @nlist = the list of available nodes in events/*/*/*/ subdirectories + my (@ilist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????/*/*/*"; + my @nlist; + foreach (sort(keys(%DefinedNodes))) { + if (grep(/$_/i,@ilist)) { + push(@nlist,$_); + if ($QryParm->{'g'} =~ /$_/) { + print "| $DefinedNodes{$_}{ALIAS} "; + } else { + print "| $DefinedNodes{$_}{ALIAS} "; + } + } + } +} +if ($#tslist >= 0 && -d "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}") { + print "| Time scales: $tsHtml "; +} +print " | ]\n"; + +# build @elist = the list of available .eps graphs for timescale $tslist[$tsSelected] +my (@elist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.eps"; + +# build @slist = the list of available .svg graphs for timescale $tslist[$tsSelected] +my (@slist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.svg"; + +# build @plist = the list of available .pdf graphs for timescale $tslist[$tsSelected] +my (@plist) = glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.pdf"; + +# build @dlist = the list of available data/**.* for timescale $tslist[$tsSelected] +my (@dlist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_$tslist[$tsSelected]*.*"; + +# build @ylist = the list of available events/* years +my (@ylist) = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/????"; + +# build @glist = the list of available .png graphs for timescale $tslist[$tsSelected] +# $glistHtml is the corresponding string of html hrefs to these graphs +# with each nodenames replaced with their alias if it is defined +my (@glist) = sort glob "$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_$tslist[$tsSelected]*.png"; +my $glistHtml = ""; +if ($QryParm->{'ts'} eq 'events' ) { + if ($QryParm->{'g'} eq "") { + $QryParm->{'g'} = $ylist[$#ylist]; + $QryParm->{'g'} =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; + } + foreach (@ylist) { + my $year = $_; + $year =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///; + if ($QryParm->{'g'} eq $year) { + $glistHtml .= " $year |"; + } else { + $glistHtml .= " $year |"; + } + } +} else { + my $lnk = "$baseurl&ts=$tslist[$tsSelected]&g="; + $glistHtml .= " Overview | "; + $glistHtml .= ($QryParm->{'g'} ne "col" ? "Column":"Column")." |"; + for my $fpath (@glist) { + my $gname = $fpath; + $gname =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_$tslist[$tsSelected].*$/$1/; + $gname =~ s/^$/SUMMARY/; + my $gbase = $gname; + $gbase =~ s/(.*)_.*$/$1/; + my $gmenu = $gname; + if ($gname ne 'SUMMARY' && !(grep( /^$gbase$/i, @SummaryList)) ) { + if ( grep( /^$gname$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc + my $alias = getNodeString(node=>uc($gname), style=>'alias'); + $gmenu = $alias if ( $alias ne '' && $alias ne '-' ); + } else { # it's a node file, but node NOT currently in proc == stale node that survived the housekeeping above + $gmenu = 'STALE'; + } + } + if ( $gmenu ne 'STALE' ) { + if ($QryParm->{'g'} eq $gname) { + $glistHtml .= " $gmenu |"; + } else { + $glistHtml .= " $gmenu |"; + } + } + } +} +chop($glistHtml); +if ($QryParm->{'ts'} ne 'map' ) { + print "
        [ ".$glistHtml." ]\n"; +} print "
        "; print "
        ".qrcode(2)."
        \n"; - # ---- now show the selected item # -- case 'Map' if ($QryParm->{'ts'} eq 'map') { - # only 1 map : *.png and its corresponding *.map - my $MAPpath = my $MAPurn = ""; - my @htmlarea; - $MAPpath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_MAPS}"; - ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - - my $mapname = "$GRIDType.$GRIDName"."_map"; - if ( -e "$MAPpath/$mapname.eps" ) { - print "\"$mapname.eps\"
        \n"; - } - if ( -e "$MAPpath/$mapname.png" ) { - print "
        \n"; - if (-e "$MAPpath/$mapname.map") { - @htmlarea = readFile("$MAPpath/$mapname.map"); - print "\n@htmlarea\n"; - } - } - -# -- case 'Events' + # only 1 map : *.png and its corresponding *.map + my $MAPpath = my $MAPurn = ""; + my @htmlarea; + $MAPpath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/$WEBOBS{PATH_OUTG_MAPS}"; + ( $MAPurn = $MAPpath ) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + + my $mapname = "$GRIDType.$GRIDName"."_map"; + if ( -e "$MAPpath/$mapname.eps" ) { + print "\"$mapname.eps\"
        \n"; + } + if ( -e "$MAPpath/$mapname.png" ) { + print "
        \n"; + if (-e "$MAPpath/$mapname.map") { + @htmlarea = readFile("$MAPpath/$mapname.map"); + print "\n@htmlarea\n"; + } + } + + # -- case 'Events' } elsif ($QryParm->{'ts'} eq 'events') { - # this lists files using complementary wildcards from g= YYYY[/MM[/DD[/EVENTID[/EVENTNAME]]]] - (my $depth = $QryParm->{'g'}) =~ s/[^\/]//g; - $depth = length($depth); # $depth is number of "/" in the g= argument - - # lists all files - @plist = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/$QryParm->{'g'}".("/*" x (4 - $depth)).".jpg"; - - # target directory contains multiple files: displays existing thumbnails - if ($#plist > 1) { - my $month0 = ""; - for (@plist) { - if ( ($depth < 3 && -l $_) || ($depth == 3 && ! -l $_)) { - (my $JPGurn = $_) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - (my $EVENTid = $_) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; - if (-l $_) { - my $lnk = basename($_); - my $tgt = readlink($_); - $EVENTid =~ s/$lnk/$tgt/g; - } - $EVENTid =~ s/\.jpg//g; - (my @evt) = split(/\//,$EVENTid); - my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); - my $month = l2u(strftime("%B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); - my $msg = "ID: $evt[3]
        $evt[4]"; - if ($depth == 3 && $QryParm->{'g'} !~ m/\*/ && $month ne $month0) { - print "

        $dte: $evt[3]

        \n"; - $month0 = $month; - } elsif ($month ne $month0) { - print "

        $month

        \n"; - $month0 = $month; - } - my $thumb = ""; - if ($WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT} > 0) { - $thumb = "; height:$WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT}px"; - } - my $target = $EVENTid; - if ($depth < 3) { - $target = join("/",@evt[0..3]); - } - print "", - "\n"; - } - } - # single file: displays .png (or .jpg) and links to other files (.eps,.pdf,.gse,.txt) - } else { - my $addlinks = ""; - (my $short = $plist[0]) =~ s/\.jpg//g; - (my $urn = $short) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - (my $EVENTid = $short) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; - (my @evt) = split(/\//,$EVENTid); - my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); - foreach ("eps","svg","pdf","gse","txt","kml") { - if ( -e "$short.$_" ) { - $addlinks .= " \"$urn.$_\" "; - } - } - # special case of .msg file (tremblemaps) - if ( -e "$short.msg" ) { - $addlinks .= " {'grid'}&ts=events&g=$EVENTid\">" - ."\"$urn.msg\" "; - } - print "

        $dte: $evt[3] / $evt[4]

        \n"; - print "$addlinks
        " if ($QryParm->{'header'} ne 'no'); - my $img = "$urn.png"; - if ( ! -f "$short.png" ) { - $img = "$urn.jpg"; - } - print "
        "; - } - -# -- case 'Timescales' +# this lists files using complementary wildcards from g= YYYY[/MM[/DD[/EVENTID[/EVENTNAME]]]] + (my $depth = $QryParm->{'g'}) =~ s/[^\/]//g; + $depth = length($depth); # $depth is number of "/" in the g= argument + + # lists all files + @plist = glob "$OUTG/$WEBOBS{PATH_OUTG_EVENTS}/$QryParm->{'g'}".("/*" x (4 - $depth)).".jpg"; + + # target directory contains multiple files: displays existing thumbnails + if ($#plist > 1) { + my $month0 = ""; + for (@plist) { + if ( ($depth < 3 && -l $_) || ($depth == 3 && ! -l $_)) { + (my $JPGurn = $_) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + (my $EVENTid = $_) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; + if (-l $_) { + my $lnk = basename($_); + my $tgt = readlink($_); + $EVENTid =~ s/$lnk/$tgt/g; + } + $EVENTid =~ s/\.jpg//g; + (my @evt) = split(/\//,$EVENTid); + my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); + my $month = l2u(strftime("%B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); + my $msg = "ID: $evt[3]
        $evt[4]"; + if ($depth == 3 && $QryParm->{'g'} !~ m/\*/ && $month ne $month0) { + print "

        $dte: $evt[3]

        \n"; + $month0 = $month; + } elsif ($month ne $month0) { + print "

        $month

        \n"; + $month0 = $month; + } + my $thumb = ""; + if ($WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT} > 0) { + $thumb = "; height:$WEBOBS{MKGRAPH_THUMBNAIL_HEIGHT}px"; + } + my $target = $EVENTid; + if ($depth < 3) { + $target = join("/",@evt[0..3]); + } + print "", + "\n"; + } + } + +# single file: displays .png (or .jpg) and links to other files (.eps,.pdf,.gse,.txt) + } else { + my $addlinks = ""; + (my $short = $plist[0]) =~ s/\.jpg//g; + (my $urn = $short) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + (my $EVENTid = $short) =~ s/$OUTG\/$WEBOBS{PATH_OUTG_EVENTS}\///g; + (my @evt) = split(/\//,$EVENTid); + my $dte = l2u(strftime("%A %d %B %Y",0,0,0,$evt[2],$evt[1] - 1,$evt[0] - 1900)); + foreach ("eps","svg","pdf","gse","txt","kml") { + if ( -e "$short.$_" ) { + $addlinks .= " \"$urn.$_\" "; + } + } + + # special case of .msg file (tremblemaps) + if ( -e "$short.msg" ) { + $addlinks .= " {'grid'}&ts=events&g=$EVENTid\">" + ."\"$urn.msg\" "; + } + print "

        $dte: $evt[3] / $evt[4]

        \n"; + print "$addlinks
        " if ($QryParm->{'header'} ne 'no'); + my $img = "$urn.png"; + if ( ! -f "$short.png" ) { + $img = "$urn.jpg"; + } + print "
        "; + } + + # -- case 'Timescales' } else { - # i.e "only display requested g= in query-string" - # if none requested in query-string, show thumbnails of all available graphs - if ($QryParm->{'g'} eq "") { - - for my $g (@glist) { - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $urn =~ s/\.png$/\.jpg/; - (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $short =~ s/^$/SUMMARY/; - print " "; - } - - # if g=col in query-string, show all available graphs in one column - } elsif ($QryParm->{'g'} eq "col") { - - for my $g (@glist) { - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $short =~ s/^$/SUMMARY/; - print "
        "; - } - - - } else { - # prepare additional links to eps, svg, pdf and data - my $addlinks = ""; - for my $i (0..$#elist) { - if (-f $elist[$i]) { - (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $elist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $elist[$i] =~ s/^$/$GRIDName/; - if ($elist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; - } - } - } - for my $i (0..$#slist) { - if (-f $slist[$i]) { - (my $surn = $slist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $slist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $slist[$i] =~ s/^$/$GRIDName/; - if ($slist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.svg\" src=\"/icons/fsvg.png\"> "; - } - } - } - for my $i (0..$#plist) { - if (-f $plist[$i]) { - (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $plist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $plist[$i] =~ s/^$/$GRIDName/; - if ($plist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; - } - } - } - for my $i (0..$#dlist) { - if (-f $dlist[$i]) { - (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $dlist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; - $dlist[$i] =~ s/^$/$GRIDName/; - ##if ($dlist[$i] eq $QryParm->{'g'}) { - if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { - $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; - } - } - } - # if a FORM is associated to the PROC, adds a link to the database interface - if ($GRID{FORM} ne '') { - my $FORM = new WebObs::Form($GRID{FORM}); - my $opt = ($QryParm->{'g'} eq $GRIDName ? "{$GRIDName}":uc($QryParm->{'g'})); - $addlinks .= "conf('CGI_SHOW')."?node=$opt\">\"\" "; - } - - if ( $QryParm->{'g'} ne $GRIDName && !(grep( /^$QryParm->{'g'}$/i, @SummaryList)) && $QryParm->{'g'} eq lc($QryParm->{'g'}) ) { - my $ucg = uc($QryParm->{'g'}); - $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; - } - # finally plots the image ! - for my $g (@glist) { - (my $map = $g) =~ s/\.png/\.map/; - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; - $g =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $g =~ s/^$/SUMMARY/; - if ($g eq $QryParm->{'g'}) { - print "$addlinks
        " if ($QryParm->{'header'} ne 'no'); - print "
        "; - if (-e "$map") { - my @htmlarea = readFile("$map"); - print "\n@htmlarea\n"; - } - } - } - } + # i.e "only display requested g= in query-string" + # if none requested in query-string, show thumbnails of all available graphs + if ($QryParm->{'g'} eq "") { + + for my $g (@glist) { + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $urn =~ s/\.png$/\.jpg/; + (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $short =~ s/^$/SUMMARY/; + print " "; + } + + # if g=col in query-string, show all available graphs in one column + } elsif ($QryParm->{'g'} eq "col") { + + for my $g (@glist) { + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + (my $short = $g) =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $short =~ s/^$/SUMMARY/; + print "
        "; + } + + } else { + + # prepare additional links to eps, svg, pdf and data + my $addlinks = ""; + for my $i (0..$#elist) { + if (-f $elist[$i]) { + (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $elist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $elist[$i] =~ s/^$/$GRIDName/; + if ($elist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; + } + } + } + for my $i (0..$#slist) { + if (-f $slist[$i]) { + (my $surn = $slist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $slist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $slist[$i] =~ s/^$/$GRIDName/; + if ($slist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.svg\" src=\"/icons/fsvg.png\"> "; + } + } + } + for my $i (0..$#plist) { + if (-f $plist[$i]) { + (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $plist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $plist[$i] =~ s/^$/$GRIDName/; + if ($plist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; + } + } + } + for my $i (0..$#dlist) { + if (-f $dlist[$i]) { + (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $dlist[$i] =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; + $dlist[$i] =~ s/^$/$GRIDName/; + ##if ($dlist[$i] eq $QryParm->{'g'}) { + if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { + $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; + } + } + } + + # if a FORM is associated to the PROC, adds a link to the database interface + if ($GRID{FORM} ne '') { + my $FORM = new WebObs::Form($GRID{FORM}); + my $opt = ($QryParm->{'g'} eq $GRIDName ? "{$GRIDName}":uc($QryParm->{'g'})); + $addlinks .= "conf('CGI_SHOW')."?node=$opt\">\"\" "; + } + + if ( $QryParm->{'g'} ne $GRIDName && !(grep( /^$QryParm->{'g'}$/i, @SummaryList)) && $QryParm->{'g'} eq lc($QryParm->{'g'}) ) { + my $ucg = uc($QryParm->{'g'}); + $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; + } + + # finally plots the image ! + for my $g (@glist) { + (my $map = $g) =~ s/\.png/\.map/; + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTG}/$WEBOBS{URN_OUTG}/g; + $g =~ s/^$OUTG\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $g =~ s/^$/SUMMARY/; + if ($g eq $QryParm->{'g'}) { + print "$addlinks
        " if ($QryParm->{'header'} ne 'no'); + print "
        "; + if (-e "$map") { + my @htmlarea = readFile("$map"); + print "\n@htmlarea\n"; + } + } + } + } } print "
        $go2top
        "; @@ -493,18 +500,19 @@ =head1 DESCRIPTION print "\n\n"; sub outgHouseKeeping { - # %DefinedNodes and @SummaryList must have been built - if ( defined($WEBOBS{OUTG_STALENODES_DISPO}) ) { - my @objects = ( glob("$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_*.eps"), glob("$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_*.*") ); - for my $object (@objects) { - my $prefix = basename($object); $prefix =~ /(.*)_.*/; $prefix = $1; - if ( $WEBOBS{OUTG_STALENODES_DISPO} eq 'DELETE' && ($prefix ne "" || !defined($GRID{SUMMARYLIST})) && $prefix ne $GRIDName ) { - if ( !(grep( /^$prefix$/i, keys(%DefinedNodes))) && !(grep( /^$prefix$/i, @SummaryList)) ) { - qx(rm $object); - } - } - } - } + + # %DefinedNodes and @SummaryList must have been built + if ( defined($WEBOBS{OUTG_STALENODES_DISPO}) ) { + my @objects = ( glob("$OUTG/$WEBOBS{PATH_OUTG_GRAPHS}/*_*.eps"), glob("$OUTG/$WEBOBS{PATH_OUTG_EXPORT}/*_*.*") ); + for my $object (@objects) { + my $prefix = basename($object); $prefix =~ /(.*)_.*/; $prefix = $1; + if ( $WEBOBS{OUTG_STALENODES_DISPO} eq 'DELETE' && ($prefix ne "" || !defined($GRID{SUMMARYLIST})) && $prefix ne $GRIDName ) { + if ( !(grep( /^$prefix$/i, keys(%DefinedNodes))) && !(grep( /^$prefix$/i, @SummaryList)) ) { + qx(rm $object); + } + } + } + } } __END__ diff --git a/CODE/cgi-bin/showOUTR.pl b/CODE/cgi-bin/showOUTR.pl index b933b118..cbee4313 100755 --- a/CODE/cgi-bin/showOUTR.pl +++ b/CODE/cgi-bin/showOUTR.pl @@ -49,23 +49,23 @@ =head1 DESCRIPTION # ---- check authorization: request owner or administrator if ($user ne $CLIENT && !clientHasAdm(type=>"authprocs",name=>"*")) { - die "Sorry, you're not the owner of this proc request."; + die "Sorry, you're not the owner of this proc request."; } # ---- what grids do we have to process ? my @GL = qx(find $WEBOBS{ROOT_OUTR}/$OUTDIR -type d \\( -name "PROC.*" -o -name "VIEW.*" -o -name "GRIDMAPS" \\) -maxdepth 1); chomp(@GL); foreach (@GL) { - my $g = $_; - $g =~ s/$WEBOBS{ROOT_OUTR}\/$OUTDIR\///; - push(@GRIDList,$g); + my $g = $_; + $g =~ s/$WEBOBS{ROOT_OUTR}\/$OUTDIR\///; + push(@GRIDList,$g); } $QryParm->{'g'} ||= ''; $QryParm->{'grid'} ||= $GRIDList[0]; ($GRIDType, $GRIDName) = split(/[\.\/]/, trim($QryParm->{'grid'})); if (-d "$WEBOBS{ROOT_OUTR}/$OUTDIR/$GRIDType.$GRIDName" ) { - $OUTR = "$WEBOBS{ROOT_OUTR}/$OUTDIR/$GRIDType.$GRIDName"; + $OUTR = "$WEBOBS{ROOT_OUTR}/$OUTDIR/$GRIDType.$GRIDName"; } else { die "$__{'No outputs for'} $GRIDType.$GRIDName" } if (uc($GRIDType) eq 'VIEW') { %G = readView($GRIDName) } @@ -95,54 +95,53 @@ =head1 DESCRIPTION print "

        $GRID{NAME}

        \n"; my $go2top = ""; - # ---- build the top-of-page outputs selection banner: # 1st line for GRID selection # 2nd line for output selection print "
        "; - print "»» [ ".ucfirst(lc($GRIDType)).""; - foreach (@GRIDList) { - if ($QryParm->{'grid'} eq $_ ) { - print " | $_"; - } else { - print " | {'dir'}&grid=$_\">$_"; - } - } - print " ]\n"; - - # build $elist = the list of available .eps graphs - my (@elist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.eps"; - - # build $plist = the list of available .pdf graphs - my (@plist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.pdf"; - - # build $dlist = the list of available data/**.* for timescale $tslist[$tsSelected] - my (@dlist) = glob "$OUTR/$WEBOBS{PATH_OUTG_EXPORT}/*_.*"; - - # build $glist = the list of available .png graphs for timescale $tslist[$tsSelected] - # $glistHtml is the corresponding string of html hrefs to these graphs - # with each nodenames replaced with their alias if it is defined - my (@glist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.png"; - my $glistHtml = ""; - for my $fpath (@glist) { - my $short = $fpath; - $short =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $short =~ s/^$/$GRIDName/; - my $shorter = ($short eq $GRIDName ? "Summary":$short); - if ($short ne $GRIDName && !(grep( /^$short$/i, @SummaryList)) ) { - if ( grep( /^$short$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc - my $alias = getNodeString(node=>uc($short), style=>'alias'); - $shorter = $alias if ( $alias ne '' && $alias ne '-' ); - } - } - if ($QryParm->{'g'} eq $short) { - $glistHtml .= " $shorter |"; - } else { - $glistHtml .= " {'dir'}&grid=$GRIDType.$GRIDName&g=$short\"> $shorter |"; - } - } - chop($glistHtml); - print "
        [ ".$glistHtml." ]\n"; +print "»» [ ".ucfirst(lc($GRIDType)).""; +foreach (@GRIDList) { + if ($QryParm->{'grid'} eq $_ ) { + print " | $_"; + } else { + print " | {'dir'}&grid=$_\">$_"; + } +} +print " ]\n"; + +# build $elist = the list of available .eps graphs +my (@elist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.eps"; + +# build $plist = the list of available .pdf graphs +my (@plist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.pdf"; + +# build $dlist = the list of available data/**.* for timescale $tslist[$tsSelected] +my (@dlist) = glob "$OUTR/$WEBOBS{PATH_OUTG_EXPORT}/*_.*"; + +# build $glist = the list of available .png graphs for timescale $tslist[$tsSelected] +# $glistHtml is the corresponding string of html hrefs to these graphs +# with each nodenames replaced with their alias if it is defined +my (@glist) = glob "$OUTR/$WEBOBS{PATH_OUTG_GRAPHS}/*_.png"; +my $glistHtml = ""; +for my $fpath (@glist) { + my $short = $fpath; + $short =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $short =~ s/^$/$GRIDName/; + my $shorter = ($short eq $GRIDName ? "Summary":$short); + if ($short ne $GRIDName && !(grep( /^$short$/i, @SummaryList)) ) { + if ( grep( /^$short$/i, keys(%DefinedNodes)) ) { # it's a node file AND node still in proc + my $alias = getNodeString(node=>uc($short), style=>'alias'); + $shorter = $alias if ( $alias ne '' && $alias ne '-' ); + } + } + if ($QryParm->{'g'} eq $short) { + $glistHtml .= " $shorter |"; + } else { + $glistHtml .= " {'dir'}&grid=$GRIDType.$GRIDName&g=$short\"> $shorter |"; + } +} +chop($glistHtml); +print "
        [ ".$glistHtml." ]\n"; print "
        "; # ---- now show the selected item @@ -150,60 +149,61 @@ =head1 DESCRIPTION # i.e "only display requested g= in query-string" # if none requested in query-string, use the first item of $glist if ($QryParm->{'g'} eq "") { - $QryParm->{'g'} = $glist[0]; - $QryParm->{'g'} =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $QryParm->{'g'} =~ s/^$/$GRIDName/; + $QryParm->{'g'} = $glist[0]; + $QryParm->{'g'} =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $QryParm->{'g'} =~ s/^$/$GRIDName/; } + # prepare additional links to eps, pdf and data my $addlinks = ""; for my $i (0..$#elist) { - if (-f $elist[$i]) { - (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $elist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $elist[$i] =~ s/^$/$GRIDName/; - if ($elist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; - } - } + if (-f $elist[$i]) { + (my $surn = $elist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $elist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $elist[$i] =~ s/^$/$GRIDName/; + if ($elist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.eps\" src=\"/icons/feps.png\"> "; + } + } } for my $i (0..$#plist) { - if (-f $plist[$i]) { - (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $plist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $plist[$i] =~ s/^$/$GRIDName/; - if ($plist[$i] eq $QryParm->{'g'}) { - $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; - } - } + if (-f $plist[$i]) { + (my $surn = $plist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $plist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $plist[$i] =~ s/^$/$GRIDName/; + if ($plist[$i] eq $QryParm->{'g'}) { + $addlinks .= " \"$QryParm-{'g'}.pdf\" src=\"/icons/fpdf.png\"> "; + } + } } for my $i (0..$#dlist) { - if (-f $dlist[$i]) { - (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $dlist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; - $dlist[$i] =~ s/^$/$GRIDName/; - ##if ($dlist[$i] eq $QryParm->{'g'}) { - if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { - $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; - } - } + if (-f $dlist[$i]) { + (my $surn = $dlist[$i]) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $dlist[$i] =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_EXPORT}\/(.*)_.*$/$1/; + $dlist[$i] =~ s/^$/$GRIDName/; + ##if ($dlist[$i] eq $QryParm->{'g'}) { + if ( ($dlist[$i]=~m/$QryParm->{'g'}/i) ) { + $addlinks .= " \"$QryParm-{'g'}.txt\" src=\"/icons/fdata.png\"> "; + } + } } if ($QryParm->{'g'} ne $GRIDName && !(grep( /^$QryParm->{'g'}$/i, @SummaryList)) ) { - my $ucg = uc($QryParm->{'g'}); - $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; + my $ucg = uc($QryParm->{'g'}); + $addlinks .= " \"$QryParm-{'g'}\" src=\"/icons/fnode.png\"> "; } for my $g (@glist) { - (my $map = $g) =~ s/\.png/\.map/; - (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; - $g =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; - $g =~ s/^$/$GRIDName/; - if ($g eq $QryParm->{'g'}) { - print "$addlinks
        "; - print "
        "; - if (-e "$map") { - my @htmlarea = readFile("$map"); - print "@htmlarea\n"; - } - } + (my $map = $g) =~ s/\.png/\.map/; + (my $urn = $g) =~ s/$WEBOBS{ROOT_OUTR}/$WEBOBS{URN_OUTR}/g; + $g =~ s/^$OUTR\/$WEBOBS{PATH_OUTG_GRAPHS}\/(.*)_.*$/$1/; + $g =~ s/^$/$GRIDName/; + if ($g eq $QryParm->{'g'}) { + print "$addlinks
        "; + print "
        "; + if (-e "$map") { + my @htmlarea = readFile("$map"); + print "@htmlarea\n"; + } + } } print "
        $go2top
        "; @@ -211,7 +211,6 @@ =head1 DESCRIPTION # ---- We're done ! print "\n\n"; - __END__ =pod diff --git a/CODE/cgi-bin/showPLUVIO.pl b/CODE/cgi-bin/showPLUVIO.pl index fb68c80e..18307b9e 100755 --- a/CODE/cgi-bin/showPLUVIO.pl +++ b/CODE/cgi-bin/showPLUVIO.pl @@ -86,20 +86,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -126,12 +126,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamSite; @@ -140,19 +140,19 @@ =head1 Query string parameters my @option = (); my $msgFinal; -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "Tout"; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "Tout"; $QryParm->{'site'} ||= "Tout"; -$QryParm->{'affiche'} ||= ""; +$QryParm->{'affiche'} ||= ""; # ---- a site requested as {name} means "all nodes for grid (proc) 'name'" # my @gridsites; if ($QryParm->{'site'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -161,63 +161,63 @@ =head1 Query string parameters # ---- start html if not CSV output - if ($affiche ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "$titrePage\n", - "", - "\n"; - - print "\n", - "\n", - "
        Recherche des données, merci de patienter.
        ", - "
        \n", - "\n", - "\n"; +if ($affiche ne "csv") { + print $cgi->header(-charset=>'utf-8'); + print "\n", + "$titrePage\n", + "", + "\n"; + + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "
        \n", + "\n", + "\n"; } # Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'affiche'} ne "csv") { - print("
        conf('CGI_SHOW')."\" method=\"get\">", - "

        ", - "Sélectionner: \n", - "\n", - "", - " "); - if ($displayOnly ne 1) { - print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); - } - print "

        \n", - "

        $titrePage

        \n", - "

        Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
        ", - "Sites sélectionnés: $afficheSite
        "; + print("

        conf('CGI_SHOW')."\" method=\"get\">", + "

        ", + "Sélectionner: \n", + "\n", + "", + " "); + if ($displayOnly ne 1) { + print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + } + print "

        \n", + "

        $titrePage

        \n", + "

        Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
        ", + "Sites sélectionnés: $afficheSite
        "; } # ---- Lecture du fichier de données dans tableau @lignes @@ -237,16 +237,16 @@ =head1 Query string parameters $entete = ""; if ($displayOnly ne 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."Année" - ."Mois" - ."Site" - ."Pluviométrie journalière (en mm)" - ."Cumul
        (mm)" - ."\n"; + ."Mois" + ."Site" + ."Pluviométrie journalière (en mm)" + ."Cumul
        (mm)" + ."\n"; for ("01".."31") { - $entete = $entete."$_"; + $entete = $entete."$_"; } $entete = $entete."\n"; @@ -254,77 +254,77 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,$_); - my $sc = ""; - my $cm = 0; - if ($i eq 0) { - push(@csv,u2l("$aa;$mm;Code Site;$site;$d01;$d02;$d03;$d04;$d05;$d06;$d07;$d08;$d09;$d10;$d11;$d12;$d13;$d14;$d15;$d16;$d17;$d18;$d19;$d20;$d21;$d22;$d23;$d24;$d25;$d26;$d27;$d28;$d29;$d30;$d31;$val")); - } - elsif (($_ ne "") - && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} == $aa) || (($QryParm->{'annee'} eq "Ancien") && ($aa lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} == $mm))) { - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($displayOnly ne 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$aa" - ."$nomMois[$mm-1]" - ."$lien"; - $txt = "$aa;$mm;$site;$aliasSite"; - for ("01".."31") { - my $dd = eval("\$d$_"); - my $vv = eval("\$v$_"); - my $ss = ""; - $cm += $dd; - if ($dd ne "") { $dd = sprintf("%0.1f",$dd); } - if ($vv == 2) { - $ss = "style=\"background-color:#FFAAAA\" onMouseOut=\"nd()\" onMouseOver=\"overlib('Donnée douteuse')\""; - } - if (($vv == 3) || ($sc ne "")) { - if ($sc eq "") { $sc = "Cumul depuis le $_ $nomMois[$mm-1] $aa"; }; - $ss = "style=\"background-color:#AAAAFF\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$sc')\""; - } - if ($vv == 4) { - $ss = ""; - $sc = ""; - } - $texte = $texte."$dd"; - $txt = $txt.";".eval("\$d$_"); - } - $texte = $texte."$cm\n"; - $txt = $txt."\n"; - push(@csv,$txt); - - $nbLignesRetenues++; - } - $i++; + my ($id,$aa,$mm,$site,$d01,$v01,$d02,$v02,$d03,$v03,$d04,$v04,$d05,$v05,$d06,$v06,$d07,$v07,$d08,$v08,$d09,$v09,$d10,$v10,$d11,$v11,$d12,$v12,$d13,$v13,$d14,$v14,$d15,$v15,$d16,$v16,$d17,$v17,$d18,$v18,$d19,$v19,$d20,$v20,$d21,$v21,$d22,$v22,$d23,$v23,$d24,$v24,$d25,$v25,$d26,$v26,$d27,$v27,$d28,$v28,$d29,$v29,$d30,$v30,$d31,$v31,$val) = split(/\|/,$_); + my $sc = ""; + my $cm = 0; + if ($i eq 0) { + push(@csv,u2l("$aa;$mm;Code Site;$site;$d01;$d02;$d03;$d04;$d05;$d06;$d07;$d08;$d09;$d10;$d11;$d12;$d13;$d14;$d15;$d16;$d17;$d18;$d19;$d20;$d21;$d22;$d23;$d24;$d25;$d26;$d27;$d28;$d29;$d30;$d31;$val")); + } + elsif (($_ ne "") + && (($QryParm->{'site'} eq "Tout") || ($site =~ $QryParm->{'site'}) || ($site ~~ @gridsites)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} == $aa) || (($QryParm->{'annee'} eq "Ancien") && ($aa lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} == $mm))) { + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($displayOnly ne 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$aa" + ."$nomMois[$mm-1]" + ."$lien"; + $txt = "$aa;$mm;$site;$aliasSite"; + for ("01".."31") { + my $dd = eval("\$d$_"); + my $vv = eval("\$v$_"); + my $ss = ""; + $cm += $dd; + if ($dd ne "") { $dd = sprintf("%0.1f",$dd); } + if ($vv == 2) { + $ss = "style=\"background-color:#FFAAAA\" onMouseOut=\"nd()\" onMouseOver=\"overlib('Donnée douteuse')\""; + } + if (($vv == 3) || ($sc ne "")) { + if ($sc eq "") { $sc = "Cumul depuis le $_ $nomMois[$mm-1] $aa"; }; + $ss = "style=\"background-color:#AAAAFF\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$sc')\""; + } + if ($vv == 4) { + $ss = ""; + $sc = ""; + } + $texte = $texte."$dd"; + $txt = $txt.";".eval("\$d$_"); + } + $texte = $texte."$cm\n"; + $txt = $txt."\n"; + push(@csv,$txt); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

        \n", - "

        Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

        \n"); + "

        Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&site=$QryParm->{'site'}\">$fileCSV

        \n"); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
        \n"); + push(@html,"$entete\n$texte\n$entete\n
        \n"); } # Time to display (or download csv) # if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/showQRcode.pl b/CODE/cgi-bin/showQRcode.pl index 9d4e6959..c1f634c5 100755 --- a/CODE/cgi-bin/showQRcode.pl +++ b/CODE/cgi-bin/showQRcode.pl @@ -37,7 +37,7 @@ =head1 Parameters # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $title = "$ENV{HTTP_REFERER}"; @@ -67,7 +67,7 @@ =head1 Parameters END for (@logos) { - print "

        "; + print "

        "; } print "\n\n\n"; diff --git a/CODE/cgi-bin/showRAINWATER.pl b/CODE/cgi-bin/showRAINWATER.pl index 201bc7c8..1e7f1a12 100755 --- a/CODE/cgi-bin/showRAINWATER.pl +++ b/CODE/cgi-bin/showRAINWATER.pl @@ -115,13 +115,13 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (sort keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -179,22 +179,22 @@ =head1 Query string parameters $i = 0; for (@ratios) { - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } - $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } + $i++; } # ---- a site requested as {name} means "all nodes for proc 'name'" # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -204,13 +204,13 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'dump'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print qq( + print $cgi->header(-charset=>'utf-8'); + print qq( ).$FORM->conf('TITLE').qq( ); - print qq( + print qq(
        $__{'Searching for the data... please wait'}.
        @@ -221,65 +221,65 @@ =head1 Query string parameters # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'dump'} ne "csv") { - print "
        conf('CGI_SHOW')."\" method=\"get\">", - ""; + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('return_url' => $return_url); + print qq(); + } + print qq(
        ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "   + print "conf('CGI_SHOW')."\" method=\"get\">", + ""; - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('return_url' => $return_url); - print qq(); - } - print qq(
        ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "       + for (@cleParamUnite) { + my ($val,$cle) = split (/\|/,$_); + if ("$val" eq "$QryParm->{'unit'}") { print qq(\n); } + else { print qq(\n); } + } + print qq(   
          \n$__{'Ratios'}:); - $i = 0; - for (@ratios) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print qq($nhtm/$dhtm  ); - $i++; - } - print "
        + $i = 0; + for (@ratios) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print qq($nhtm/$dhtm  ); + $i++; + } + print "

        ).$FORM->conf('TITLE').qq(

        \n); } @@ -300,39 +300,39 @@ =head1 Query string parameters $header = ""; if ($clientAuth > 1) { - $header = $header.""; + $header = $header.""; } $header = $header."Sampling Time Collection" - ."Site" - ."Rainfall" - ."Laboratory Meas." - ."Cations ($unit)" - ."Anions ($unit)" - ."Isotopes (‰)" - ."NICB
        (%)" - .($nbRap > 0 ? " Ratios":"") - ."\n" - ."Start
        Date & TimeEnd
        Date & TimeDays" - ."Cum.
        (mm)Avr.
        (mm/day)" - ."pH" - ."Cond.
        (µS)" - ."Na+" - ."K+" - ."Mg++" - ."Ca++" - ."HCO3-" - ."Cl-" - ."SO4--" - ."δDδ18O"; + ."Site" + ."Rainfall" + ."Laboratory Meas." + ."Cations ($unit)" + ."Anions ($unit)" + ."Isotopes (‰)" + ."NICB
        (%)" + .($nbRap > 0 ? " Ratios":"") + ."\n" + ."Start
        Date & TimeEnd
        Date & TimeDays" + ."Cum.
        (mm)Avr.
        (mm/day)" + ."pH" + ."Cond.
        (µS)" + ."Na+" + ."K+" + ."Mg++" + ."Ca++" + ."HCO3-" + ."Cl-" + ."SO4--" + ."δDδ18O"; $i = 0; for (@ratios) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - if ($rap[$i] == 1) { - $header = $header."" - ."" - ."
        $nhtm
        $dthm
        "; - } - $i++; + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + if ($rap[$i] == 1) { + $header = $header."" + ."" + ."
        $nhtm
        $dthm
        "; + } + $i++; } $header = $header."\n"; @@ -340,138 +340,138 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for (@lines) { - my ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$volume;$diameter;Total Rain (mm);Daily Rain (mm/day);$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;$dD;$d18O;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) - && ($id > 0 || $clientAuth == 4) - && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span - - my ($y,$m,$d) = split(/-/,$date1); - my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); - my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my ($y,$m,$d) = split(/-/,$date2); - my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); - my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my $dur = $d1->delta_days($d2)->delta_days; - my $total_rain = ""; - my $daily_rain = ""; - my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cSO4_mmol,$cHCO3_mmol); - $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cSO4_mmol=$cHCO3_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; - my $nicb = ""; - my @rapv; - my $rapport = ""; - - if ($volume gt 0 && $diameter gt 0) { - $total_rain = 10*$volume/(pi()*($diameter/2)**2); - $daily_rain = $total_rain/$dur if ($dur > 0); - } - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; - if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - my $iv = 0; - for (@ratios) { - if ($rap[$iv] == 1) { - my ($num,$den,$nrp) = split(/\|/,$_); - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - $rapport = $rapport."$rapv[$iv]"; - } - $iv++; - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { - $lien = "$aliasSite"; - } - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('id' => $id, 'return_url' => $return_url); - $modif = qq(); - $efface = qq(); - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$date1 $time1$date2 $time2$dur$lien" - ."".sprintf("%0.1f",$total_rain)."".sprintf("%0.1f",$daily_rain)."" - ."$pH$cond"; - $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$volume;$diameter;" - .sprintf("%0.1f",$total_rain).";".sprintf("%0.1f",$daily_rain).";$pH;$cond;"; - if ($QryParm->{'unit'} eq "mmol") { - for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { - $texte .= ""; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= ""; - } - $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol;"; - } else { - $texte .= "$cNa$cK$cMg$cCa" - ."$cHCO3$cCl$cSO4"; - $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;"; - } - if ($QryParm->{'isotopes'} ne "") { - $texte .= "$dD$d18O"; - } - if ($nicb and ($nicb < -20) || ($nicb > 20)) { - $texte .= ""; - } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= "$rapport"; - $txt = $txt."$dD;$d18O;".sprintf("%0.1f",$nicb).";\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date2,$time2,$site,$date1,$time1,$volume,$diameter,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$dD,$d18O,$rem,$val) = split (/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$volume;$diameter;Total Rain (mm);Daily Rain (mm/day);$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;$dD;$d18O;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) + && ($id > 0 || $clientAuth == 4) + && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span + + my ($y,$m,$d) = split(/-/,$date1); + my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); + my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my ($y,$m,$d) = split(/-/,$date2); + my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); + my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my $dur = $d1->delta_days($d2)->delta_days; + my $total_rain = ""; + my $daily_rain = ""; + my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cSO4_mmol,$cHCO3_mmol); + $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cSO4_mmol=$cHCO3_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + my $nicb = ""; + my @rapv; + my $rapport = ""; + + if ($volume gt 0 && $diameter gt 0) { + $total_rain = 10*$volume/(pi()*($diameter/2)**2); + $daily_rain = $total_rain/$dur if ($dur > 0); + } + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + my $iv = 0; + for (@ratios) { + if ($rap[$iv] == 1) { + my ($num,$den,$nrp) = split(/\|/,$_); + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + $rapport = $rapport."$rapv[$iv]"; + } + $iv++; + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { + $lien = "$aliasSite"; + } + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('id' => $id, 'return_url' => $return_url); + $modif = qq(); + $efface = qq(); + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$date1 $time1$date2 $time2$dur$lien" + ."".sprintf("%0.1f",$total_rain)."".sprintf("%0.1f",$daily_rain)."" + ."$pH$cond"; + $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$volume;$diameter;" + .sprintf("%0.1f",$total_rain).";".sprintf("%0.1f",$daily_rain).";$pH;$cond;"; + if ($QryParm->{'unit'} eq "mmol") { + for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { + $texte .= ""; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= ""; + } + $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol;"; + } else { + $texte .= "$cNa$cK$cMg$cCa" + ."$cHCO3$cCl$cSO4"; + $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;"; + } + if ($QryParm->{'isotopes'} ne "") { + $texte .= "$dD$d18O"; + } + if ($nicb and ($nicb < -20) || ($nicb > 20)) { + $texte .= ""; + } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= "$rapport"; + $txt = $txt."$dD;$d18O;".sprintf("%0.1f",$nicb).";\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"$__{'Number of records'} = $nbLignesRetenues / $nbData.

        \n", - "

        $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

        \n"); + "

        $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

        \n"); if ($texte ne "") { - push(@html,"$header\n$texte\n$header\n
        "); - push(@html,"

        "); + push(@html,"$header\n$texte\n$header\n
        "); + push(@html,"

        "); } push(@html,@notes); if ($QryParm->{'dump'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/showREQ.pl b/CODE/cgi-bin/showREQ.pl index 2cba9b28..b5647281 100755 --- a/CODE/cgi-bin/showREQ.pl +++ b/CODE/cgi-bin/showREQ.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showREQ.pl @@ -81,69 +82,69 @@ =head1 DESCRIPTION print "

        $pagetitle

        "; print "

        »» [ Forms: " -."Procs | " -."Gridmaps | " -."Users: " -.($QryParm->{'usr'} eq "all" ? "$CLIENT | all":"$CLIENT | all")." | " -."" -." ]

        "; + ."Procs | " + ."Gridmaps | " + ."Users: " + .($QryParm->{'usr'} eq "all" ? "$CLIENT | all":"$CLIENT | all")." | " + ."" + ." ]

        "; $table = " .\n"; for (reverse sort @reqlist) { - my $dir = my $reqdir = $_; - $reqdir =~ s|$WEBOBS{ROOT_OUTR}/||; - my ($date,$time,$host,$user) = split(/_/,$reqdir); - my $date1 = qx(grep -a "^DATE1|" $dir/REQUEST.rc | sed -e "s/DATE1|//"); - my $date2 = qx(grep -a "^DATE2|" $dir/REQUEST.rc | sed -e "s/DATE2|//"); - my (@procs) = grep {-d} glob("$dir/{PROC.*,GRIDMAPS}"); # first list of procs from output directories - $_ =~ s|$dir/|| for @procs; # keeps only the PROC.NAME part - my @procreq = qx(grep -a "^PROC\." $dir/REQUEST.rc | sed -e "s/\.[^.]*|.*//"); # second list of procs from the request parameters - chomp(@procreq); - push(@procs,@procreq); # merging output directories and request parameters - @procs = do { my %seen; grep { !$seen{$_}++ } @procs }; # uniq - my $rowspan = scalar(@procs); - if ($user eq $CLIENT || (WebObs::Users::clientHasAdm(type=>"authprocs",name=>"$_") && $QryParm->{'usr'} eq "all")) { - if (length($date)==8 && length($time)==6) { - $date = substr($date,0,4)."-".substr($date,4,2)."-".substr($date,6,2); - $time = substr($time,0,2).":".substr($time,2,2).":".substr($time,4,2); - } - $table .= "" - ."" - ."" - ."" - ."" - .""; - for (@procs) { - (my $proc = $_) =~ s/PROC\.//; - if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$proc") || $_ eq "GRIDMAPS") { - my $rreq = qx(sqlite3 $SCHED{SQL_DB_JOBS} "SELECT cmd,stdpath,rc FROM runs WHERE jid<0 AND cmd LIKE '%$reqdir%' AND cmd LIKE '%$proc%';"); - chomp($rreq); - if ($rreq eq "") { - $table .= ("" x 2); - } else { - my ($rcmd,$rlog,$rc) = split(/\|/,$rreq); - my $log_filename = $rlog =~ s/^[><] +//r; - my $log_name = $log_filename =~ s|/$reqdir/||r; - $table .= ""; - if ($rc eq "0") { - $table .= ""; - } elsif ($rc > 0) { - $table .= ""; - } else { - $table .= ""; - } - } - $table .= ""; - $table .= ""; - } else { - $table .= ""; - } - $table .= "\n"; - } - $table .= "\n"; - } + my $dir = my $reqdir = $_; + $reqdir =~ s|$WEBOBS{ROOT_OUTR}/||; + my ($date,$time,$host,$user) = split(/_/,$reqdir); + my $date1 = qx(grep -a "^DATE1|" $dir/REQUEST.rc | sed -e "s/DATE1|//"); + my $date2 = qx(grep -a "^DATE2|" $dir/REQUEST.rc | sed -e "s/DATE2|//"); + my (@procs) = grep {-d} glob("$dir/{PROC.*,GRIDMAPS}"); # first list of procs from output directories + $_ =~ s|$dir/|| for @procs; # keeps only the PROC.NAME part + my @procreq = qx(grep -a "^PROC\." $dir/REQUEST.rc | sed -e "s/\.[^.]*|.*//"); # second list of procs from the request parameters + chomp(@procreq); + push(@procs,@procreq); # merging output directories and request parameters + @procs = do { my %seen; grep { !$seen{$_}++ } @procs }; # uniq + my $rowspan = scalar(@procs); + if ($user eq $CLIENT || (WebObs::Users::clientHasAdm(type=>"authprocs",name=>"$_") && $QryParm->{'usr'} eq "all")) { + if (length($date)==8 && length($time)==6) { + $date = substr($date,0,4)."-".substr($date,4,2)."-".substr($date,6,2); + $time = substr($time,0,2).":".substr($time,2,2).":".substr($time,4,2); + } + $table .= "" + ."" + ."" + ."" + ."" + .""; + for (@procs) { + (my $proc = $_) =~ s/PROC\.//; + if (WebObs::Users::clientHasRead(type=>"authprocs",name=>"$proc") || $_ eq "GRIDMAPS") { + my $rreq = qx(sqlite3 $SCHED{SQL_DB_JOBS} "SELECT cmd,stdpath,rc FROM runs WHERE jid<0 AND cmd LIKE '%$reqdir%' AND cmd LIKE '%$proc%';"); + chomp($rreq); + if ($rreq eq "") { + $table .= ("" x 2); + } else { + my ($rcmd,$rlog,$rc) = split(/\|/,$rreq); + my $log_filename = $rlog =~ s/^[><] +//r; + my $log_name = $log_filename =~ s|/$reqdir/||r; + $table .= ""; + if ($rc eq "0") { + $table .= ""; + } elsif ($rc > 0) { + $table .= ""; + } else { + $table .= ""; + } + } + $table .= ""; + $table .= ""; + } else { + $table .= ""; + } + $table .= "\n"; + } + $table .= "\n"; + } } $table .= "
        $__{'Date & Time'}$__{'Host'}$__{'User'}$__{'Time Span'}$__{'Params'}$__{'Job logs'}$__{'Status'}$__{'Graphs'}$__{'Archive'}
        $date $time$host$user$date1 - $date2$log_nameOKerrorwait...".(-d "$dir/$_" ? "":"")."".(-e "$dir/$_.tgz" ? "":"")."
        $date $time$host$user$date1 - $date2$log_nameOKerrorwait...".(-d "$dir/$_" ? "":"")."".(-e "$dir/$_.tgz" ? "":"")."


        \n"; @@ -154,7 +155,6 @@ =head1 DESCRIPTION print "\n\n\n"; - __END__ =pod diff --git a/CODE/cgi-bin/showRIVERS.pl b/CODE/cgi-bin/showRIVERS.pl index bb1f41c3..789e6d03 100755 --- a/CODE/cgi-bin/showRIVERS.pl +++ b/CODE/cgi-bin/showRIVERS.pl @@ -118,21 +118,21 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # ---- DateTime inits ---------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $day = strftime('%d',@tod); -my $month = strftime('%m',@tod); +my $day = strftime('%d',@tod); +my $month = strftime('%m',@tod); my $year = strftime('%Y',@tod); my $endDate = strftime('%F',@tod); my $delay = $FORM->conf('DEFAULT_DAYS') // 30; @@ -161,12 +161,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$year) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$year-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamUnite = ("ppm|en ppm","mmol|en mmol/l"); my @cleParamSite; @@ -176,17 +176,17 @@ =head1 Query string parameters my $nbRap = 0; my @rapCalc; -$QryParm->{'y1'} //= $y1; -$QryParm->{'m1'} //= $m1; -$QryParm->{'d1'} //= $d1; -$QryParm->{'y2'} //= $year; -$QryParm->{'m2'} //= $month; -$QryParm->{'d2'} //= $day; -$QryParm->{'node'} //= "All"; -$QryParm->{'sio2'} //= ""; -$QryParm->{'organiques'} //= ""; -$QryParm->{'affiche'} //= ""; -$QryParm->{'unite'} //= "ppm"; +$QryParm->{'y1'} //= $y1; +$QryParm->{'m1'} //= $m1; +$QryParm->{'d1'} //= $d1; +$QryParm->{'y2'} //= $year; +$QryParm->{'m2'} //= $month; +$QryParm->{'d2'} //= $day; +$QryParm->{'node'} //= "All"; +$QryParm->{'sio2'} //= ""; +$QryParm->{'organiques'} //= ""; +$QryParm->{'affiche'} //= ""; +$QryParm->{'unite'} //= "ppm"; if ($QryParm->{'unite'} eq "ppm") {$unite = "ppm = mg/l"} else {$unite = "mmol/l"} $startDate = "$QryParm->{'y1'}-$QryParm->{'m1'}-$QryParm->{'d1'}"; @@ -196,20 +196,20 @@ =head1 Query string parameters # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } $i = 0; for (@rapports) { - $i++; - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } + $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } } # ---- @@ -219,83 +219,83 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "".$FORM->conf('TITLE')."\n", - "", - "\n"; - - print "\n", - "\n", - "
        Recherche des données, merci de patienter.
        ", - "
        \n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "".$FORM->conf('TITLE')."\n", + "", + "\n"; + + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "
        \n", + "\n", + "\n"; } # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'affiche'} ne "csv") { - print "
        conf('CGI_SHOW')."\" method=\"get\">", - "

        ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  \n", - "", - " ", - " "); - if ($clientAuth > 1) { - print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; - } - print("
        \n"); - print("{'sio2'} ne ""? " checked":"").">SiO2  "); - print("{'organiques'} ne ""? " checked":"").">$__{'Organiques'}  "); - print("  \n$__{'Ratios'}: "); - - $i = 0; - for (@rapports) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - $i++; - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print("$nhtm/$dhtm  "); - } - print "

        \n", - "

        ".$FORM->conf('TITLE')."

        \n", - "

        "; + print "

        conf('CGI_SHOW')."\" method=\"get\">", + "

        ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  \n", + "", + " ", + " "); + if ($clientAuth > 1) { + print "conf('CGI_FORM')."'\" value=\"$__{'Enter a new record'}\">"; + } + print("
        \n"); + print("{'sio2'} ne ""? " checked":"").">SiO2  "); + print("{'organiques'} ne ""? " checked":"").">$__{'Organiques'}  "); + print("  \n$__{'Ratios'}: "); + + $i = 0; + for (@rapports) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + $i++; + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print("$nhtm/$dhtm  "); + } + print "

        \n", + "

        ".$FORM->conf('TITLE')."

        \n", + "

        "; } # ---- Read the data file @@ -315,186 +315,189 @@ =head1 Query string parameters $entete = ""; if ($clientAuth > 1) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete."Date" - ."Site
        (Type prél.
        et flacon)" - ."Mesures sur site" - ."Charge
        solide
        (mg/L)" - ."Cations ($unite)" - ."Anions ($unite)" - .($QryParm->{'sio2'} ne "" ? "Autres":"") - .($QryParm->{'organiques'} ne "" ? "Organiques":"") - ." Calculs" - ."\n" - ."Niveau
        (cm)" - ."T eau
        (°C)" - ."pH" - ."Cond
        (µS/cm)" - ."Na+" - ."K+" - ."Mg++" - ."Ca++" - ."HCO3-" - ."Cl-" - ."SO4--" - .($QryParm->{'sio2'} ne "" ? "SiO2".($QryParm->{'unite'} ne "mmol" ? "
        (ppm)":"")."":"") - .($QryParm->{'organiques'} ne "" ? "DOCPOC":"") - ."Cond25
        (μS)" - ."NICB
        (%)"; + ."Site
        (Type prél.
        et flacon)" + ."Mesures sur site" + ."Charge
        solide
        (mg/L)" + ."Cations ($unite)" + ."Anions ($unite)" + .($QryParm->{'sio2'} ne "" ? "Autres":"") + .($QryParm->{'organiques'} ne "" ? "Organiques":"") + ." Calculs" + ."\n" + ."Niveau
        (cm)" + ."T eau
        (°C)" + ."pH" + ."Cond
        (µS/cm)" + ."Na+" + ."K+" + ."Mg++" + ."Ca++" + ."HCO3-" + ."Cl-" + ."SO4--" + .($QryParm->{'sio2'} ne "" ? "SiO2".($QryParm->{'unite'} ne "mmol" ? "
        (ppm)":"")."":"") + .($QryParm->{'organiques'} ne "" ? "DOCPOC":"") + ."Cond25
        (μS)" + ."NICB
        (%)"; $i = 0; for (@rapports) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - $i++; - if ($rap[$i] == 1) { - $entete = $entete."
        $nhtm
        $dthm
        "; - } + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + $i++; + if ($rap[$i] == 1) { + $entete = $entete."
        $nhtm
        $dthm
        "; + } } - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date;$heure;Code Site;$site;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;".($QryParm->{'sio2'} ne "" ? "$cSiO2;":"").($QryParm->{'organiques'} ne "" ? "$cDOC;$cPOC;":"")."$cond25;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) - && ($id > 0 || $clientAuth == 4) - && ($date le $endDate) && ($date ge $startDate)) { - - my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cHCO3_mmol,$cCl_mmol,$cSO4_mmol,$cSiO2_mmol); - $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cHCO3_mmol=$cCl_mmol=$cSO4_mmol=$cSiO2_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; -# my $cond25 = ""; - my $nicb = ""; - my @rapv; - my $iv = 0; - my $rapport = ""; - - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cSiO2 ne "") { $cSiO2_mmol = $cSiO2/$GMOL{SiO2}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - if (($cond ne "") && ($tRiver ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tRiver - 25))); }; - $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; -# if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cHCO3_mmol + $cCl_mmol + 2*$cSO4_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - for (@rapports) { - my ($num,$den,$nrp) = split(/\|/,$_); - $iv++; - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - if ($rap[$iv] == 1) { - $rapport = $rapport."$rapv[$iv]"; - } - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { $lien = "$aliasSite" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte .= "$date $heure$lien 
        $type $flacon" - .($level ne ""?"".sprintf('%.2f',$level):"")."" - .($tRiver ne ""?"".sprintf('%.2f',$tRiver):"")."" - .($pH ne ""?"".sprintf('%.2f',$pH):"")."" - .($cond ne ""?"".sprintf('%.2f',$cond):"")."" - .($suspendedLoad ne ""?"".sprintf('%.2f',$suspendedLoad):"").""; - $txt = "$date;$heure;$site;$aliasSite;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;"; - if ($QryParm->{'unite'} eq "mmol") { - for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { - $texte .= ""; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= ""; - } - $texte .= ($QryParm->{'sio2'} ne "" ? "".sprintf($fmt,$cSiO2_mmol)."":""); - $txt .= "$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol" - .($QryParm->{'sio2'} ne "" ? ";$cSiO2_mmol;":";"); - } else { - $texte .= "" - .($cNa ne ""?"".sprintf('%.2f',$cNa):"")."" - .($cK ne ""?"".sprintf('%.2f',$cK):"")."" - .($cMg ne ""?"".sprintf('%.2f',$cMg):"")."" - .($cCa ne ""?"".sprintf('%.2f',$cCa):"")."" - .($cHCO3 ne ""?"".sprintf('%.2f',$cHCO3):"")."" - .($cCl ne ""?"".sprintf('%.2f',$cCl):"")."" - .($cSO4 ne ""?"".sprintf('%.2f',$cSO4):"")."" - .($QryParm->{'sio2'} ne ""?"".($cSiO2 ne ""?"".sprintf('%.2f',$cSiO2):"")."":""); - $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4" - .($QryParm->{'sio2'} ne "" ? ";$cSiO2;":";"); - } - if ($QryParm->{'organiques'} ne "") { - $texte .= "" - .($cDOC ne ""?"".sprintf('%.2f',$cDOC):"")."" - .($cPOC ne ""?"".sprintf('%.2f',$cPOC):"").""; - $txt .= "$cDOC;$cPOC;"; - } - $texte .= "$cond25"; - if (($nicb < -20) || ($nicb > 20)) { - $texte .= ""; - } elsif (($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= "$rapport"; - #$texte = $texte."$so4_cl$hco3_cl$ca_cl"; - $txt = $txt."$cond25;$nicb;\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$site,$level,$type,$flacon,$tRiver,$suspendedLoad,$pH,$cond25,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cSO4,$cSiO2,$cDOC,$cPOC,$rem,$val) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date;$heure;Code Site;$site;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4;".($QryParm->{'sio2'} ne "" ? "$cSiO2;":"").($QryParm->{'organiques'} ne "" ? "$cDOC;$cPOC;":"")."$cond25;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site =~ $QryParm->{'node'} || $site ~~ @gridsites || ($QryParm->{'node'} eq "All" && $site ~~ @NODESValidList)) + && ($id > 0 || $clientAuth == 4) + && ($date le $endDate) && ($date ge $startDate)) { + + my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cHCO3_mmol,$cCl_mmol,$cSO4_mmol,$cSiO2_mmol); + $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cHCO3_mmol=$cCl_mmol=$cSO4_mmol=$cSiO2_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + + # my $cond25 = ""; + my $nicb = ""; + my @rapv; + my $iv = 0; + my $rapport = ""; + + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cSiO2 ne "") { $cSiO2_mmol = $cSiO2/$GMOL{SiO2}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + if (($cond ne "") && ($tRiver ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tRiver - 25))); }; + $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + + # if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cHCO3_mmol + $cCl_mmol + 2*$cSO4_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + for (@rapports) { + my ($num,$den,$nrp) = split(/\|/,$_); + $iv++; + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + if ($rap[$iv] == 1) { + $rapport = $rapport."$rapv[$iv]"; + } + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { $lien = "$aliasSite" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte .= "$date $heure$lien 
        $type $flacon" + .($level ne ""?"".sprintf('%.2f',$level):"")."" + .($tRiver ne ""?"".sprintf('%.2f',$tRiver):"")."" + .($pH ne ""?"".sprintf('%.2f',$pH):"")."" + .($cond ne ""?"".sprintf('%.2f',$cond):"")."" + .($suspendedLoad ne ""?"".sprintf('%.2f',$suspendedLoad):"").""; + $txt = "$date;$heure;$site;$aliasSite;$level;$type;$flacon;$tRiver;$suspendedLoad;$pH;$cond;"; + if ($QryParm->{'unite'} eq "mmol") { + for ("Na","K","Mg","Ca","HCO3","Cl","SO4") { + $texte .= ""; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= ""; + } + $texte .= ($QryParm->{'sio2'} ne "" ? "".sprintf($fmt,$cSiO2_mmol)."":""); + $txt .= "$cNa_mmol;$cK_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cSO4_mmol" + .($QryParm->{'sio2'} ne "" ? ";$cSiO2_mmol;":";"); + } else { + $texte .= "" + .($cNa ne ""?"".sprintf('%.2f',$cNa):"")."" + .($cK ne ""?"".sprintf('%.2f',$cK):"")."" + .($cMg ne ""?"".sprintf('%.2f',$cMg):"")."" + .($cCa ne ""?"".sprintf('%.2f',$cCa):"")."" + .($cHCO3 ne ""?"".sprintf('%.2f',$cHCO3):"")."" + .($cCl ne ""?"".sprintf('%.2f',$cCl):"")."" + .($cSO4 ne ""?"".sprintf('%.2f',$cSO4):"")."" + .($QryParm->{'sio2'} ne ""?"".($cSiO2 ne ""?"".sprintf('%.2f',$cSiO2):"")."":""); + $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cSO4" + .($QryParm->{'sio2'} ne "" ? ";$cSiO2;":";"); + } + if ($QryParm->{'organiques'} ne "") { + $texte .= "" + .($cDOC ne ""?"".sprintf('%.2f',$cDOC):"")."" + .($cPOC ne ""?"".sprintf('%.2f',$cPOC):"").""; + $txt .= "$cDOC;$cPOC;"; + } + $texte .= "$cond25"; + if (($nicb < -20) || ($nicb > 20)) { + $texte .= ""; + } elsif (($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= "$rapport"; + +#$texte = $texte."$so4_cl$hco3_cl$ca_cl"; + $txt = $txt."$cond25;$nicb;\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Number of records = $nbLignesRetenues / $nbData.

        \n", - "

        Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}".($QryParm->{'sio2'} ne "" ? "&sio2=$QryParm->{'sio2'}":"").($QryParm->{'organiques'} ne "" ? "&organiques=$QryParm->{'organiques'}":"")."\">$fileCSV

        \n"); + "

        Download a CSV text file of these data conf('CGI_SHOW')."?affiche=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unite=$QryParm->{'unite'}".($QryParm->{'sio2'} ne "" ? "&sio2=$QryParm->{'sio2'}":"").($QryParm->{'organiques'} ne "" ? "&organiques=$QryParm->{'organiques'}":"")."\">$fileCSV

        \n"); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
        ", - "

        Types of sites: "); - for (sort(keys(%types))) { - push(@html,"$_ = $types{$_}{name}, "); - } - push(@html,"

        "); + push(@html,"$entete\n$texte\n$entete\n
        ", + "

        Types of sites: "); + for (sort(keys(%types))) { + push(@html,"$_ = $types{$_}{name}, "); + } + push(@html,"

        "); } push(@html,@notes); if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/showSISMOBUL.pl b/CODE/cgi-bin/showSISMOBUL.pl index 87603d3e..62061b96 100755 --- a/CODE/cgi-bin/showSISMOBUL.pl +++ b/CODE/cgi-bin/showSISMOBUL.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showSISMOBUL.pl @@ -44,8 +45,6 @@ =head1 Query string parameters my $FORMPATH = "$WEBOBS{PATH_FORMS}/SISMOBUL"; my %FORM = readCfg("$FORMPATH/SISMOBUL.conf"); - - ########djl: here I am . my @grids = readCfgFile("$FORMPATH/$FORM{FILE_PROCS}"); @@ -57,8 +56,8 @@ =head1 Query string parameters # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -76,11 +75,11 @@ =head1 Query string parameters # sélection des stations utilisées et récupération des alias (réseaux sources + érosion) my @reseaux = readCfgFile("$WEBOBS{RACINE_FICHIERS_CONFIGURATION}/$WEBOBS{SISMOBUL_FILE_RESEAUX}"); + #my @types = readCfgFile("$WEBOBS{RACINE_FICHIERS_CONFIGURATION}/$WEBOBS{PLUVIO_FILE_TYPE}"); my %stationsRes; my @cleRes; - $ENV{TZ} = "America/Guadeloupe"; my $tz_old = $ENV{TZ}; $ENV{LANG} = $WEBOBS{LOCALE}; @@ -99,12 +98,12 @@ =head1 Query string parameters my $unite; my @cleParamAnnee; for ($WEBOBS{SISMOBUL_BANG}..$anneeP) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$anneeP-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$anneeP-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamSite; @@ -112,7 +111,6 @@ =head1 Query string parameters my $titrePage = $WEBOBS{SISMOBUL_TITLE}; my $pathDATA = $WEBOBS{RACINE_FTP}."/".$WEBOBS{SISMOBUL_PATH_NAME}; - # --------------------------------------------------------------- # Récuperation des paramètres transmis (GET) # --------------------------------------------------------------- @@ -121,24 +119,24 @@ =head1 Query string parameters my @parametres=$cgi->url_param(); my $valParams = join(" ",@parametres); -if ($valParams =~ /annee/) { - $parametreAnnee=$cgi->url_param('annee'); - $msgFinal = $msgFinal." & annee=$parametreAnnee"; +if ($valParams =~ /annee/) { + $parametreAnnee=$cgi->url_param('annee'); + $msgFinal = $msgFinal." & annee=$parametreAnnee"; } else { - $msgFinal = "Pas (ou Mauvais) paramètre d'année - Option forcée à année en cours"; - $parametreAnnee = $anneeP; + $msgFinal = "Pas (ou Mauvais) paramètre d'année - Option forcée à année en cours"; + $parametreAnnee = $anneeP; } -if ($valParams =~ /mois/) { - $parametreMois=$cgi->url_param('mois'); - $msgFinal = $msgFinal." & mois=$parametreMois"; +if ($valParams =~ /mois/) { + $parametreMois=$cgi->url_param('mois'); + $msgFinal = $msgFinal." & mois=$parametreMois"; } else { - $msgFinal = $msgFinal." & Mois non transmis - Option forcée à mois en cours"; - $parametreMois = $moisP; + $msgFinal = $msgFinal." & Mois non transmis - Option forcée à mois en cours"; + $parametreMois = $moisP; } -if ($valParams =~ /affiche/) { - $affiche=$cgi->url_param('affiche'); +if ($valParams =~ /affiche/) { + $affiche=$cgi->url_param('affiche'); } my $fileDATA = "$pathDATA/$parametreAnnee/$parametreAnnee-$parametreMois.TXT"; @@ -147,13 +145,13 @@ =head1 Query string parameters push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/dat\n\n"); if ($affiche ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "$titrePage\n", - "", - "\n"; - - print "\n"; - print "\n", - "\n", - "
        Recherche des données, merci de patienter.
        ", - "\n", - "
        \n", - "\n", - "\n", - "\n"; + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "\n", + "
        \n", + "\n", + "\n", + "\n"; } - for (@reseaux) { - my $codeRes = $_; - chomp($codeRes); - my @sta = qx(/bin/ls -d $WEBOBS{RACINE_DATA_STATIONS}/$codeRes*); - my $res = $graphStr{"nom_".$graphStr{"routine_$codeRes"}}; - push(@cleRes,"$codeRes|- réseau $res -"); - for (@sta) { - $s = substr($_,length($_)-8,7); - my %config = readConfStation($s); - $stationsRes{$s} = $config{ALIAS}; - if ($stationsRes{$s} ne "-") { - push(@cleRes,"$s|$stationsRes{$s}"); - } - } + my $codeRes = $_; + chomp($codeRes); + my @sta = qx(/bin/ls -d $WEBOBS{RACINE_DATA_STATIONS}/$codeRes*); + my $res = $graphStr{"nom_".$graphStr{"routine_$codeRes"}}; + push(@cleRes,"$codeRes|- réseau $res -"); + for (@sta) { + $s = substr($_,length($_)-8,7); + my %config = readConfStation($s); + $stationsRes{$s} = $config{ALIAS}; + if ($stationsRes{$s} ne "-") { + push(@cleRes,"$s|$stationsRes{$s}"); + } + } } # Debut du formulaire pour la selection de l'affichage # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ($affiche ne "csv") { - print("
        ", - "

        ", - "Sélectionner: \n", - "\n", - " "); - print "

        \n", - "

        $titrePage

        \n", - "

        Intervalle sélectionné: $afficheMois $parametreAnnee
        ", - "Fichier: $fileDATA

        "; + print("
        ", + "

        ", + "Sélectionner: \n", + "\n", + " "); + print "

        \n", + "

        $titrePage

        \n", + "

        Intervalle sélectionné: $afficheMois $parametreAnnee
        ", + "Fichier: $fileDATA

        "; } # ---- Lecture du fichier de données (dans tableau @lignes) @@ -239,20 +236,19 @@ =head1 Query string parameters $i = 0; open(FILE, "<$fileDATA") || die "fichier $fileDATA non trouvé\n"; $debuts_lignes[0] = tell(FILE); -while() { - $i++; - $debuts_lignes[$i] = tell(FILE); - my $old_fin=$/; - $/="\n";chomp; - $/="\r";chomp; - $/="\r\n";chomp; - $/=$old_fin; - push(@lignes,l2u($_)); +while() { + $i++; + $debuts_lignes[$i] = tell(FILE); + my $old_fin=$/; + $/="\n";chomp; + $/="\r";chomp; + $/="\r\n";chomp; + $/=$old_fin; + push(@lignes,l2u($_)); } close(FILE); my $nbData = @lignes - 1; - my $entete; my $texte = ""; my $modif; @@ -266,73 +262,74 @@ =head1 Query string parameters # Ligne d'en-tête du tableau de données $entete = "Station" - ."Phase P" - ."Temps d'arrivée" - ."Phase S" - ."Distance" - ."Durée
        (s)" - ."Commentaire" - ."TXT" - ."\n"; + ."Phase P" + ."Temps d'arrivée" + ."Phase S" + ."Distance" + ."Durée
        (s)" + ."Commentaire" + ."TXT" + ."\n"; # Tableau de données $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - if (substr($_,0,length($car10)) ne $car10) { - - $sta = substr($_,0,4); - $php = substr($_,4,4); - $tps = substr($_,9,15); - $phs = substr($_,30,10); - $dis = substr($_,99,4); - $dur = substr($_,70,5); - $com = substr($_,75,23); - - if ($stationsRes{$sta}) { - $aliasSite = "$stationsRes{$sta}"; - } else { - $aliasSite = $sta; - } + if (substr($_,0,length($car10)) ne $car10) { - $lien = "$aliasSite"; + $sta = substr($_,0,4); + $php = substr($_,4,4); + $tps = substr($_,9,15); + $phs = substr($_,30,10); + $dis = substr($_,99,4); + $dur = substr($_,70,5); + $com = substr($_,75,23); + + if ($stationsRes{$sta}) { + $aliasSite = "$stationsRes{$sta}"; + } else { + $aliasSite = $sta; + } + + $lien = "$aliasSite"; # my $ligne_txt = substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis; - my $ligne_txt = sprintf("%3s%4s%15s%6s%1s %23s%4s%4s", substr($sta,0,3), $php, $tps, substr($phs,0,6), substr($phs,9,1), $com, substr($dur,1,4), $dis); - $texte = $texte."$lien".substr($sta,0,3)."" - ."$php" - ."$tps" - ."$phs".substr($phs,0,6)."".substr($phs,9,1)."" - ."$dis" - ."$dur".substr($dur,1,4)."" - ."$com" - ."$ligne_txt" - ."\n"; - $txt.=$ligne_txt; + my $ligne_txt = sprintf("%3s%4s%15s%6s%1s %23s%4s%4s", substr($sta,0,3), $php, $tps, substr($phs,0,6), substr($phs,9,1), $com, substr($dur,1,4), $dis); + $texte = $texte."$lien".substr($sta,0,3)."" + ."$php" + ."$tps" + ."$phs".substr($phs,0,6)."".substr($phs,9,1)."" + ."$dis" + ."$dur".substr($dur,1,4)."" + ."$com" + ."$ligne_txt" + ."\n"; + $txt.=$ligne_txt; + # $txt = $txt.substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis."\n"; # $texte .= "
        ".$ligne_txt."
        "; - - $nbLignesRetenues++; - } else { - $texte = $texte." \n"; - } - $i++; + + $nbLignesRetenues++; + } else { + $texte = $texte." \n"; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

        \n", - "

        Télécharger le bulletin au format GUA (Martinique): $fileCSV

        \n", -"
        sprintf(\"%3s%4s%15s%6s%1s    %23s%4s%4s\", substr(\$sta,0,3), \$php, \$tps, substr(\$phs,0,6), substr(\$phs,9,1), \$com, substr(\$dur,1,4), \$dis)
        "); + "

        Télécharger le bulletin au format GUA (Martinique): $fileCSV

        \n", + "
        sprintf(\"%3s%4s%15s%6s%1s    %23s%4s%4s\", substr(\$sta,0,3), \$php, \$tps, substr(\$phs,0,6), substr(\$phs,9,1), \$com, substr(\$dur,1,4), \$dis)
        "); if ($texte ne "") { - push(@html,"$entete\n$texte\n$entete\n
        \n"); + push(@html,"$entete\n$texte\n$entete\n
        \n"); } if ($affiche eq "csv") { - push(@csv,$txt); - print @csv; + push(@csv,$txt); + print @csv; } else { - print @html; - print "\n
        \n@signature\n\n\n"; diff --git a/CODE/cgi-bin/showSOILSOLUTION.pl b/CODE/cgi-bin/showSOILSOLUTION.pl index eac8e6d9..24d8b828 100755 --- a/CODE/cgi-bin/showSOILSOLUTION.pl +++ b/CODE/cgi-bin/showSOILSOLUTION.pl @@ -111,13 +111,13 @@ =head1 Query string parameters my @NODESValidList; my %Ps = $FORM->procs; for my $p (sort keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (sort keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - push(@NODESValidList,"$n"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- {PROC.$p} $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (sort keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + push(@NODESValidList,"$n"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; @@ -174,22 +174,22 @@ =head1 Query string parameters $i = 0; for (@ratios) { - my $rapn = "rap$i"; - if (defined($QryParm->{$rapn})) { - $rap[$i] = 1; - $nbRap++; - } else { $rap[$i] = 0 } - $i++; + my $rapn = "rap$i"; + if (defined($QryParm->{$rapn})) { + $rap[$i] = 1; + $nbRap++; + } else { $rap[$i] = 0 } + $i++; } # ---- a site requested as {name} means "all nodes for proc 'name'" # my @gridsites; if ($QryParm->{'node'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridsites,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridsites,"$_"); + } } # ---- @@ -199,13 +199,13 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'dump'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print qq( + print $cgi->header(-charset=>'utf-8'); + print qq( ).$FORM->conf('TITLE').qq( ); - print qq( + print qq(
        $__{'Searching for the data... please wait'}.
        @@ -216,65 +216,65 @@ =head1 Query string parameters # ---- Debut du formulaire pour la selection de l'affichage # if ($QryParm->{'dump'} ne "csv") { - print "
        conf('CGI_SHOW')."\" method=\"get\">", - ""; + if ($clientAuth > 1) { + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('return_url' => $return_url); + print qq(); + } + print qq(
        ", - "$__{'Start Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "  $__{'End Date'}: "; - print "\n"; - print "\n"; - print "\n"; - print "   + print "conf('CGI_SHOW')."\" method=\"get\">", + ""; - if ($clientAuth > 1) { - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('return_url' => $return_url); - print qq(); - } - print qq(
        ", + "$__{'Start Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "  $__{'End Date'}: "; + print "\n"; + print "\n"; + print "\n"; + print "       + for (@cleParamUnite) { + my ($val,$cle) = split (/\|/,$_); + if ("$val" eq "$QryParm->{'unit'}") { print qq(\n); } + else { print qq(\n); } + } + print qq(   
          \n$__{'Ratios'}:); - $i = 0; - for (@ratios) { - my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); - my $sel_rap = ""; - if ($rap[$i] == 1) { $sel_rap = "checked"; } - print qq($nhtm/$dhtm  ); - $i++; - } - print "
        + $i = 0; + for (@ratios) { + my ($num,$den,$nhtm,$dhtm) = split(/\|/,$_); + my $sel_rap = ""; + if ($rap[$i] == 1) { $sel_rap = "checked"; } + print qq($nhtm/$dhtm  ); + $i++; + } + print "

        ).$FORM->conf('TITLE').qq(

        \n); } @@ -295,40 +295,40 @@ =head1 Query string parameters $header = ""; if ($clientAuth > 1) { - $header = $header.""; + $header = $header.""; } $header = $header."Sampling Time Collection" - ."Site" - ."Lysimeter" - ."Laboratory Meas." - ."Cations ($unit)" - ."Anions ($unit)" - ."NICB
        (%)" - .($nbRap > 0 ? " Ratios":"") - ."\n" - ."Start
        Date & TimeEnd
        Date & TimeDays" - ."Depth
        (cm)Level" - ."pH" - ."Cond.
        (µS)" - ."SiO2
        (ppm)" - ."DOC
        (ppm)" - ."Na+" - ."K+" - ."Mg++" - ."Ca++" - ."HCO3-" - ."Cl-" - ."NO3-" - ."SO4--"; + ."Site" + ."Lysimeter" + ."Laboratory Meas." + ."Cations ($unit)" + ."Anions ($unit)" + ."NICB
        (%)" + .($nbRap > 0 ? " Ratios":"") + ."\n" + ."Start
        Date & TimeEnd
        Date & TimeDays" + ."Depth
        (cm)Level" + ."pH" + ."Cond.
        (µS)" + ."SiO2
        (ppm)" + ."DOC
        (ppm)" + ."Na+" + ."K+" + ."Mg++" + ."Ca++" + ."HCO3-" + ."Cl-" + ."NO3-" + ."SO4--"; $i = 0; for (@ratios) { - my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); - if ($rap[$i] == 1) { - $header = $header."" - ."" - ."
        $nhtm
        $dthm
        "; - } - $i++; + my ($num,$den,$nhtm,$dthm) = split(/\|/,$_); + if ($rap[$i] == 1) { + $header = $header."" + ."" + ."
        $nhtm
        $dthm
        "; + } + $i++; } $header = $header."\n"; @@ -336,130 +336,130 @@ =head1 Query string parameters $i = 0; my $nbLignesRetenues = 0; for (@lines) { - my ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,$_); - if ($i eq 0) { - push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$depth;$level;$pH;$cond;$cSiO2;$cDOC;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;NICB (%);\"$rem\";$val")); - } - elsif (($_ ne "") - && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) - && ($id > 0 || $clientAuth == 4) - && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span - - my ($y,$m,$d) = split(/-/,$date1); - my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); - my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my ($y,$m,$d) = split(/-/,$date2); - my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); - my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); - my $dur = $d1->delta_days($d2)->delta_days; - my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol); - $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=0; - my $cH_mmol = ""; - my $tzp = ""; - my $tzn = ""; - my $nicb = ""; - my @rapv; - my $rapport = ""; - - if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; - if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; - if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; - if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; - if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; - if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; - if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; - if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; - if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } - $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; - if ($tzp != 0) { $tzp += $cH_mmol; } - $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; - if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } - - my $iv = 0; - for (@ratios) { - if ($rap[$iv] == 1) { - my ($num,$den,$nrp) = split(/\|/,$_); - $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); - $rapport = $rapport."$rapv[$iv]"; - } - $iv++; - } - - $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; - - my $normSite = normNode(node=>"PROC.$site"); - if ($normSite ne "") { - $lien = "$aliasSite"; - } else { - $lien = "$aliasSite"; - } - my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); - $form_url->query_form('id' => $id, 'return_url' => $return_url); - $modif = qq(); - $efface = qq(); - - $texte = $texte.""; - if ($clientAuth > 1) { - $texte = $texte."$modif"; - } - $texte = $texte."$date1 $time1$date2 $time2$dur$lien" - ."$depth$level" - ."$pH$cond" - ."$cSiO2$cDOC"; - $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$depth;$level;$pH;$cond;$cSiO2;$cDOC;"; - if ($QryParm->{'unit'} eq "mmol") { - for ("Na","K","Mg","Ca","HCO3","Cl","NO3","SO4") { - $texte .= ""; - if (eval("\$c$_ ne \"\"")) { - $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); - } - $texte .= ""; - } - $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cNO3_mmol;$cSO4_mmol;"; - } else { - $texte .= "$cNa$cK$cMg$cCa" - ."$cHCO3$cCl$cNO3$cSO4"; - $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;"; - } - if ($nicb and ($nicb < -20) || ($nicb > 20)) { - $texte .= ""; - } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { - $texte .= ""; - } else { - $texte .= ""; - } - if ($nicb ne "") { - $texte .= sprintf("%1.1f",$nicb); - } - $texte .= "$rapport"; - $txt = $txt.sprintf("%0.1f",$nicb).";\"$rem\"\n"; - if ($rem ne "") { - $rem =~ s/\'/’/g; - $rem =~ s/\"/"/g; - $texte = $texte.""; - } - $texte = $texte."\n"; - push(@csv,l2u($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date2,$time2,$site,$date1,$time1,$depth,$level,$pH,$cond,$cNa,$cK,$cMg,$cCa,$cHCO3,$cCl,$cNO3,$cSO4,$cSiO2,$cDOC,$rem,$val) = split (/\|/,$_); + if ($i eq 0) { + push(@csv,l2u("$date1;$time1;$date2;$time2;Site ID;$site;$depth;$level;$pH;$cond;$cSiO2;$cDOC;$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;NICB (%);\"$rem\";$val")); + } + elsif (($_ ne "") + && ($site eq $QryParm->{'node'} || grep(/^$site$/, @gridsites) || ($QryParm->{'node'} eq "All" && grep(/^$site$/, @NODESValidList))) + && ($id > 0 || $clientAuth == 4) + && ($date1 le $endDate) && ($date2 ge $startDate)) { # here we accept any data partially included in the time span + + my ($y,$m,$d) = split(/-/,$date1); + my ($hr,$mn) = split(/:/,($time1 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time1)); + my $d1 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my ($y,$m,$d) = split(/-/,$date2); + my ($hr,$mn) = split(/:/,($time2 eq "" ? $FORM->conf('DEFAULT_SAMPLING_TIME'):$time2)); + my $d2 = DateTime->new(year => $y, month => $m, day => $d, hour => ($hr eq "" ? "00":$hr), minute => ($mn eq "" ? "00":$mn)); + my $dur = $d1->delta_days($d2)->delta_days; + my ($cNa_mmol,$cK_mmol,$cMg_mmol,$cCa_mmol,$cCl_mmol,$cNO3_mmol,$cSO4_mmol,$cHCO3_mmol); + $cNa_mmol=$cK_mmol=$cMg_mmol=$cCa_mmol=$cCl_mmol=$cNO3_mmol=$cSO4_mmol=$cHCO3_mmol=0; + my $cH_mmol = ""; + my $tzp = ""; + my $tzn = ""; + my $nicb = ""; + my @rapv; + my $rapport = ""; + + if ($cNa ne "") { $cNa_mmol = $cNa/$GMOL{Na}; }; + if ($cK ne "") { $cK_mmol = $cK/$GMOL{K}; }; + if ($cMg ne "") { $cMg_mmol = $cMg/$GMOL{Mg}; }; + if ($cCa ne "") { $cCa_mmol = $cCa/$GMOL{Ca}; }; + if ($cCl ne "") { $cCl_mmol = $cCl/$GMOL{Cl}; }; + if ($cNO3 ne "") { $cNO3_mmol = $cNO3/$GMOL{NO3}; }; + if ($cSO4 ne "") { $cSO4_mmol = $cSO4/$GMOL{SO4}; }; + if ($cHCO3 ne "") { $cHCO3_mmol = $cHCO3/$GMOL{HCO3}; }; + if ($pH ne "") { $cH_mmol = 1000*10**(-$pH); } + $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; + if ($tzp != 0) { $tzp += $cH_mmol; } + $tzn = $cCl_mmol + 2*$cSO4_mmol + $cHCO3_mmol; + if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } + + my $iv = 0; + for (@ratios) { + if ($rap[$iv] == 1) { + my ($num,$den,$nrp) = split(/\|/,$_); + $rapv[$iv] = eval("sprintf(\"%1.3f\",\$c".$num."_mmol/\$c".$den."_mmol)"); + $rapport = $rapport."$rapv[$iv]"; + } + $iv++; + } + + $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; + + my $normSite = normNode(node=>"PROC.$site"); + if ($normSite ne "") { + $lien = "$aliasSite"; + } else { + $lien = "$aliasSite"; + } + my $form_url = URI->new("/cgi-bin/".$FORM->conf('CGI_FORM')); + $form_url->query_form('id' => $id, 'return_url' => $return_url); + $modif = qq(); + $efface = qq(); + + $texte = $texte.""; + if ($clientAuth > 1) { + $texte = $texte."$modif"; + } + $texte = $texte."$date1 $time1$date2 $time2$dur$lien" + ."$depth$level" + ."$pH$cond" + ."$cSiO2$cDOC"; + $txt = "$date1;$time1;$date2;$time2;$site;$aliasSite;$depth;$level;$pH;$cond;$cSiO2;$cDOC;"; + if ($QryParm->{'unit'} eq "mmol") { + for ("Na","K","Mg","Ca","HCO3","Cl","NO3","SO4") { + $texte .= ""; + if (eval("\$c$_ ne \"\"")) { + $texte .= sprintf($fmt,eval("\$c".$_."_mmol")); + } + $texte .= ""; + } + $txt .= "$cNa_mmol;$cMg_mmol;$cCa_mmol;$cHCO3_mmol;$cCl_mmol;$cNO3_mmol;$cSO4_mmol;"; + } else { + $texte .= "$cNa$cK$cMg$cCa" + ."$cHCO3$cCl$cNO3$cSO4"; + $txt .= "$cNa;$cK;$cMg;$cCa;$cHCO3;$cCl;$cNO3;$cSO4;"; + } + if ($nicb and ($nicb < -20) || ($nicb > 20)) { + $texte .= ""; + } elsif ($nicb and ($nicb < -10) || ($nicb > 10)) { + $texte .= ""; + } else { + $texte .= ""; + } + if ($nicb ne "") { + $texte .= sprintf("%1.1f",$nicb); + } + $texte .= "$rapport"; + $txt = $txt.sprintf("%0.1f",$nicb).";\"$rem\"\n"; + if ($rem ne "") { + $rem =~ s/\'/’/g; + $rem =~ s/\"/"/g; + $texte = $texte.""; + } + $texte = $texte."\n"; + push(@csv,l2u($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"$__{'Number of records'} = $nbLignesRetenues / $nbData.

        \n", - "

        $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

        \n"); + "

        $__{'Download a CSV text file of these data'} conf('CGI_SHOW')."?dump=csv&y1=$QryParm->{'y1'}&m1=$QryParm->{'m1'}&d1=$QryParm->{'d1'}&y2=$QryParm->{'y2'}&m2=$QryParm->{'m2'}&d2=$QryParm->{'d2'}&node=$QryParm->{'node'}&unit=$QryParm->{'unit'}\">$fileCSV

        \n"); if ($texte ne "") { - push(@html,"$header\n$texte\n$header\n
        "); - push(@html,"

        "); + push(@html,"$header\n$texte\n$header\n
        "); + push(@html,"

        "); } push(@html,@notes); if ($QryParm->{'dump'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/showTHEIA.pl b/CODE/cgi-bin/showTHEIA.pl index 0d3e9026..9366f742 100755 --- a/CODE/cgi-bin/showTHEIA.pl +++ b/CODE/cgi-bin/showTHEIA.pl @@ -44,7 +44,7 @@ =head1 DESCRIPTION # ---- checking if user has authorisation to create a JSON metadata file. # ---------------------------------------- if ( ! WebObs::Users::clientHasAdm(type=>"authmisc",name=>"grids")) { - die "You are not authorized" ; + die "You are not authorized" ; } # ---- init general-use variables on the way and quit if something's wrong @@ -61,7 +61,7 @@ =head1 DESCRIPTION my $userid = ""; my $password = ""; my $dbh = DBI->connect($dsn, $userid, $password, { RaiseError => 1 }) - or die $DBI::errstr; + or die $DBI::errstr; # ---- display HTML content print $cgi->header(-type=>'text/html',-charset=>'utf-8'); @@ -87,7 +87,7 @@ =head1 DESCRIPTION my $rv = $sth->execute() or die $DBI::errstr; if($rv < 0) { - print $DBI::errstr; + print $DBI::errstr; } # ---- creating the panel @@ -95,66 +95,66 @@ =head1 DESCRIPTION print "Producer"; print ""; print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + my $contacts; my $funders; my @onlineRes; - -while(my @row = $sth->fetchrow_array()) { - $funders = join(', ',split(/_,/,$row[8])); - @onlineRes = split(/_,/,$row[9]); - foreach (@onlineRes) { - $_ = (split '@', $_)[1]; - } - my $onlineRes = join(', ', @onlineRes); - - # ---- extracting datasets contacts data - my $stmt2 = qq(SELECT * FROM contacts WHERE related_id = '$row[0]';); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - if($rv2 < 0) { - print $DBI::errstr; - } - my @contacts; - while(my @row2 = $sth2->fetchrow_array()){ - push(@contacts, "($row2[3]) ".$row2[1]." ".$row2[2].": ".$row2[0]); - } - print "" - ."" - ."" - ."

        " - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; +while(my @row = $sth->fetchrow_array()) { + $funders = join(', ',split(/_,/,$row[8])); + @onlineRes = split(/_,/,$row[9]); + foreach (@onlineRes) { + $_ = (split '@', $_)[1]; + } + my $onlineRes = join(', ', @onlineRes); + + # ---- extracting datasets contacts data + my $stmt2 = qq(SELECT * FROM contacts WHERE related_id = '$row[0]';); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + if($rv2 < 0) { + print $DBI::errstr; + } + + my @contacts; + while(my @row2 = $sth2->fetchrow_array()){ + push(@contacts, "($row2[3]) ".$row2[1]." ".$row2[2].": ".$row2[0]); + } + print "" + ."" + ."" + ."

        " + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; }; print "
        IdentifierNameTitleDescriptionObjectiveMeasured variablesEmailContactsFundersOnline resource
        IdentifierNameTitleDescriptionObjectiveMeasured variablesEmailContactsFundersOnline resource
        $row[0]  $row[1]" - ."

        		$row[2]" - ."

        		$row[3]" - ."

        		$row[4]" - ."

        		$row[5]" - ."

        		$row[6]" - ."

        		".(join "\n", @contacts) - ."

        		$funders" - ."

        		$onlineRes" - ."

        $row[0]  $row[1]" + ."

        		$row[2]" + ."

        		$row[3]" + ."

        		$row[4]" + ."

        		$row[5]" + ."

        		$row[6]" + ."

        		".(join "\n", @contacts) + ."

        		$funders" + ."

        		$onlineRes" + ."

        \n"; @@ -174,69 +174,70 @@ =head1 DESCRIPTION $rv = $sth->execute() or die $DBI::errstr; if($rv < 0) { - print $DBI::errstr; + print $DBI::errstr; } + # ---- creating the panel print ""; print ""; print "\n"; @@ -250,52 +251,53 @@ =head1 DESCRIPTION $rv = $sth->execute() or die $DBI::errstr; if($rv < 0) { - print $DBI::errstr; + print $DBI::errstr; } + # ---- creating the panel print "
        Datasets"; print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; while(my @row = $sth->fetchrow_array()){ - my $datasetId = (split /_DAT_/, $row[0]) [1]; - ($GRIDName, $NODEName) = (split /\./, $datasetId); - my %S = readNode($NODEName, "novsub"); - my %NODE = %{$S{$NODEName}}; - my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; - - if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ){ - my $subject = join(',', split(/_/,$row[2])); - - # ---- extracting datasets contacts data - my $stmt2 = qq(SELECT * FROM contacts WHERE related_id LIKE '$row[0]%';); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - if($rv2 < 0) { - print $DBI::errstr; - } - - my @contacts; - while(my @row2 = $sth2->fetchrow_array()){ - push(@contacts, $row2[1]." ".$row2[2].": ".$row2[0]); - } - - print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - } else { - print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - } + my $datasetId = (split /_DAT_/, $row[0]) [1]; + ($GRIDName, $NODEName) = (split /\./, $datasetId); + my %S = readNode($NODEName, "novsub"); + my %NODE = %{$S{$NODEName}}; + my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; + + if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ){ + my $subject = join(',', split(/_/,$row[2])); + + # ---- extracting datasets contacts data + my $stmt2 = qq(SELECT * FROM contacts WHERE related_id LIKE '$row[0]%';); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + if($rv2 < 0) { + print $DBI::errstr; + } + + my @contacts; + while(my @row2 = $sth2->fetchrow_array()){ + push(@contacts, $row2[1]." ".$row2[2].": ".$row2[0]); + } + + print "" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + } else { + print "" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + } }; print "
        IdentifierTitleDescriptionSubjectCreator(s)Spatial coverageProvenance
        IdentifierTitleDescriptionSubjectCreator(s)Spatial coverageProvenance
        $row[0]$row[1]$desc$subject".join(', ', @contacts)."$row[3]$row[4]
        No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !
        $row[0]$row[1]$desc$subject".join(', ', @contacts)."$row[3]$row[4]
        No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !No access to $GRIDName.$NODEName !
        "; print ""; print "\n"; diff --git a/CODE/cgi-bin/showVEHICLES.pl b/CODE/cgi-bin/showVEHICLES.pl index 91b1a76b..a5641638 100755 --- a/CODE/cgi-bin/showVEHICLES.pl +++ b/CODE/cgi-bin/showVEHICLES.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl # + =head1 NAME showVEHICLES.pl @@ -90,20 +91,20 @@ =head1 Query string parameters my @NODESSelList; my %Ps = $FORM->procs; for my $p (keys(%Ps)) { - push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); - my %N = $FORM->nodes($p); - for my $n (keys(%N)) { - push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); - } - %Ns = (%Ns, %N); + push(@NODESSelList,"\{$p\}|-- $Ps{$p} --"); + my %N = $FORM->nodes($p); + for my $n (keys(%N)) { + push(@NODESSelList,"$n|$N{$n}{ALIAS}: $N{$n}{NAME}"); + } + %Ns = (%Ns, %N); } my $QryParm = $cgi->Vars; # --- DateTime inits ------------------------------------- my $Ctod = time(); my @tod = localtime($Ctod); -my $jour = strftime('%d',@tod); -my $mois = strftime('%m',@tod); +my $jour = strftime('%d',@tod); +my $mois = strftime('%m',@tod); my $annee = strftime('%Y',@tod); my $moisActuel = strftime('%Y-%m',@tod); my $displayMoisActuel = strftime('%B %Y',@tod); @@ -129,12 +130,12 @@ =head1 Query string parameters my @cleParamAnnee = ("Ancien|Ancien"); for ($FORM->conf('BANG')..$annee) { - push(@cleParamAnnee,"$_|$_"); + push(@cleParamAnnee,"$_|$_"); } my @cleParamMois; for ('01'..'12') { - $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); - push(@cleParamMois,"$_|$s"); + $s = l2u(qx(date -d "$annee-$_-01" +"%B")); chomp($s); + push(@cleParamMois,"$_|$s"); } my @cleParamVehicle; @@ -142,19 +143,19 @@ =head1 Query string parameters my @option = (); -$QryParm->{'annee'} ||= $annee; -$QryParm->{'mois'} ||= "Tout"; -$QryParm->{'vehicle'} ||= "Tout"; -$QryParm->{'affiche'} ||= ""; +$QryParm->{'annee'} ||= $annee; +$QryParm->{'mois'} ||= "Tout"; +$QryParm->{'vehicle'} ||= "Tout"; +$QryParm->{'affiche'} ||= ""; # ---- a vehicle requested as {name} means "all nodes for grid (proc) 'name'" # my @gridvehicles; if ($QryParm->{'vehicle'} =~ /^{(.*)}$/) { - my %tmpN = $FORM->nodes($1); - for (keys(%tmpN)) { - push(@gridvehicles,"$_"); - } + my %tmpN = $FORM->nodes($1); + for (keys(%tmpN)) { + push(@gridvehicles,"$_"); + } } # ---- @@ -164,64 +165,64 @@ =head1 Query string parameters # ---- start html if not CSV output if ($QryParm->{'affiche'} ne "csv") { - print $cgi->header(-charset=>'utf-8'); - print "\n", - "$titrePage\n", - "", - "\n"; - - print "\n", - "\n", - "
        Recherche des données, merci de patienter.
        ", - "\n", - "
        \n", - "\n", - "\n", - "\n"; + print $cgi->header(-charset=>'utf-8'); + print "\n", + "$titrePage\n", + "", + "\n"; + + print "\n", + "\n", + "
        Recherche des données, merci de patienter.
        ", + "\n", + "
        \n", + "\n", + "\n", + "\n"; } # ---- selection-form for display # if ($QryParm->{'affiche'} ne "csv") { - print("conf('CGI_SHOW')."\" method=\"get\">", - "

        ", - "Sélectionner: \n", - "\n", - "", - " "); - if ($editOK) { - print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); - } - print "

        \n", - "

        $titrePage

        \n", - "

        Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
        ", - "Vehicule sélectionnés: $afficheVehicle
        "; + print("
        conf('CGI_SHOW')."\" method=\"get\">", + "

        ", + "Sélectionner: \n", + "\n", + "", + " "); + if ($editOK) { + print("conf('CGI_FORM')."'\" value=\"nouvel enregistrement\">"); + } + print "

        \n", + "

        $titrePage

        \n", + "

        Intervalle sélectionné: $afficheMois $QryParm->{'annee'}
        ", + "Vehicule sélectionnés: $afficheVehicle
        "; } # ---- Lecture du fichier de données (dans tableau @lignes) @@ -242,66 +243,66 @@ =head1 Query string parameters $entete = "

        "; if ($editOK) { - $entete = $entete.""; + $entete = $entete.""; } $entete = $entete.""; - + $entete = $entete."\n"; $i = 0; my $nbLignesRetenues = 0; for(@lignes) { - my ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split(/\|/,$_); - if ($i eq 0) { - push(@csv,u2l("$date;$heure;Code Vehicle;$vehicle;$mileage;$type;$site;$driver;$oil")); - } - elsif (($_ ne "") - && (($QryParm->{'vehicle'} eq "Tout") || ($vehicle =~ $QryParm->{'vehicle'}) || ($vehicle ~~ @gridvehicles)) - && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) - && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { - - $aliasVehicle = $Ns{$vehicle}{ALIAS} ? $Ns{$vehicle}{ALIAS} : $vehicle; - - my $normVehicle = normNode(node=>"PROC.$vehicle"); - if ($normVehicle ne "") { - $lien = "$aliasVehicle"; - } else { $lien = "$aliasVehicle" } - $modif = "conf('CGI_FORM')."?id=$id\">"; - $efface = ""; - - $texte = $texte.""; - if ($editOK) { - $texte = $texte.""; - } - $texte = $texte."" - ."" - .""; - $txt = "$date;$heure;$vehicle;$aliasVehicle;$mileage;$type;$site;$driver;$oil\n"; - push(@csv,u2l($txt)); - - $nbLignesRetenues++; - } - $i++; + my ($id,$date,$heure,$vehicle,$mileage,$type,$site,$driver,$oil) = split(/\|/,$_); + if ($i eq 0) { + push(@csv,u2l("$date;$heure;Code Vehicle;$vehicle;$mileage;$type;$site;$driver;$oil")); + } + elsif (($_ ne "") + && (($QryParm->{'vehicle'} eq "Tout") || ($vehicle =~ $QryParm->{'vehicle'}) || ($vehicle ~~ @gridvehicles)) + && (($QryParm->{'annee'} eq "Tout") || ($QryParm->{'annee'} eq substr($date,0,4)) || (($QryParm->{'annee'} eq "Ancien") && ($date lt $FORM->conf('BANG')))) + && (($QryParm->{'mois'} eq "Tout") || ($QryParm->{'mois'} eq substr($date,5,2)))) { + + $aliasVehicle = $Ns{$vehicle}{ALIAS} ? $Ns{$vehicle}{ALIAS} : $vehicle; + + my $normVehicle = normNode(node=>"PROC.$vehicle"); + if ($normVehicle ne "") { + $lien = "$aliasVehicle"; + } else { $lien = "$aliasVehicle" } + $modif = "conf('CGI_FORM')."?id=$id\">"; + $efface = ""; + + $texte = $texte.""; + if ($editOK) { + $texte = $texte.""; + } + $texte = $texte."" + ."" + .""; + $txt = "$date;$heure;$vehicle;$aliasVehicle;$mileage;$type;$site;$driver;$oil\n"; + push(@csv,u2l($txt)); + + $nbLignesRetenues++; + } + $i++; } push(@html,"Nombre de données affichées = $nbLignesRetenues / $nbData.

        \n", "

        Télécharger un fichier Excel de ces données: conf('CGI_SHOW')."?affiche=csv&annee=$QryParm->{'annee'}&mois=$QryParm->{'mois'}&vehicle=$QryParm->{'vehicle'}\">$fileCSV

        \n"); if ($texte ne "") { - push(@html,"
        Observations"; print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; while(my @row = $sth->fetchrow_array()){ - my $datasetId = $row[7]; - my $channelId = $row[5]; - ($GRIDName, $NODEName) = (split /\./, $datasetId); - $GRIDName = (split /_DAT_/, $GRIDName)[1]; - if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ) { - my $subject = join(',', split(/_/,$row[3])); - print ""; - print $row[0] ~~ @channels ? "" : ""; - print "" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - ."" - .""; - } else { - print "" - ."" - .""; - } + my $datasetId = $row[7]; + my $channelId = $row[5]; + ($GRIDName, $NODEName) = (split /\./, $datasetId); + $GRIDName = (split /_DAT_/, $GRIDName)[1]; + if ( clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") || clientHasAdm(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName") ) { + my $subject = join(',', split(/_/,$row[3])); + print ""; + print $row[0] ~~ @channels ? "" : ""; + print "" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + ."" + .""; + } else { + print "" + ."" + .""; + } }; print "
        IdentifierProcessing levelData typeTemporal extentTime seriesObserved propertyStation nameDatasetData file nameTHEIA category
        IdentifierProcessing levelData typeTemporal extentTime seriesObserved propertyStation nameDatasetData file nameTHEIA category
        $row[0]$row[2]$row[3]$row[4]$row[5]$row[6]$row[7]$row[8]
        No access to $GRIDName.$NODEName\_$channelId !
        $row[0]$row[2]$row[3]$row[4]$row[5]$row[6]$row[7]$row[8]
        No access to $GRIDName.$NODEName\_$channelId !
        DateVehiculeKilomètrageType de déplacementLieuxConducteurPlein?
        $modif$date $heure$lien$mileage$type$site$driver$oil
        $modif$date $heure$lien$mileage$type$site$driver$oil
        $entete\n$texte\n$entete\n
        ", - "

        Types de deplacements: "); - for (@types) { - my ($tpi,$tpn) = split(/\|/,$_); - push(@html,"$tpi = $tpn, "); - } - push(@html,"

        \n"); + push(@html,"$entete\n$texte\n$entete\n
        ", + "

        Types de deplacements: "); + for (@types) { + my ($tpi,$tpn) = split(/\|/,$_); + push(@html,"$tpi = $tpn, "); + } + push(@html,"

        \n"); } if ($QryParm->{'affiche'} eq "csv") { - print @csv; + print @csv; } else { - print @html; - print "\n
        \n\n\n"; diff --git a/CODE/cgi-bin/training.pl b/CODE/cgi-bin/training.pl index 90edba19..16885eb6 100755 --- a/CODE/cgi-bin/training.pl +++ b/CODE/cgi-bin/training.pl @@ -35,7 +35,6 @@ =head1 Query string parameters my $cgi = CGI->new; $cgi->charset('UTF-8'); - # ---- loads arguments my ($date1, $date2, $s3, $conf) = @ARGV; @@ -49,7 +48,7 @@ =head1 Query string parameters # ---- must have admin auth to run if (clientHasAdm(type=>"authprocs",name=>"MC") || clientHasAdm(type=>"authprocs",name=>"$mc3")) { - die "Sorry, you must have administrator right on $mc3 to run this script."; + die "Sorry, you must have administrator right on $mc3 to run this script."; } # ---- Download csv database from the WebObs main-courante @@ -57,7 +56,6 @@ =head1 Query string parameters my $netrc = $WEBOBS{NETRC_FILE}; my $opt = (-e $netrc ? "--netrc-file '$netrc'":""); - # split dates my $y1 = substr($date1, 0,4); my $m1 = substr($date1, 4,2); @@ -91,6 +89,7 @@ =head1 Query string parameters my $verbatim = 3; my $stdout = qx($WEBOBS{ROOT_CODE}/python/AAA/USECASE3_REAL_TIME_SPARSE_CLASSIFICATION_TRAINING.py $MC3{PSE_ROOT_CONF} $MC3{PSE_ROOT_DATA} $MC3{PSE_TMP_FILEPATH} $conf $SEFRAN3{DATASOURCE} $WEBOBS{SLINKTOOL_PRGM} $verbatim); print $stdout if ($debug); + #print "$MC3{PSE_CONF_FILENAME} \n"; __END__ diff --git a/CODE/cgi-bin/usersMgr.pl b/CODE/cgi-bin/usersMgr.pl index cb3188af..0a771afd 100755 --- a/CODE/cgi-bin/usersMgr.pl +++ b/CODE/cgi-bin/usersMgr.pl @@ -77,11 +77,10 @@ =head1 QUERY-STRING PARAMETERS # ---- special functions only for the WebObs Owner my $isWO = WebObs::Users::clientIsWO; - # ---- any reasons why we couldn't go on ? # ---------------------------------------- if ( ! WebObs::Users::clientHasAdm(type=>"authmisc",name=>"users")) { - die "You are not authorized." ; + die "You are not authorized." ; } # ---- parse/defaults query string @@ -118,169 +117,177 @@ =head1 QUERY-STRING PARAMETERS # ---- process (execute) sql insert new row into table 'tbl' # ----------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'insert') { - # query-string must contain all required DB columns values for an sql insert - my $q=''; - if ($QryParm->{'tbl'} eq "user") { - $q = "insert into $WEBOBS{SQL_TABLE_USERS} values(\'$QryParm->{'uid'}\',\'$QryParm->{'fullname'}\',"; - $q .= "\'$QryParm->{'login'}\',\'$QryParm->{'email'}\',\'$QryParm->{'valid'}\',\'$QryParm->{'enddate'}\',\'$QryParm->{'comment'}\')"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "group") { - $q = "insert into $WEBOBS{SQL_TABLE_GROUPS} values(\'$QryParm->{'gid'}\',\'$QryParm->{'uid'}\')"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "notification") { - $q = "insert into $WEBOBS{SQL_TABLE_NOTIFICATIONS} values(\'$QryParm->{'event'}\',\'$QryParm->{'valid'}\',"; - $q .= "\'$QryParm->{'uid'}\',\'$QryParm->{'mailsub'}\',\'$QryParm->{'mailatt'}\',\'$QryParm->{'act'}\')"; - $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; - } - elsif ($authtable ne "") { - $q = "insert into $authtable values(\'$QryParm->{'uid'}\',\'$QryParm->{'res'}\',\'$QryParm->{'auth'}\')"; - $q = "" if ( $QryParm->{'uid'} eq '!' && !$isWO ); - $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; - } else { die "$QryParm->{'action'} for unknown table"; } - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $$refMsg .= " failed to insert new $QryParm->{'tbl'} ($err) "; - $$refMsgColor = "red"; - } else { - $$refMsg .= " successfully inserted new $QryParm->{'tbl'} "; - $$refMsgColor = "green" if ($$refMsgColor ne "red"); - } + + # query-string must contain all required DB columns values for an sql insert + my $q=''; + if ($QryParm->{'tbl'} eq "user") { + $q = "insert into $WEBOBS{SQL_TABLE_USERS} values(\'$QryParm->{'uid'}\',\'$QryParm->{'fullname'}\',"; + $q .= "\'$QryParm->{'login'}\',\'$QryParm->{'email'}\',\'$QryParm->{'valid'}\',\'$QryParm->{'enddate'}\',\'$QryParm->{'comment'}\')"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "group") { + $q = "insert into $WEBOBS{SQL_TABLE_GROUPS} values(\'$QryParm->{'gid'}\',\'$QryParm->{'uid'}\')"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "notification") { + $q = "insert into $WEBOBS{SQL_TABLE_NOTIFICATIONS} values(\'$QryParm->{'event'}\',\'$QryParm->{'valid'}\',"; + $q .= "\'$QryParm->{'uid'}\',\'$QryParm->{'mailsub'}\',\'$QryParm->{'mailatt'}\',\'$QryParm->{'act'}\')"; + $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; + } + elsif ($authtable ne "") { + $q = "insert into $authtable values(\'$QryParm->{'uid'}\',\'$QryParm->{'res'}\',\'$QryParm->{'auth'}\')"; + $q = "" if ( $QryParm->{'uid'} eq '!' && !$isWO ); + $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; + } else { die "$QryParm->{'action'} for unknown table"; } + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $$refMsg .= " failed to insert new $QryParm->{'tbl'} ($err) "; + $$refMsgColor = "red"; + } else { + $$refMsg .= " successfully inserted new $QryParm->{'tbl'} "; + $$refMsgColor = "green" if ($$refMsgColor ne "red"); + } } + # ---- process (execute) sql update a row of table 'tbl' # ---------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'update') { - # query-string must contain all required DB columns values for an sql insert - my $q=''; - if ($QryParm->{'tbl'} eq "user") { - $q = "update $WEBOBS{SQL_TABLE_USERS} set UID=\'$QryParm->{'uid'}\',"; - $q .= " FULLNAME=\'$QryParm->{'fullname'}\', LOGIN=\'$QryParm->{'login'}\',"; - $q .= " EMAIL=\'$QryParm->{'email'}\', VALIDITY=\'$QryParm->{'valid'}\',"; - $q .= " ENDDATE=\'$QryParm->{'enddate'}\', COMMENT=\'$QryParm->{'comment'}\'"; - $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "group") { - $q = "update $WEBOBS{SQL_TABLE_GROUPS} set GID=\'$QryParm->{'gid'}\', UID=\'$QryParm->{'uid'}\'"; - $q .= " WHERE GID=\'$QryParm->{'OLDgid'}\' AND UID=\'$QryParm->{'OLDuid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "notification") { - $q = "update $WEBOBS{SQL_TABLE_NOTIFICATIONS} set EVENT=\'$QryParm->{'event'}\', VALIDITY=\'$QryParm->{'valid'}\', UID=\'$QryParm->{'uid'}\', MAILSUBJECT=\'$QryParm->{'mailsub'}\', MAILATTACH=\'$QryParm->{'mailatt'}\',ACTION=\'$QryParm->{'act'}\'"; - $q .= " WHERE EVENT=\'$QryParm->{'OLDevent'}\' AND UID=\'$QryParm->{'OLDuid'}\' AND ACTION=\'$QryParm->{'OLDact'}\'"; - $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; - } - elsif ($authtable ne "") { - $q = "update $authtable set UID=\'$QryParm->{'uid'}\', RESOURCE=\'$QryParm->{'res'}\', AUTH=\'$QryParm->{'auth'}\'"; - $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\' AND RESOURCE=\'$QryParm->{'OLDres'}\'"; - $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; - } else { die "$QryParm->{'action'} for unknown table"; } - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $$refMsg .= " failed to update $QryParm->{'tbl'} ($err) "; - $$refMsgColor = "red"; - } else { - $$refMsg .= " successfully updated $QryParm->{'tbl'} "; - $$refMsgColor = "green" if ($$refMsgColor ne "red" ); - } + + # query-string must contain all required DB columns values for an sql insert + my $q=''; + if ($QryParm->{'tbl'} eq "user") { + $q = "update $WEBOBS{SQL_TABLE_USERS} set UID=\'$QryParm->{'uid'}\',"; + $q .= " FULLNAME=\'$QryParm->{'fullname'}\', LOGIN=\'$QryParm->{'login'}\',"; + $q .= " EMAIL=\'$QryParm->{'email'}\', VALIDITY=\'$QryParm->{'valid'}\',"; + $q .= " ENDDATE=\'$QryParm->{'enddate'}\', COMMENT=\'$QryParm->{'comment'}\'"; + $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "group") { + $q = "update $WEBOBS{SQL_TABLE_GROUPS} set GID=\'$QryParm->{'gid'}\', UID=\'$QryParm->{'uid'}\'"; + $q .= " WHERE GID=\'$QryParm->{'OLDgid'}\' AND UID=\'$QryParm->{'OLDuid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "notification") { + $q = "update $WEBOBS{SQL_TABLE_NOTIFICATIONS} set EVENT=\'$QryParm->{'event'}\', VALIDITY=\'$QryParm->{'valid'}\', UID=\'$QryParm->{'uid'}\', MAILSUBJECT=\'$QryParm->{'mailsub'}\', MAILATTACH=\'$QryParm->{'mailatt'}\',ACTION=\'$QryParm->{'act'}\'"; + $q .= " WHERE EVENT=\'$QryParm->{'OLDevent'}\' AND UID=\'$QryParm->{'OLDuid'}\' AND ACTION=\'$QryParm->{'OLDact'}\'"; + $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; + } + elsif ($authtable ne "") { + $q = "update $authtable set UID=\'$QryParm->{'uid'}\', RESOURCE=\'$QryParm->{'res'}\', AUTH=\'$QryParm->{'auth'}\'"; + $q .= " WHERE UID=\'$QryParm->{'OLDuid'}\' AND RESOURCE=\'$QryParm->{'OLDres'}\'"; + $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; + } else { die "$QryParm->{'action'} for unknown table"; } + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $$refMsg .= " failed to update $QryParm->{'tbl'} ($err) "; + $$refMsgColor = "red"; + } else { + $$refMsg .= " successfully updated $QryParm->{'tbl'} "; + $$refMsgColor = "green" if ($$refMsgColor ne "red" ); + } } + # ---- process (execute) sql update table 'groups' after user insert or update # ---------------------------------------------------------------------------- if (($QryParm->{'action'} eq 'insert' || $QryParm->{'action'} eq 'update') && $QryParm->{'tbl'} eq "user") { - my $err = set_wo_user_groups($QryParm->{'uid'}, - $cgi->multi_param('gid')); - if ($err) { - $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; - $userMsgColor = "red"; - } else { - $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; - $userMsgColor = "green" if ($userMsgColor ne "red"); - } + my $err = set_wo_user_groups($QryParm->{'uid'}, + $cgi->multi_param('gid')); + if ($err) { + $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; + $userMsgColor = "red"; + } else { + $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; + $userMsgColor = "green" if ($userMsgColor ne "red"); + } } + # ---- process (execute) sql update table 'groups' # ---------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'updgrp') { - my $err = set_wo_group_members($QryParm->{'gid'}, - $cgi->multi_param('uid')); - if ($err) { - $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; - $userMsgColor = "red"; - } else { - $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; - $userMsgColor = "green" if ($userMsgColor ne "red"); - } + my $err = set_wo_group_members($QryParm->{'gid'}, + $cgi->multi_param('uid')); + if ($err) { + $userMsg .= " ‑ failed to update $WEBOBS{SQL_TABLE_GROUPS} ($err) "; + $userMsgColor = "red"; + } else { + $userMsg .= " ‑ $WEBOBS{SQL_TABLE_GROUPS} successfully updated "; + $userMsgColor = "green" if ($userMsgColor ne "red"); + } } + # ---- process (execute) sql delete a row of table 'tbl' # ------------------------------------------------------ if ($QryParm->{'action'} eq 'delete') { - my $q=''; - # query-string must contain all required DB columns values for an sql insert - if ($QryParm->{'tbl'} eq "user") { - $q = "delete from $WEBOBS{SQL_TABLE_USERS}"; - $q .= " WHERE UID=\'$QryParm->{'uid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "group") { - $q = "delete from $WEBOBS{SQL_TABLE_GROUPS}"; - $q .= " WHERE GID=\'$QryParm->{'gid'}\' AND UID=\'$QryParm->{'uid'}\'"; - $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; - } - elsif ($QryParm->{'tbl'} eq "notification") { - $q = "delete from $WEBOBS{SQL_TABLE_NOTIFICATIONS}"; - $q .= " WHERE EVENT=\'$QryParm->{'event'}\' AND UID=\'$QryParm->{'uid'}\' AND ACTION=\'$QryParm->{'act'}\'"; - $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; - } - elsif ($authtable ne "") { - $q = "delete from $authtable"; - $q .= " WHERE UID=\'$QryParm->{'uid'}\' AND RESOURCE=\'$QryParm->{'res'}\'"; - $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; - } else { die "$QryParm->{'action'} for unknown table"; } - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $$refMsg .= " failed to delete in $QryParm->{'tbl'} ($err) "; - $$refMsgColor = "red"; - } else { - $$refMsg .= " successfully deleted in $QryParm->{'tbl'} "; - $$refMsgColor = "green" if ($$refMsgColor ne "red"); - } + my $q=''; + + # query-string must contain all required DB columns values for an sql insert + if ($QryParm->{'tbl'} eq "user") { + $q = "delete from $WEBOBS{SQL_TABLE_USERS}"; + $q .= " WHERE UID=\'$QryParm->{'uid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "group") { + $q = "delete from $WEBOBS{SQL_TABLE_GROUPS}"; + $q .= " WHERE GID=\'$QryParm->{'gid'}\' AND UID=\'$QryParm->{'uid'}\'"; + $refMsg = \$userMsg; $refMsgColor = \$userMsgColor; + } + elsif ($QryParm->{'tbl'} eq "notification") { + $q = "delete from $WEBOBS{SQL_TABLE_NOTIFICATIONS}"; + $q .= " WHERE EVENT=\'$QryParm->{'event'}\' AND UID=\'$QryParm->{'uid'}\' AND ACTION=\'$QryParm->{'act'}\'"; + $refMsg = \$notfMsg; $refMsgColor = \$notfMsgColor; + } + elsif ($authtable ne "") { + $q = "delete from $authtable"; + $q .= " WHERE UID=\'$QryParm->{'uid'}\' AND RESOURCE=\'$QryParm->{'res'}\'"; + $refMsg = \$authMsg; $refMsgColor = \$authMsgColor; + } else { die "$QryParm->{'action'} for unknown table"; } + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $$refMsg .= " failed to delete in $QryParm->{'tbl'} ($err) "; + $$refMsgColor = "red"; + } else { + $$refMsg .= " successfully deleted in $QryParm->{'tbl'} "; + $$refMsgColor = "green" if ($$refMsgColor ne "red"); + } } + # ---- process (execute) sql delete # --------------------------------------------------------------------------------------- if ($QryParm->{'action'} eq 'deleteU') { - if ($QryParm->{'tbl'} eq "group") { - my $q = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." WHERE GID='$QryParm->{'gid'}'"; - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $userMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; - $userMsgColor = "red"; - } else { - $userMsg .= " successfully deleted $QryParm->{'tbl'} "; - $userMsgColor = "green" if ($userMsgColor ne "red"); - } - - } - if ($QryParm->{'tbl'} eq "notification") { - my $q = "DELETE FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." WHERE EVENT='$QryParm->{'event'}'"; - - my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); - if ($err) { - $notfMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; - $notfMsgColor = "red"; - } else { - $notfMsg .= " successfully deleted $QryParm->{'tbl'} "; - $notfMsgColor = "green" if ($notfMsgColor ne "red"); - } - } + if ($QryParm->{'tbl'} eq "group") { + my $q = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." WHERE GID='$QryParm->{'gid'}'"; + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $userMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; + $userMsgColor = "red"; + } else { + $userMsg .= " successfully deleted $QryParm->{'tbl'} "; + $userMsgColor = "green" if ($userMsgColor ne "red"); + } + + } + if ($QryParm->{'tbl'} eq "notification") { + my $q = "DELETE FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." WHERE EVENT='$QryParm->{'event'}'"; + + my $err = execute_queries($WEBOBS{SQL_DB_USERS}, $q); + if ($err) { + $notfMsg .= " failed to delete $QryParm->{'tbl'} ($err) "; + $notfMsgColor = "red"; + } else { + $notfMsg .= " successfully deleted $QryParm->{'tbl'} "; + $notfMsgColor = "green" if ($notfMsgColor ne "red"); + } + } } # ---- start html page @@ -310,64 +317,64 @@ =head1 QUERY-STRING PARAMETERS # ---- build users and groups 'select dropdowns contents' # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(UID), FULLNAME" - ." FROM $WEBOBS{SQL_TABLE_USERS} ORDER BY UID"); + "SELECT DISTINCT(UID), FULLNAME" + ." FROM $WEBOBS{SQL_TABLE_USERS} ORDER BY UID"); my $selusers = ""; for my $uid_name (@$db_rows) { - my ($uid, $name) = @$uid_name; - $selusers .= qq(); + my ($uid, $name) = @$uid_name; + $selusers .= qq(); } $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." ORDER BY GID"); + "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." ORDER BY GID"); my $selgrps = ""; for my $row (@$db_rows) { - my ($gid) = @$row; - $selgrps .= ""; + my ($gid) = @$row; + $selgrps .= ""; } # ---- build 'users' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT u.UID,FULLNAME,LOGIN,EMAIL,VALIDITY,ENDDATE,COMMENT," - ."group_concat(GID) AS groups" - ." FROM $WEBOBS{SQL_TABLE_USERS} u" - ." LEFT JOIN $WEBOBS{SQL_TABLE_GROUPS} g" - ." ON (u.uid = g.uid)" - ." GROUP BY u.UID ORDER BY u.UID"); + "SELECT u.UID,FULLNAME,LOGIN,EMAIL,VALIDITY,ENDDATE,COMMENT," + ."group_concat(GID) AS groups" + ." FROM $WEBOBS{SQL_TABLE_USERS} u" + ." LEFT JOIN $WEBOBS{SQL_TABLE_GROUPS} g" + ." ON (u.uid = g.uid)" + ." GROUP BY u.UID ORDER BY u.UID"); my $dusers = ''; my $dusersCount = 0; my $dusersCountValid = 0; my $dusersId = ''; for my $row (@$db_rows) { - my ($dusers_uid, $dusers_fullname, $dusers_login, $dusers_email, - $dusers_validity, $dusers_enddate, $dusers_comment, $dusers_groups) = @$row; - $dusers_groups //= ''; - $dusers_groups =~ s/,/ /g; - $dusersCount++; - $dusersCountValid++ if ($dusers_validity eq 'Y' && ($dusers_enddate eq '' || $dusers_enddate gt $today)); - $dusersId = "udef".$dusersCount; - - # Webobs owner and visitor user row should be grayed and have no edition/deletion link - my $tr_classes = ''; - my $edit_link = ''; - my $del_link = ''; - if ($dusers_uid eq "!" || $dusers_uid eq "?" ) { - $tr_classes = "trlock"; - } else { - if ($dusers_validity ne "Y" || ($dusers_enddate ne "" && $dusers_enddate lt $today)) { - $tr_classes = "troff"; - } - $edit_link = "" - .""; - $del_link = "" - ."" if ($isWO); - } - - # Build user table row (also used as input for the user edition form) - $dusers .= <<_EOD_; + my ($dusers_uid, $dusers_fullname, $dusers_login, $dusers_email, + $dusers_validity, $dusers_enddate, $dusers_comment, $dusers_groups) = @$row; + $dusers_groups //= ''; + $dusers_groups =~ s/,/ /g; + $dusersCount++; + $dusersCountValid++ if ($dusers_validity eq 'Y' && ($dusers_enddate eq '' || $dusers_enddate gt $today)); + $dusersId = "udef".$dusersCount; + +# Webobs owner and visitor user row should be grayed and have no edition/deletion link + my $tr_classes = ''; + my $edit_link = ''; + my $del_link = ''; + if ($dusers_uid eq "!" || $dusers_uid eq "?" ) { + $tr_classes = "trlock"; + } else { + if ($dusers_validity ne "Y" || ($dusers_enddate ne "" && $dusers_enddate lt $today)) { + $tr_classes = "troff"; + } + $edit_link = "" + .""; + $del_link = "" + ."" if ($isWO); + } + + # Build user table row (also used as input for the user edition form) + $dusers .= <<_EOD_; $edit_link $del_link @@ -386,17 +393,17 @@ =head1 QUERY-STRING PARAMETERS # ---- build 'unique groups' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." ORDER BY GID"); + "SELECT DISTINCT(GID) FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." ORDER BY GID"); my $dugrps = ''; my $dugrpsCount = 0; my $dugrpsId = ''; for my $row (@$db_rows) { - my ($gid) = @$row; - $dugrpsCount++; - $dugrpsId="nudef".$dugrpsCount; - $dugrps .= <<_EOD_ + my ($gid) = @$row; + $dugrpsCount++; + $dugrpsId="nudef".$dugrpsCount; + $dugrps .= <<_EOD_ @@ -411,20 +418,20 @@ =head1 QUERY-STRING PARAMETERS # ---- build S'groups' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT GID,GROUP_CONCAT(UID) AS UIDS" - ." FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." GROUP BY GID ORDER BY GID"); + "SELECT GID,GROUP_CONCAT(UID) AS UIDS" + ." FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." GROUP BY GID ORDER BY GID"); my $Sdgrps = ''; my $SdgrpsCount = 0; my $SdgrpsId = ''; for my $row (@$db_rows) { - my ($Sdgrps_gid, $Sdgrps_uids) = @$row; - $Sdgrps_uids =~ s/,/ /g; - $SdgrpsCount++; - $SdgrpsId="gdef".$SdgrpsCount; + my ($Sdgrps_gid, $Sdgrps_uids) = @$row; + $Sdgrps_uids =~ s/,/ /g; + $SdgrpsCount++; + $SdgrpsId="gdef".$SdgrpsCount; - $Sdgrps .= <<_EOD_; + $Sdgrps .= <<_EOD_; @@ -445,19 +452,19 @@ =head1 QUERY-STRING PARAMETERS # ---- build 'unique evnt notifications' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT DISTINCT(EVENT)" - ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." ORDER BY EVENT"); + "SELECT DISTINCT(EVENT)" + ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." ORDER BY EVENT"); my $dunotf = ''; my $dunotfCount = 0; my $dunotfId = ''; for my $row (@$db_rows) { - my ($event) = @$row; - $dunotfCount++; - $dunotfId="nudef".$dunotfCount; - $dunotf .= <<_EOD_; + my ($event) = @$row; + $dunotfCount++; + $dunotfId="nudef".$dunotfCount; + $dunotf .= <<_EOD_; @@ -472,20 +479,20 @@ =head1 QUERY-STRING PARAMETERS # ---- build 'notifications' table result rows # ----------------------------------------------------------------------------- $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT EVENT,VALIDITY,UID,MAILSUBJECT,MAILATTACH,ACTION" - ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." ORDER BY 1"); + "SELECT EVENT,VALIDITY,UID,MAILSUBJECT,MAILATTACH,ACTION" + ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." ORDER BY 1"); my $dnotf = ''; my $dnotfCount = 0; my $dnotfId = ''; for my $row (@$db_rows) { - my ($dnotf_event, $dnotf_valid, $dnotf_mail, $dnotf_mailsubj, - $dnotf_mailatt, $dnotf_act) = @$row; + my ($dnotf_event, $dnotf_valid, $dnotf_mail, $dnotf_mailsubj, + $dnotf_mailatt, $dnotf_act) = @$row; - $dnotfCount++; - $dnotfId="ndef".$dnotfCount; - $dnotf .= <<_EOD_; + $dnotfCount++; + $dnotfId="ndef".$dnotfCount; + $dnotf .= <<_EOD_; @@ -512,44 +519,43 @@ =head1 QUERY-STRING PARAMETERS my $postboardstatus=""; my @PBREPLY = qx($WEBOBS{ROOT_CODE}/shells/postboard status); if ( scalar(@PBREPLY) > 0 ) { - my @td1 = map {$_ =~ s/\n/
        /; $_} (grep { /STATTIME=|STARTED=|PID=|USER=/ } @PBREPLY); - s/POSTBOARD NOT RUNNING/POSTBOARD NOT RUNNING<\/span>/ for @td1; - my @td2 = map {$_ =~ s/\n/
        /; $_} (grep { /FIFO=|LOG=/ } @PBREPLY); - $postboardstatus = "
        @td1@td2
        " + my @td1 = map {$_ =~ s/\n/
        /; $_} (grep { /STATTIME=|STARTED=|PID=|USER=/ } @PBREPLY); + s/POSTBOARD NOT RUNNING/POSTBOARD NOT RUNNING<\/span>/ for @td1; + my @td2 = map {$_ =~ s/\n/
        /; $_} (grep { /FIFO=|LOG=/ } @PBREPLY); + $postboardstatus = "
        @td1@td2
        " } else { $postboardstatus = "POSTBOARD IS NOT RUNNING !"} - # ---- build 'auth' table result rows # ----------------------------------------------------------------------------- my %TA; for my $an (qw(proc view form wiki misc)) { - my %auth_tablenames = ( - "proc" => $WEBOBS{SQL_TABLE_AUTHPROCS}, - "view" => $WEBOBS{SQL_TABLE_AUTHVIEWS}, - "form" => $WEBOBS{SQL_TABLE_AUTHFORMS}, - "wiki" => $WEBOBS{SQL_TABLE_AUTHWIKIS}, - "misc" => $WEBOBS{SQL_TABLE_AUTHMISC}, - ); - $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, - "SELECT UID,RESOURCE,AUTH FROM $auth_tablenames{$an}" - ." ORDER BY UID,RESOURCE"); - $TA{$an}{dauth} = ''; - $TA{$an}{dauthCount} = 0; - - for my $row (@$db_rows) { - my ($dauth_uid, $dauth_res, $dauth_auth) = @$row; - - my $td_modif_auth = ''; - my $td_delete_auth = ''; - $TA{$an}{dauthCount}++; - my $dauthId="adef$an".$TA{$an}{dauthCount}; - if ($dauth_uid ne '!' || $isWO) { - $td_modif_auth = "        " - .""; - $td_delete_auth = "" - .""; - } - $TA{$an}{dauth} .= <<_EOD_; + my %auth_tablenames = ( + "proc" => $WEBOBS{SQL_TABLE_AUTHPROCS}, + "view" => $WEBOBS{SQL_TABLE_AUTHVIEWS}, + "form" => $WEBOBS{SQL_TABLE_AUTHFORMS}, + "wiki" => $WEBOBS{SQL_TABLE_AUTHWIKIS}, + "misc" => $WEBOBS{SQL_TABLE_AUTHMISC}, + ); + $db_rows = fetch_all($WEBOBS{SQL_DB_USERS}, + "SELECT UID,RESOURCE,AUTH FROM $auth_tablenames{$an}" + ." ORDER BY UID,RESOURCE"); + $TA{$an}{dauth} = ''; + $TA{$an}{dauthCount} = 0; + + for my $row (@$db_rows) { + my ($dauth_uid, $dauth_res, $dauth_auth) = @$row; + + my $td_modif_auth = ''; + my $td_delete_auth = ''; + $TA{$an}{dauthCount}++; + my $dauthId="adef$an".$TA{$an}{dauthCount}; + if ($dauth_uid ne '!' || $isWO) { + $td_modif_auth = "" + .""; + $td_delete_auth = "" + .""; + } + $TA{$an}{dauth} .= <<_EOD_; $td_modif_auth $td_delete_auth @@ -558,7 +564,7 @@ =head1 QUERY-STRING PARAMETERS $dauth_auth _EOD_ - } + } } # ---- assemble the page @@ -789,10 +795,10 @@ =head1 QUERY-STRING PARAMETERS

        EOPART2 - print ""; - print "
        "; - for my $i (qw(view proc form)) { - print <<"EOAUTH1" +print ""; +print "
        "; +for my $i (qw(view proc form)) { + print <<"EOAUTH1"
        $i
        @@ -809,13 +815,13 @@ =head1 QUERY-STRING PARAMETERS
        EOAUTH1 - } - print "
        "; +} +print "
        "; - print ""; - print ""); + +# il faut balayer 6 semaines pour être sûr d'avoir le mois complet dans toutes les situations... + for (0..41) { + $j = qx(date -I -d "$lundiCalendrier $_ days"); chomp($j); + if (($_ % 7) == 0) { + if (($_ != 0) && (substr($j,5,2) ne substr($moisCalendrier,5,2))) { + last; + } else { + +#$s = qx(date -d "$j" +"\%W"); chomp($s); +# permet de choisir le n° semaine suivant l'année du calendrier (dernière semaine Y ou première semaine Y+1) + if (substr($j,0,4) != $anneeCalendrier) { $s = qx(date -d "$j 6 days" +%V); } + else { $s = qx(date -d "$j" +%V); } + chomp($s); + +#push(@contenu,"\n"); + push(@contenu,"\n"); + } + } + if (substr($j,5,2) ne substr($moisCalendrier,5,2)) { + $s = "class=\"CalendarOutMonth\""; + } else { + $s = "class=\"CalendarInMonth\""; + if (($_%7) >= 5) { $s = "class=\"CalendarWeekend\""; } + my @jf = grep(/$j/,@feries); + if (@jf and length($jf[0]) > 0) { + my ($dd,$ss) = split(/\|/,$jf[0]); + chomp($ss); + $ss =~ s/\'/’/g; + $ss =~ s/\"/"/g; + $s = "class=\"CalendarFerie\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\""; + } + } + if ($j eq $todayDate) { $s = "class=\"CalendarToday\""; } + push(@contenu,""); + } + push(@contenu,"
        "; - for my $i (qw(wiki misc)) { - print <<"EOAUTH2" +print ""; +print "\n"; +print "
        "; +for my $i (qw(wiki misc)) { + print <<"EOAUTH2"
        $i
        @@ -844,87 +850,90 @@ =head1 QUERY-STRING PARAMETERS # Connect to the database and return the handler # ------------------------------------------------------------------------------ sub db_connect { - # Open a connection to a SQLite database using RaiseError. - # - # Usage example: - # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) - # || die "Error connecting to $dbname: $DBI::errstr"; - # - my $dbname = shift; - my $opts = shift || {}; - my %default_options = ( - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - ); - my %options = (%default_options, %$opts); - return DBI->connect("dbi:SQLite:$dbname", "", "", \%options); -} + # Open a connection to a SQLite database using RaiseError. + # + # Usage example: + # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) + # || die "Error connecting to $dbname: $DBI::errstr"; + # + my $dbname = shift; + my $opts = shift || {}; + my %default_options = ( + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + ); + my %options = (%default_options, %$opts); + return DBI->connect("dbi:SQLite:$dbname", "", "", \%options); +} # Fetch and return all results of a select statement # ----------------------------------------------------------------------------- sub fetch_all { - # - # Connect to a database, run the given SQL statement, and - # return a reference to an array of array references. - # - my $dbname = shift; - my $query = shift; - - my $dbh = db_connect($dbname); - if (not $dbh) { - logit("Error connecting to $dbname: $DBI::errstr"); - return; - } - # Will raise an error if anything goes wrong - my $ref = $dbh->selectall_arrayref($query); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $dbname: ".$dbh->errstr; - return $ref; + # + # Connect to a database, run the given SQL statement, and + # return a reference to an array of array references. + # + my $dbname = shift; + my $query = shift; + + my $dbh = db_connect($dbname); + if (not $dbh) { + logit("Error connecting to $dbname: $DBI::errstr"); + return; + } + + # Will raise an error if anything goes wrong + my $ref = $dbh->selectall_arrayref($query); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $dbname: ".$dbh->errstr; + return $ref; } # Atomatically execute a list of queries # ----------------------------------------------------------------------------- sub execute_queries { - # - # Connect to a database and atomically execute the given SQL - # statements, using DBI->do(). - # Log error or warning to stderr/logs if anything goes wrong. - # Return an empty string on success, the error message otherwise. - # - my $dbname = shift; - my @queries = @_; - my $err_msg = ""; - - my $dbh = db_connect($dbname, {'AutoCommit' => 0}); - if (not $dbh) { - logit("Error connecting to $dbname: $DBI::errstr"); - return $DBI::errstr; - } - try { - for my $q (@queries) { - $dbh->do($q); - } - } catch { - # Catch errors to show them to the user - # (Try::Tiny sets $_ to the exception message) - $err_msg = $_; - # Log the queries for information (the error is already logged by DBI, - # as we use the PrintError option). - warn "Error while executing queries '".join("; ", @queries) - ." (rolling back)"; - eval { $dbh->rollback() }; # rollback might fail - }; - if (not $err_msg) { - $dbh->commit(); - } - $dbh->disconnect() - or CORE::warn "Got warning while disconnecting from $dbname: " - .$dbh->errstr; - - return $err_msg; + # + # Connect to a database and atomically execute the given SQL + # statements, using DBI->do(). + # Log error or warning to stderr/logs if anything goes wrong. + # Return an empty string on success, the error message otherwise. + # + my $dbname = shift; + my @queries = @_; + my $err_msg = ""; + + my $dbh = db_connect($dbname, {'AutoCommit' => 0}); + if (not $dbh) { + logit("Error connecting to $dbname: $DBI::errstr"); + return $DBI::errstr; + } + try { + for my $q (@queries) { + $dbh->do($q); + } + } catch { + + # Catch errors to show them to the user + # (Try::Tiny sets $_ to the exception message) + $err_msg = $_; + + # Log the queries for information (the error is already logged by DBI, + # as we use the PrintError option). + warn "Error while executing queries '".join("; ", @queries) + ." (rolling back)"; + eval { $dbh->rollback() }; # rollback might fail + }; + if (not $err_msg) { + $dbh->commit(); + } + $dbh->disconnect() + or CORE::warn "Got warning while disconnecting from $dbname: " + .$dbh->errstr; + + return $err_msg; } # ------------------------------------------------------------------------------ @@ -933,23 +942,23 @@ sub execute_queries { # occured and the gropu members could not be updated. # sub set_wo_group_members { - my $gid = shift; # group GID - my @uids = @_; # UIDs of group members - - # Insert members of the group - my @values = map { "('$gid', '$_')" } @uids; - my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " - .join(',', @values); - - # Delete any removed members from the group. This is done _after_ we have - # inserted new members to prevent the group from having no member for a - # short while, as the SQL trigger on the 'groups' table would remove the - # group entries in 'auth*' and 'notifications' tables. - my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" - ." WHERE GID='$gid' AND UID NOT IN (" - .join(",", map { "'$_'" } @uids).")"; - - return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); + my $gid = shift; # group GID + my @uids = @_; # UIDs of group members + + # Insert members of the group + my @values = map { "('$gid', '$_')" } @uids; + my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " + .join(',', @values); + + # Delete any removed members from the group. This is done _after_ we have + # inserted new members to prevent the group from having no member for a + # short while, as the SQL trigger on the 'groups' table would remove the + # group entries in 'auth*' and 'notifications' tables. + my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS}" + ." WHERE GID='$gid' AND UID NOT IN (" + .join(",", map { "'$_'" } @uids).")"; + + return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); } # ------------------------------------------------------------------------------ @@ -958,26 +967,25 @@ sub set_wo_group_members { # occured and the memberships could not be updated. # sub set_wo_user_groups { - my $uid = shift; # user UID - my @gids = @_; # GIDs of groups the user is a member of - - # Insert the user in its groups - my @values = map { "('$_', '$uid')" } @gids; - my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " - .join(',', @values); - - # Delete any group membership for the user. This is done _after_ we have - # inserted new memberships to prevent any group from having no member for - # a short while, as the SQL trigger on the 'groups' table would remove the - # group entries in 'auth*' and 'notifications' tables. - my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS} " - ."WHERE UID='$uid' AND GID NOT IN (" - .join(",", map { "'$_'" } @gids).")"; - - return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); + my $uid = shift; # user UID + my @gids = @_; # GIDs of groups the user is a member of + + # Insert the user in its groups + my @values = map { "('$_', '$uid')" } @gids; + my $insert_stm = "INSERT OR REPLACE INTO $WEBOBS{SQL_TABLE_GROUPS} VALUES " + .join(',', @values); + + # Delete any group membership for the user. This is done _after_ we have + # inserted new memberships to prevent any group from having no member for + # a short while, as the SQL trigger on the 'groups' table would remove the + # group entries in 'auth*' and 'notifications' tables. + my $delete_stm = "DELETE FROM $WEBOBS{SQL_TABLE_GROUPS} " + ."WHERE UID='$uid' AND GID NOT IN (" + .join(",", map { "'$_'" } @gids).")"; + + return execute_queries($WEBOBS{SQL_DB_USERS}, $insert_stm, $delete_stm); } - __END__ =pod diff --git a/CODE/cgi-bin/vedit.pl b/CODE/cgi-bin/vedit.pl index 7dc3f277..bca2fdaa 100755 --- a/CODE/cgi-bin/vedit.pl +++ b/CODE/cgi-bin/vedit.pl @@ -146,38 +146,40 @@ =head1 Markitup customization my $tz = ""; if ($action =~ /upd|new|del|save/i) { - if (defined($GRIDType)) { - $isProject = ($evpath =~ /$NODEName\_Projet.txt/); - if (clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { - if ( $isProject && basename($evpath) ne $evpath ) { die $__{'invalid project name'} } - if ( $action =~ /upd|del/i && $evpath !~ /.*\.txt$/i) { die "\"$evpath\" $__{'invalid for action'} $action" } - if ( $action =~ /upd|del/i && !-f "$evbase/$evpath") { die "\"$evpath\" $__{'not found'}" } - if ( $action =~ /new/i && -f "$evbase/$evpath" ) { $action = 'upd' } # new on existing: force upd ! - } else { - die "$__{'Not authorized'}"; - } - } else { - die "$__{'invalid event object'}"; - } + if (defined($GRIDType)) { + $isProject = ($evpath =~ /$NODEName\_Projet.txt/); + if (clientHasEdit(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")) { + if ( $isProject && basename($evpath) ne $evpath ) { die $__{'invalid project name'} } + if ( $action =~ /upd|del/i && $evpath !~ /.*\.txt$/i) { die "\"$evpath\" $__{'invalid for action'} $action" } + if ( $action =~ /upd|del/i && !-f "$evbase/$evpath") { die "\"$evpath\" $__{'not found'}" } + if ( $action =~ /new/i && -f "$evbase/$evpath" ) { $action = 'upd' } # new on existing: force upd ! + } else { + die "$__{'Not authorized'}"; + } + } else { + die "$__{'invalid event object'}"; + } } else { - die "$__{'No or invalid action'}"; + die "$__{'No or invalid action'}"; } my $objectfullname; my %NODE; my %GRID; + # object if a node (gridtype.gridname.nodename) if ($object =~ /^.*\..*\..*$/) { - my %S = readNode($NODEName); - %NODE = %{$S{$NODEName}}; - $objectfullname = "$NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})"; - $tz = $NODE{TZ}; -# ... or a grid (gridtype.gridname) + my %S = readNode($NODEName); + %NODE = %{$S{$NODEName}}; + $objectfullname = "$NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})"; + $tz = $NODE{TZ}; + + # ... or a grid (gridtype.gridname) } else { - my %S = readGrid($object); - %GRID = %{$S{$object}}; - $objectfullname = "$GRID{NAME}"; - $tz = $GRID{TZ}; + my %S = readGrid($object); + %GRID = %{$S{$object}}; + $objectfullname = "$GRID{NAME}"; + $tz = $GRID{TZ}; } # --------------------------------------------------------------------------------------- @@ -185,85 +187,90 @@ =head1 Markitup customization # write event's form elements to event file (object,event,formelements) # if ($action =~ /save/i ) { - my $logmsg = ""; - my @lines; - # determine $target which is the full path to the event file we want to 'save' - # from $evbase which is the events (=interventions) root directory path - # and $evpath (event= in querystring) which is the event file name relative to $evbase: - # $evpath is: "subpath/evname.txt" OR "subpath" OR "" - $target = "$evbase/$evpath"; - # extract the event's file name from $evpath and make sure the path exists - my $evname = ($evpath =~ /.*\.txt$/) ? basename($evpath) : ""; - - my $tline = join("+",@oper)."/".join("+",@roper)."|$titre"; - if (!$isProject) { - $tline .= "|$date2 $time2|$feature|$channel|$outcome|$notebook|$notebookfwd"; - # now build an event's file name from form's elements - $time =~ s/:/-/; - my $formname = "$NODEName\_$date\_$time.txt"; - if ($evname eq "") { # no *txt specified, use $formname (new event) - $target = "$evbase/$evpath/$formname"; - WebObs::Events::versionit(\$target); - my $fp = dirname($target); qx(mkdir -p "$fp" 2>/dev/null); - } else { - # moving an event - if ($mvnode ne "" && $mvnode ne $NODEName) { - (my $object2 = $object) =~ s/$NODEName/$mvnode/; - (my $evpath2 = $evpath) =~ s/$NODEName/$mvnode/; - my ($GRIDType2, $GRIDName2, $NODEName2, $evbase2, $evtrash2) = WebObs::Events::struct(trim($object2)); - my $formname2 = "$mvnode\_$date\_$time.txt"; - my $evname2 = ($evpath2 =~ /.*\.txt$/) ? basename($evpath2) : ""; - $target = "$evbase2/$formname2"; - WebObs::Events::versionit(\$target); - my $fp = dirname($target); - qx(mkdir -p "$fp" 2>/dev/null); - (my $evsrc = $evname2) =~ s/.txt//; - (my $evtgt = $formname2) =~ s/.txt//; - $logmsg .= "moving event $evpath to $evname2\n"; - qx(mv "$evbase/$evpath" $target); # rename event file - qx(mv "$evbase/$evsrc/" "$evbase2/$evtgt"); # rename event extensions dir - qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file - $logmsg .= "deleting gazette $evpath\n"; - my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); - } - # renaming of an event (*.txt != $formname) - elsif ($evname ne $formname) { - $target = dirname("$evbase/$evpath")."/$formname"; - WebObs::Events::versionit(\$target); - my $fp = dirname($target); - qx(mkdir -p "$fp" 2>/dev/null); - (my $evsrc = $evname) =~ s/.txt//; - (my $evtgt = $formname) =~ s/.txt//; - $logmsg .= "renaming event $evpath\n"; - qx(mv "$evbase/$evpath" $target); # rename event file - qx(mv "$evbase/$evsrc/" "$evbase/$evtgt"); # rename event extensions dir - qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file - $logmsg .= "deleting gazette $evpath\n"; - my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); - } - } - } - $logmsg .= "saving ".basename($target); - if ( sysopen(FILE, "$target", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $target..."; - flock(FILE, LOCK_EX); - } - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - if ($conv eq "1") { # add MMD - $contents = WebObs::Wiki::wiki2MMD($contents); - $contents = "WebObs: converted with wiki2MMD\n\n$contents"; - } - $contents =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lines,$tline."\n"); - push(@lines,$contents); - print FILE @lines; - close(FILE); - htmlMsgOK("$logmsg"); - } else { htmlMsgNotOK("$logmsg\nerror $! opening ".basename($target)) } - - exit; + my $logmsg = ""; + my @lines; + +# determine $target which is the full path to the event file we want to 'save' +# from $evbase which is the events (=interventions) root directory path +# and $evpath (event= in querystring) which is the event file name relative to $evbase: +# $evpath is: "subpath/evname.txt" OR "subpath" OR "" + $target = "$evbase/$evpath"; + + # extract the event's file name from $evpath and make sure the path exists + my $evname = ($evpath =~ /.*\.txt$/) ? basename($evpath) : ""; + + my $tline = join("+",@oper)."/".join("+",@roper)."|$titre"; + if (!$isProject) { + $tline .= "|$date2 $time2|$feature|$channel|$outcome|$notebook|$notebookfwd"; + + # now build an event's file name from form's elements + $time =~ s/:/-/; + my $formname = "$NODEName\_$date\_$time.txt"; + if ($evname eq "") { # no *txt specified, use $formname (new event) + $target = "$evbase/$evpath/$formname"; + WebObs::Events::versionit(\$target); + my $fp = dirname($target); qx(mkdir -p "$fp" 2>/dev/null); + } else { + + # moving an event + if ($mvnode ne "" && $mvnode ne $NODEName) { + (my $object2 = $object) =~ s/$NODEName/$mvnode/; + (my $evpath2 = $evpath) =~ s/$NODEName/$mvnode/; + my ($GRIDType2, $GRIDName2, $NODEName2, $evbase2, $evtrash2) = WebObs::Events::struct(trim($object2)); + my $formname2 = "$mvnode\_$date\_$time.txt"; + my $evname2 = ($evpath2 =~ /.*\.txt$/) ? basename($evpath2) : ""; + $target = "$evbase2/$formname2"; + WebObs::Events::versionit(\$target); + my $fp = dirname($target); + qx(mkdir -p "$fp" 2>/dev/null); + (my $evsrc = $evname2) =~ s/.txt//; + (my $evtgt = $formname2) =~ s/.txt//; + $logmsg .= "moving event $evpath to $evname2\n"; + qx(mv "$evbase/$evpath" $target); # rename event file + qx(mv "$evbase/$evsrc/" "$evbase2/$evtgt"); # rename event extensions dir + qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file + $logmsg .= "deleting gazette $evpath\n"; + my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); + } + + # renaming of an event (*.txt != $formname) + elsif ($evname ne $formname) { + $target = dirname("$evbase/$evpath")."/$formname"; + WebObs::Events::versionit(\$target); + my $fp = dirname($target); + qx(mkdir -p "$fp" 2>/dev/null); + (my $evsrc = $evname) =~ s/.txt//; + (my $evtgt = $formname) =~ s/.txt//; + $logmsg .= "renaming event $evpath\n"; + qx(mv "$evbase/$evpath" $target); # rename event file + qx(mv "$evbase/$evsrc/" "$evbase/$evtgt"); # rename event extensions dir + qx(rm "$evbase/$evpath~" 2>/dev/null); # delete legacy bkup file + $logmsg .= "deleting gazette $evpath\n"; + my $rcd = WebObs::Gazette::delEventArticle($object, "$evbase/$evpath"); + } + } + } + $logmsg .= "saving ".basename($target); + if ( sysopen(FILE, "$target", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $target..."; + flock(FILE, LOCK_EX); + } + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + if ($conv eq "1") { # add MMD + $contents = WebObs::Wiki::wiki2MMD($contents); + $contents = "WebObs: converted with wiki2MMD\n\n$contents"; + } + $contents =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lines,$tline."\n"); + push(@lines,$contents); + print FILE @lines; + close(FILE); + htmlMsgOK("$logmsg"); + } else { htmlMsgNotOK("$logmsg\nerror $! opening ".basename($target)) } + + exit; } # --------------------------------------------------------------------------------------- @@ -271,27 +278,31 @@ =head1 Markitup customization # delete actually is a 'move' to a shared EVENT trash directory # if ($action =~ /del/i ) { - #dbg# $msg .= "deleting \no=$object\nb=$evbase\nt=$evtrash\ne=$evpath\nE=$evp"; - (my $evp = $evpath) =~ s/\.txt$//; - # list (@tree) all children of event to delete from its eventTree() - my @tree = ("$evbase/$evpath"); my $msg = ""; my $rc = ""; my $rcd = 0; - WebObs::Events::eventsTree(\@tree,"$evbase/$evp"); - grep {s/^\Q$evbase\E\///} @tree; - #dbg# $msg .= "\ntree=\n"; for (@tree) { $msg .= "* $_\n"}; - # delete event and all of its children - $msg .= "deleting $evpath and children\n"; - $rc = WebObs::Events::deleteit($evbase, $evtrash, $evpath); - # if events are gone, remove their reference in Gazette (from @tree) - if ($rc eq 'OK') { - if (isok($GazetteDel)) { - for (@tree) { $rcd += WebObs::Gazette::delEventArticle($object,$_); } - $msg .= " $rcd $__{'article removed from Gazette'}"; - } - htmlMsgOK($msg); - } else { - htmlMsgNotOK("$msg\nError $rc"); - } - exit; + + #dbg# $msg .= "deleting \no=$object\nb=$evbase\nt=$evtrash\ne=$evpath\nE=$evp"; + (my $evp = $evpath) =~ s/\.txt$//; + + # list (@tree) all children of event to delete from its eventTree() + my @tree = ("$evbase/$evpath"); my $msg = ""; my $rc = ""; my $rcd = 0; + WebObs::Events::eventsTree(\@tree,"$evbase/$evp"); + grep {s/^\Q$evbase\E\///} @tree; + + #dbg# $msg .= "\ntree=\n"; for (@tree) { $msg .= "* $_\n"}; + # delete event and all of its children + $msg .= "deleting $evpath and children\n"; + $rc = WebObs::Events::deleteit($evbase, $evtrash, $evpath); + + # if events are gone, remove their reference in Gazette (from @tree) + if ($rc eq 'OK') { + if (isok($GazetteDel)) { + for (@tree) { $rcd += WebObs::Gazette::delEventArticle($object,$_); } + $msg .= " $rcd $__{'article removed from Gazette'}"; + } + htmlMsgOK($msg); + } else { + htmlMsgNotOK("$msg\nError $rc"); + } + exit; } # --------------------------------------------------------------------------------------- @@ -310,19 +321,20 @@ =head1 Markitup customization # (object,event) # if ($action =~ /new/i ) { - if (!$isProject) { - $date = $today->strftime('%Y-%m-%d'); - $time = $today->strftime('%H:%M'); - $date2 = $date; - $time2 = $time; - $pagetitle = "$__{'Create Event'}"; - # fool parents() with a pseudo (xx) evntname if needed - $parents = WebObs::Events::parents($evbase, "$evpath/xx") if ($evpath ne "" && $parents eq ""); - $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; - } else { - $pagetitle = "$__{'Create Project'}"; - } - $meta = "WebObs: created by vedit \n\n" if ($mmd ne 'NO'); # add MMD + if (!$isProject) { + $date = $today->strftime('%Y-%m-%d'); + $time = $today->strftime('%H:%M'); + $date2 = $date; + $time2 = $time; + $pagetitle = "$__{'Create Event'}"; + + # fool parents() with a pseudo (xx) evntname if needed + $parents = WebObs::Events::parents($evbase, "$evpath/xx") if ($evpath ne "" && $parents eq ""); + $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; + } else { + $pagetitle = "$__{'Create Project'}"; + } + $meta = "WebObs: created by vedit \n\n" if ($mmd ne 'NO'); # add MMD } # --------------------------------------------------------------------------------------- @@ -330,29 +342,29 @@ =head1 Markitup customization # (object,event) # if ($action =~ /upd/i ) { - if (!$isProject) { - my ($fname,$ft) = split(/\./,basename($evpath)); - ($name,$date,$time,$version) = WebObs::Events::eventnameSplit(basename($fname)); - $time =~ s/-/:/; - $time =~ s/NA//; - $pagetitle = "$__{'Edit Event'} [$date $time".($tz ne "" ? " ($tz)":"")." $version]"; - $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; - } else { - $pagetitle = "$__{'Edit Project'}"; - } - - # event metadata are stored in the header line of file as pipe-separated fields: - # UID1[+UID2+...]/RUID1[+RUID2+...]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd - # event text content - # ... - @lines = readFile("$evbase/$evpath"); - chomp(@lines); - (my $authors,my $remotes,$titre,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); - @oper = @$authors; - @roper = @$remotes; - shift(@lines); - $contents = join("\n",@lines); - ($contents, $meta) = WebObs::Wiki::stripMDmetadata($contents); + if (!$isProject) { + my ($fname,$ft) = split(/\./,basename($evpath)); + ($name,$date,$time,$version) = WebObs::Events::eventnameSplit(basename($fname)); + $time =~ s/-/:/; + $time =~ s/NA//; + $pagetitle = "$__{'Edit Event'} [$date $time".($tz ne "" ? " ($tz)":"")." $version]"; + $s2g = ( $GazetteWhat eq "ALL" ) ? 1 : 0; + } else { + $pagetitle = "$__{'Edit Project'}"; + } + +# event metadata are stored in the header line of file as pipe-separated fields: +# UID1[+UID2+...]/RUID1[+RUID2+...]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd +# event text content +# ... + @lines = readFile("$evbase/$evpath"); + chomp(@lines); + (my $authors,my $remotes,$titre,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); + @oper = @$authors; + @roper = @$remotes; + shift(@lines); + $contents = join("\n",@lines); + ($contents, $meta) = WebObs::Wiki::stripMDmetadata($contents); } # ---- wodp stuff @@ -367,6 +379,7 @@ =head1 Markitup customization while() { push(@holidaysdef,l2u($_)) if ($_ !~/^(#|$)/); }; close(FILE); chomp(@holidaysdef); my $wodp_holidays = "[".join(',',map { my ($d,$t)=split(/\|/,$_); "{d: \"$d\", t:\"$t\"}" } @holidaysdef)."]"; + # ---- end wodp stuff # ---- html page @@ -386,10 +399,10 @@ =head1 Markitup customization "; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print " @@ -398,7 +411,7 @@ =head1 Markitup customization # javascript for Event form (not Project) # if (!$isProject) { - print ""; -# javascript for Project form -# + + # javascript for Project form + # } else { - print ""; } + # resume common for Project and Event # print " @@ -505,176 +520,180 @@ =head1 Markitup customization print "
        $parents" if ($parents ne ""); print ""; print "
        "; - print ""; - print "\n"; +print "\n\n\n\n"; - print "
        "; - if (!$isProject) { - print " "; - print "".($tz ne "" ? " GMT $tz":"")."

        \n"; - print " "; - print "".($tz ne "" ? " GMT $tz":"")."

        \n"; - } - print "

        \n"; - # only for node's event - if ($object =~ /^.*\..*\..*$/) { - print "

        \n"; - # only if node associated to a proc and calibration file defined - my $clbFile = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; - if (-s $clbFile != 0) { - print ""; - my @carCLB = readCfgFile($clbFile); - # make a list of available channels and label them with last Chan. + Loc. codes - my %chan; - for (@carCLB) { - my (@chpCLB) = split(/\|/,$_); - $chan{$chpCLB[2]} = "$chpCLB[2]: $chpCLB[3] ($chpCLB[6] $chpCLB[19])"; - } - print "

        \n"; - } else { - print "\n"; - } - print "$__{'Sensor/data outcome'}: "; - if (isok($NODES{EVENTNODE_NOTEBOOK})) { - print "$__{'Notebook Nb'}: "; - print "$__{'Forward to notebook'}: "; - } else { - print "\n"; - print "\n"; - } - } - print "        		"; - print "$__{'Author(s)'}:
        "; +if (!$isProject) { + print " "; + print "".($tz ne "" ? " GMT $tz":"")."

        \n"; + print " "; + print "".($tz ne "" ? " GMT $tz":"")."

        \n"; +} +print "

        \n"; + +# only for node's event +if ($object =~ /^.*\..*\..*$/) { + print "

        \n"; + + # only if node associated to a proc and calibration file defined + my $clbFile = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; + if (-s $clbFile != 0) { + print ""; + my @carCLB = readCfgFile($clbFile); + + # make a list of available channels and label them with last Chan. + Loc. codes + my %chan; + for (@carCLB) { + my (@chpCLB) = split(/\|/,$_); + $chan{$chpCLB[2]} = "$chpCLB[2]: $chpCLB[3] ($chpCLB[6] $chpCLB[19])"; + } + print "

        \n"; + } else { + print "\n"; + } + print "$__{'Sensor/data outcome'}: "; + if (isok($NODES{EVENTNODE_NOTEBOOK})) { + print "$__{'Notebook Nb'}: "; + print "$__{'Forward to notebook'}: "; + } else { + print "\n"; + print "\n"; + } +} +print "        		"; +print "$__{'Author(s)'}:
        \n"; - print "        		"; - print "$__{'Remote Operator(s)'}:
        \n"; +print "        		"; +print "$__{'Remote Operator(s)'}:
        "; - print "

        "; - print "

        $__{Notify} (email)"; - # moves event to another node - if (!($action =~ /new/i) && $object =~ /^.*\..*\..*$/ && !$isProject) { - my @allNodes = qx(/bin/ls $NODES{PATH_NODES}); - chomp(@allNodes); - print "\n$__{'Move this event to another node'}: \n"; - } - print "

        \n

        "; - print ""; - if (length($meta) == 0 && $mmd ne 'NO') { - print " MMD'}\" onClick=\"convert2MMD();\" style=\"font-weight:normal\">"; - } - print ""; - print ""; - print ""; - print ""; - print ""; - print ""; - print "\n"; - print "

        "; - print "
        "; +for my $ulogin (@logins) { + my $uid = $USERS{$ulogin}{UID}; + my $sel = ((grep {$_ eq $uid} @roper) ? 'selected':''); + print "\n"; +} +print "
        "; +print "

        "; +print "

        $__{Notify} (email)"; + +# moves event to another node +if (!($action =~ /new/i) && $object =~ /^.*\..*\..*$/ && !$isProject) { + my @allNodes = qx(/bin/ls $NODES{PATH_NODES}); + chomp(@allNodes); + print "\n$__{'Move this event to another node'}: \n"; +} +print "

        \n

        "; +print ""; +if (length($meta) == 0 && $mmd ne 'NO') { + print " MMD'}\" onClick=\"convert2MMD();\" style=\"font-weight:normal\">"; +} +print ""; +print ""; +print ""; +print ""; +print ""; +print ""; +print "\n"; +print "

        "; +print "
        "; print "\n"; print "\n\n\n"; - # ---- helpers fns to process Gazette and return 'save' information to client # sub htmlMsgOK { - my $msg = "$_[0]\n"; - my $rcd = 0; - if ($send2Gazette) { - if (isok($GazetteDel) && $target ne "") { - $rcd = WebObs::Gazette::delEventArticle($object,$target); - $msg .= "\n+ ".basename($target)." $__{'removed from Gazette'}" if ($rcd != 0); - } - $rcd = WebObs::Gazette::setEventArticle($object,$target,$titre,join('+',@oper),$date2."_".$time2); - $msg .= "+ ".basename($target)." $__{'written to Gazette'}\n" if ($rcd =~ /1 row.*/); - } - if ( $notify eq 'OK' ) { - my $t = notify(); - $msg .= "+ Notify ok" if ( $t == 0 ); - $msg .= "+ Notify error $t" if ( $t > 0); - } - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "$msg\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); + my $msg = "$_[0]\n"; + my $rcd = 0; + if ($send2Gazette) { + if (isok($GazetteDel) && $target ne "") { + $rcd = WebObs::Gazette::delEventArticle($object,$target); + $msg .= "\n+ ".basename($target)." $__{'removed from Gazette'}" if ($rcd != 0); + } + $rcd = WebObs::Gazette::setEventArticle($object,$target,$titre,join('+',@oper),$date2."_".$time2); + $msg .= "+ ".basename($target)." $__{'written to Gazette'}\n" if ($rcd =~ /1 row.*/); + } + if ( $notify eq 'OK' ) { + my $t = notify(); + $msg .= "+ Notify ok" if ( $t == 0 ); + $msg .= "+ Notify error $t" if ( $t > 0); + } + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "$msg\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); } sub htmlMsgNotOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "$_[0]\n$__{'FAILED'} !\n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "$_[0]\n$__{'FAILED'} !\n"; } # ---- notify # sub notify { - my $eventname = "eventnode"; - my $senderId = $USERS{$CLIENT}{UID}; - my $names = join(", ",WebObs::Users::userName(@oper))."/".join(", ",WebObs::Users::userName(@roper)); - my $msg = ''; - my $isnode = ($object =~ /^.*\..*\..*$/ ? 1:0); - - $msg .= "$__{'New event'} WebObs-$WEBOBS{WEBOBS_ID}.\n\n"; - if ($isnode) { - my %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); - $msg .= "$__{'Node'}: {$NODEName} $NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})\n"; - $msg .= "$__{'Grids'}: @{$allNodeGrids{$NODEName}}\n"; - } else { - $msg .= "$__{'Grid'}: {$GRIDType.$GRIDName} $GRID{NAME}\n"; - } - $msg .= "$__{'Date'}: $date $time\n"; - $msg .= "$__{'Author(s)'}: $names\n"; - $msg .= "$__{'Title'}: $titre\n\n"; - $msg .= "$contents\n\n" if (isok($WEBOBS{EVENTS_NOTIFY_FULL_MESSAGE})); - if ($isnode) { - $msg .= "$__{'WebObs show node'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$NODES{CGI_SHOW}?node=$GRIDType.$GRIDName.$NODEName"; - } else { - $msg .= "$__{'WebObs show grid'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$GRIDS{CGI_SHOW_GRID}?node=$GRIDType.$GRIDName"; - } - $msg .= "\n"; - - my $args = substr("$eventname|$senderId|$msg",0,4000); # 4000 fits FIFO atomicity (4096) - return ( WebObs::Config::notify($args) ) + my $eventname = "eventnode"; + my $senderId = $USERS{$CLIENT}{UID}; + my $names = join(", ",WebObs::Users::userName(@oper))."/".join(", ",WebObs::Users::userName(@roper)); + my $msg = ''; + my $isnode = ($object =~ /^.*\..*\..*$/ ? 1:0); + + $msg .= "$__{'New event'} WebObs-$WEBOBS{WEBOBS_ID}.\n\n"; + if ($isnode) { + my %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); + $msg .= "$__{'Node'}: {$NODEName} $NODE{ALIAS}: $NODE{NAME} ($NODE{TYPE})\n"; + $msg .= "$__{'Grids'}: @{$allNodeGrids{$NODEName}}\n"; + } else { + $msg .= "$__{'Grid'}: {$GRIDType.$GRIDName} $GRID{NAME}\n"; + } + $msg .= "$__{'Date'}: $date $time\n"; + $msg .= "$__{'Author(s)'}: $names\n"; + $msg .= "$__{'Title'}: $titre\n\n"; + $msg .= "$contents\n\n" if (isok($WEBOBS{EVENTS_NOTIFY_FULL_MESSAGE})); + if ($isnode) { + $msg .= "$__{'WebObs show node'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$NODES{CGI_SHOW}?node=$GRIDType.$GRIDName.$NODEName"; + } else { + $msg .= "$__{'WebObs show grid'}: $WEBOBS{ROOT_URL}?page=/cgi-bin/$GRIDS{CGI_SHOW_GRID}?node=$GRIDType.$GRIDName"; + } + $msg .= "\n"; + + my $args = substr("$eventname|$senderId|$msg",0,4000); # 4000 fits FIFO atomicity (4096) + return ( WebObs::Config::notify($args) ) } =pod diff --git a/CODE/cgi-bin/viewMAN.pl b/CODE/cgi-bin/viewMAN.pl index 9359b23a..b2fd6d2e 100755 --- a/CODE/cgi-bin/viewMAN.pl +++ b/CODE/cgi-bin/viewMAN.pl @@ -27,7 +27,7 @@ =head1 DESCRIPTION # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $man = $cgi->param('man') // ''; @@ -38,18 +38,19 @@ =head1 DESCRIPTION print "\n"; print "webobs manpages"; print ""; + #print ""; print ""; if ( -f $man ) { - mkdir("$WEBOBS{ROOT_DATA}/tmp"); chdir("$WEBOBS{ROOT_DATA}/tmp"); - ##my @h = qx(groff -T html $man); - my @h = qx(man2html $man); - my $groffbody=0; while (! $groffbody) { my $x=shift @h; $groffbody=1 if $x =~ "" } - my $groffbody=0; while (! $groffbody) { my $x=pop @h; $groffbody=1 if $x =~ "" } - for (@h) { print $_; } + mkdir("$WEBOBS{ROOT_DATA}/tmp"); chdir("$WEBOBS{ROOT_DATA}/tmp"); + ##my @h = qx(groff -T html $man); + my @h = qx(man2html $man); + my $groffbody=0; while (! $groffbody) { my $x=shift @h; $groffbody=1 if $x =~ "" } + my $groffbody=0; while (! $groffbody) { my $x=pop @h; $groffbody=1 if $x =~ "" } + for (@h) { print $_; } } else { - print "

        man page $man not found

        "; + print "

        man page $man not found

        "; } print ""; diff --git a/CODE/cgi-bin/viewMFILE.pl b/CODE/cgi-bin/viewMFILE.pl index fc35c2d9..a1fa91b9 100755 --- a/CODE/cgi-bin/viewMFILE.pl +++ b/CODE/cgi-bin/viewMFILE.pl @@ -13,17 +13,17 @@ # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $mfile = $cgi->param('mfile') // ''; print $cgi->header(-type=>'text/plain',-charset=>'utf-8'); if ($mfile) { - my $fname = "$WEBOBS{ROOT_CODE}/matlab/$mfile"; - print STDERR "** mfile = $fname **\n"; - if (-f $fname) { - my @m = qx(sed -n '/^function/,/^[\s\r]*\$/p' $fname); - print join('',@m); - } + my $fname = "$WEBOBS{ROOT_CODE}/matlab/$mfile"; + print STDERR "** mfile = $fname **\n"; + if (-f $fname) { + my @m = qx(sed -n '/^function/,/^[\s\r]*\$/p' $fname); + print join('',@m); + } } diff --git a/CODE/cgi-bin/viewPOD.pl b/CODE/cgi-bin/viewPOD.pl index a8513864..5a4287d2 100755 --- a/CODE/cgi-bin/viewPOD.pl +++ b/CODE/cgi-bin/viewPOD.pl @@ -15,24 +15,25 @@ # --- ends here if the client is not valid if ( !clientIsValid ) { - die "$__{'die_client_not_valid'}"; + die "$__{'die_client_not_valid'}"; } my $pod = $cgi->param('pod') // ''; if ($pod) { my $fname = scan4($pod); - if ($fname) { - #print "Content-type: text/html\n\n"; - print $cgi->header(-charset=>'utf-8'); - mkdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); # just in case - chdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); - pod2html("--quiet","--css=/css/viewpod.css","--infile=$fname"); - } + if ($fname) { + + #print "Content-type: text/html\n\n"; + print $cgi->header(-charset=>'utf-8'); + mkdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); # just in case + chdir("$WEBOBS{PATH_TMP_APACHE}/viewpod"); + pod2html("--quiet","--css=/css/viewpod.css","--infile=$fname"); + } } sub scan4 { - my $what = $_[0]; - my $wd = qx(pwd); chomp($wd); + my $what = $_[0]; + my $wd = qx(pwd); chomp($wd); if ( -e $what ) { return "$wd/$what" } for (@INC) { if( -e "$_/$what.pm" ) { return "$_/$what.pm" } diff --git a/CODE/cgi-bin/vsearch.pl b/CODE/cgi-bin/vsearch.pl index 80ea690a..c0ac1302 100755 --- a/CODE/cgi-bin/vsearch.pl +++ b/CODE/cgi-bin/vsearch.pl @@ -121,37 +121,38 @@ =head1 DESCRIPTION # predefined lists my @catlist = split(/,/,$NODES{EVENT_SEARCH_CATEGORY_LIST}); if ($#catlist < 0) { - @catlist = split(/,/,"grid,alias,name,feature,author,remote,startdate,title,comment,notebook,outcome"); + @catlist = split(/,/,"grid,alias,name,feature,author,remote,startdate,title,comment,notebook,outcome"); } my %category = ( - "grid" => $__{'Grid Name'}, - "alias" => $__{'Node Alias'}, - "name" => $__{'Node Name'}, - "feature" => $__{'Node Feature'}, - "author" => $__{'Author'}, - "remote" => $__{'Remote Operator'}, - "startdate" => $__{'Start Date'}, - "enddate" => $__{'End Date'}, - "title" => $__{'Event Title'}, - "comment" => $__{'Comment/Observation'}, - "notebook" => $__{'Notebook #'}, - "outcome" => $__{'Sensor Outcome'}, -); + "grid" => $__{'Grid Name'}, + "alias" => $__{'Node Alias'}, + "name" => $__{'Node Name'}, + "feature" => $__{'Node Feature'}, + "author" => $__{'Author'}, + "remote" => $__{'Remote Operator'}, + "startdate" => $__{'Start Date'}, + "enddate" => $__{'End Date'}, + "title" => $__{'Event Title'}, + "comment" => $__{'Comment/Observation'}, + "notebook" => $__{'Notebook #'}, + "outcome" => $__{'Sensor Outcome'}, + ); + # removes category notebook if option is not set delete $category{"notebook"} if (!isok($NODES{EVENTNODE_NOTEBOOK})); my %catdisplay; foreach my $n (0..$#catlist) { - if (defined $category{$catlist[$n]}) { - $catdisplay{sprintf("%02d|%s", $n, $catlist[$n])} = $category{$catlist[$n]}; - } + if (defined $category{$catlist[$n]}) { + $catdisplay{sprintf("%02d|%s", $n, $catlist[$n])} = $category{$catlist[$n]}; + } } my %sortlist = ( - "startdateinc" => $__{'Start Date - increasing'}, - "startdatedec" => $__{'Start Date - decreasing'}, -); + "startdateinc" => $__{'Start Date - increasing'}, + "startdatedec" => $__{'Start Date - decreasing'}, + ); my @maxlist = ("15","50","100"); @maxlist = split(/,/,$NODES{EVENT_SEARCH_MAXDISPLAY_LIST}) if ($NODES{EVENT_SEARCH_MAXDISPLAY_LIST} ne ""); @@ -171,31 +172,33 @@ =head1 DESCRIPTION my ($evfname,$node,$date1,$time1,$version); if ($str ne "") { - @events1 = searchEvents($target,$str,$in); + @events1 = searchEvents($target,$str,$in); } if ($str2 ne "") { - @events2 = searchEvents($target,$str2,$in2); - if ($lop eq "OR") { - # simply appends the two requests - push(@events1,@events2); - } + @events2 = searchEvents($target,$str2,$in2); + if ($lop eq "OR") { + + # simply appends the two requests + push(@events1,@events2); + } } # ---- must remove NODES that are not associated to readable GRIDS by user my %NG = listNodeGrids; foreach(@events1) { - $evfname = $_; - my $fname = basename($evfname); - ($node,$date1,$time1,$version) = split(/_/,basename(split(/\./,$fname))); - my $ok = 0; - foreach(@{$NG{$node}}) { - my ($GRIDType,$GRIDName) = split(/\./,$_); - $ok = 1 if (clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); - } - # avoid duplicates and keeps only events common to the 2 requests in case of AND logical operator - if (! grep(/$fname/,@events) && ($lop ne "AND" || $str2 eq "" || grep(/$fname/,@events2))) { - push(@events,$evfname); - } + $evfname = $_; + my $fname = basename($evfname); + ($node,$date1,$time1,$version) = split(/_/,basename(split(/\./,$fname))); + my $ok = 0; + foreach(@{$NG{$node}}) { + my ($GRIDType,$GRIDName) = split(/\./,$_); + $ok = 1 if (clientHasRead(type=>"auth".lc($GRIDType)."s",name=>"$GRIDName")); + } + +# avoid duplicates and keeps only events common to the 2 requests in case of AND logical operator + if (! grep(/$fname/,@events) && ($lop ne "AND" || $str2 eq "" || grep(/$fname/,@events2))) { + push(@events,$evfname); + } } # ---- sort events @@ -236,59 +239,59 @@ =head1 DESCRIPTION # form part print "
        "; - print ""; - print "\n"; - print "\n"; - print "\n\n"; - print "
        "; - print "$__{'Search for:'}   "; - print "$__{'in:'}
        \n"; - print "  \n"; - print "  "; - print "$__{'in:'}         		"; - print "$__{'sorted by:'}
        \n"; - print "$__{'Show:'} $__{'grids'}"; - print "   $__{'node\'s name'}"; - print "        		"; - print "$__{'max diplayed:'} "; - if ($from > 1) { - my $prev = max(1,$from - $max); - my $qr = $query; - $qr =~ s/from=[0-9]*/from=$prev/; - print ""; - } - print "$from - ".($from + $maxdisp - 1)." / ".($#events + 1).""; - if ($from + $maxdisp - 2 < $#events) { - my $next = min($#events + 1,$from + $max); - my $qr = $query; - $qr =~ s/from=[0-9]*/from=$next/; - print ""; - } - print " "; - print "
        \n"; - print "\n"; +print ""; +print "\n"; +print "\n"; +print "\n\n"; +print "
        "; +print "$__{'Search for:'}   "; +print "$__{'in:'}
        \n"; +print "  \n"; +print "  "; +print "$__{'in:'}         		"; +print "$__{'sorted by:'}
        \n"; +print "$__{'Show:'} $__{'grids'}"; +print "   $__{'node\'s name'}"; +print "        		"; +print "$__{'max diplayed:'} "; +if ($from > 1) { + my $prev = max(1,$from - $max); + my $qr = $query; + $qr =~ s/from=[0-9]*/from=$prev/; + print ""; +} +print "$from - ".($from + $maxdisp - 1)." / ".($#events + 1).""; +if ($from + $maxdisp - 2 < $#events) { + my $next = min($#events + 1,$from + $max); + my $qr = $query; + $qr =~ s/from=[0-9]*/from=$next/; + print ""; +} +print " "; +print "
        \n"; +print "\n"; print "
        \n"; print "
        $__{'Searching for the data... please wait'}.
        "; @@ -296,169 +299,171 @@ =head1 DESCRIPTION # builds the html string push(@html,""); foreach (sort(keys(%catdisplay))) { - my ($n,$k) = split(/\|/,$_); - push(@html,"") if ($k ne "grid" || $showg); + my ($n,$k) = split(/\|/,$_); + push(@html,"") if ($k ne "grid" || $showg); } push(@html,"\n"); # result part : will read and display only the needed events my @finalevents = @events[$from-1 .. ($from + $maxdisp)-2]; + #print "

        ".join("
        ",@finalevents)."

        "; if ($#finalevents < 0 || $finalevents[0] eq "") { - @finalevents = (); - push(@html,"\n"); + @finalevents = (); + push(@html,"\n"); } my %G = WebObs::Grids::listNameGrids; my $n = 0; foreach(@finalevents) { - $evfname = $_; - my $evrel = $evfname; - $evrel =~ s/.*$NODES{SPATH_INTERVENTIONS}\///g; - my ($fname,$fext) = split(/\./,basename($evfname)); - ($node,$date1,$time1,$version) = split(/_/,basename($fname)); - $time1 =~ s/-/:/; - $time1 =~ s/NA//; - - # checks attached photos - my @attach; - my $dp = $evfname; - $dp =~ s/\.txt/\/PHOTOS/g; - if (-d $dp) { - opendir (my $dh, $dp); - @attach = grep {!/^\./} readdir $dh; - closedir $dh; - } - - @lines = readFile("$evfname"); - my ($aa,$ar,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); - my @authors = WebObs::Users::userName(@$aa); - my @remotes = WebObs::Users::userName(@$ar); - shift(@lines); # shift header line - my $comment = wiki2html(join("",@lines)); - shift(@lines) if (grep($lines[0],'^WebObs:')); # shift Wiki/MMD metadata - chomp(@lines); - my $commentcsv = join(" • ",@lines); - my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); - my @nodes; - foreach(@{$NG{$node}}) { - push(@nodes,"\"$__{'Edit...'}\""); - } - - my $tds = " class=\"td$n\""; - - # highlights results - my $hauthors = join("
        ",@authors); - my $hremotes = join("
        ",@remotes); - my $hfeature = $feature; - my $hdate1 = $date1; - my $hdate2 = $date2; - my $htitle = $title; - if ($str ne "") { - $hauthors =~ s/($str)/\1<\/SPAN>/ig if ($in eq "author"); - $hremotes =~ s/($str)/\1<\/SPAN>/ig if ($in eq "remote"); - $hfeature =~ s/($str)/\1<\/SPAN>/ig if ($in eq "feature"); - $hdate1 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "startdate"); - $hdate2 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "enddate"); - $htitle =~ s/($str)/\1<\/SPAN>/ig if ($in eq "title"); - $comment =~ s/($str)/\1<\/SPAN>/ig if ($in eq "comment"); - } - if ($str2 ne "") { - $hauthors =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "author"); - $hremotes =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "remote"); - $hfeature =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "feature"); - $hdate1 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "startdate"); - $hdate2 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "enddate"); - $htitle =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "title"); - $comment =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "comment"); - } - - push(@html,""); - #[FB]: possibility to display all edit links (procs and views) - #print ""; - push(@html,""); - - my @csvf; - foreach (sort(keys(%catdisplay))) { - my ($n,$k) = split(/\|/,$_); - switch ($k) { - case "grid" { - my @grids; - my @gridscsv; - foreach (@{$NG{$node}}) { - push(@grids,"$G{$_}"); - push(@gridscsv,$G{$_}); - } - push(@html,"") if ($showg); - push(@csvf,"\"".join(",",@gridscsv)."\""); - } - case "alias" { - my @alias; - my @aliascsv; - foreach (@{$NG{$node}}) { - push(@alias,"$N{ALIAS}".($shown ? " $N{NAME}":"").""); - push(@aliascsv,$N{ALIAS}); - } - @alias = ($alias[0]) if (!$showg); - push(@html,""); - push(@csvf,"\"".join(",",@aliascsv)."\""); - } - case "name" { - my @name; - my @namecsv; - foreach (@{$NG{$node}}) { - push(@name,"$N{NAME}"); - $N{NAME} =~ s/\"//g; - push(@namecsv,$N{NAME}); - } - @name = ($name[0]) if (!$showg); - push(@html,""); - push(@csvf,"\"".join(",",@namecsv)."\""); - } - case "feature" { - push(@html,""); - push(@csvf,"\"$feature\""); - } - case "author" { - push(@html,""); - push(@csvf,"\"".join(",",@authors)."\""); - } - case "remote" { - push(@html,""); - push(@csvf,"\"".join(",",@remotes)."\""); - } - case "startdate" { - push(@html,""); - push(@csvf,"\"$date1 $time1\""); - } - case "enddate" { - push(@html,""); - push(@csvf,"\"$date2 $time2\""); - } - case "title" { - push(@html,""); - push(@csvf,"\"$title\""); - } - case "comment" { - push(@html,""); - push(@csvf,"\"$commentcsv\""); - } - case "notebook" { - push(@html,"") if (isok($NODES{EVENTNODE_NOTEBOOK})); - push(@csvf,"\"$notebook\""); - } - case "outcome" { - push(@html,""); - push(@csvf,"\"$outcome\""); - } - } - } - push(@csv,join(";",@csvf)); - push(@html,""); - push(@html,"\n"); - $n = ($n + 1) % 2; + $evfname = $_; + my $evrel = $evfname; + $evrel =~ s/.*$NODES{SPATH_INTERVENTIONS}\///g; + my ($fname,$fext) = split(/\./,basename($evfname)); + ($node,$date1,$time1,$version) = split(/_/,basename($fname)); + $time1 =~ s/-/:/; + $time1 =~ s/NA//; + + # checks attached photos + my @attach; + my $dp = $evfname; + $dp =~ s/\.txt/\/PHOTOS/g; + if (-d $dp) { + opendir (my $dh, $dp); + @attach = grep {!/^\./} readdir $dh; + closedir $dh; + } + + @lines = readFile("$evfname"); + my ($aa,$ar,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); + my @authors = WebObs::Users::userName(@$aa); + my @remotes = WebObs::Users::userName(@$ar); + shift(@lines); # shift header line + my $comment = wiki2html(join("",@lines)); + shift(@lines) if (grep($lines[0],'^WebObs:')); # shift Wiki/MMD metadata + chomp(@lines); + my $commentcsv = join(" • ",@lines); + my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); + my @nodes; + foreach(@{$NG{$node}}) { + push(@nodes,"\"$__{'Edit...'}\""); + } + + my $tds = " class=\"td$n\""; + + # highlights results + my $hauthors = join("
        ",@authors); + my $hremotes = join("
        ",@remotes); + my $hfeature = $feature; + my $hdate1 = $date1; + my $hdate2 = $date2; + my $htitle = $title; + if ($str ne "") { + $hauthors =~ s/($str)/\1<\/SPAN>/ig if ($in eq "author"); + $hremotes =~ s/($str)/\1<\/SPAN>/ig if ($in eq "remote"); + $hfeature =~ s/($str)/\1<\/SPAN>/ig if ($in eq "feature"); + $hdate1 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "startdate"); + $hdate2 =~ s/($str)/\1<\/SPAN>/ig if ($in eq "enddate"); + $htitle =~ s/($str)/\1<\/SPAN>/ig if ($in eq "title"); + $comment =~ s/($str)/\1<\/SPAN>/ig if ($in eq "comment"); + } + if ($str2 ne "") { + $hauthors =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "author"); + $hremotes =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "remote"); + $hfeature =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "feature"); + $hdate1 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "startdate"); + $hdate2 =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "enddate"); + $htitle =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "title"); + $comment =~ s/($str2)/\1<\/SPAN>/ig if ($in2 eq "comment"); + } + + push(@html,""); + + #[FB]: possibility to display all edit links (procs and views) + #print ""; + push(@html,""); + + my @csvf; + foreach (sort(keys(%catdisplay))) { + my ($n,$k) = split(/\|/,$_); + switch ($k) { + case "grid" { + my @grids; + my @gridscsv; + foreach (@{$NG{$node}}) { + push(@grids,"$G{$_}"); + push(@gridscsv,$G{$_}); + } + push(@html,"") if ($showg); + push(@csvf,"\"".join(",",@gridscsv)."\""); + } + case "alias" { + my @alias; + my @aliascsv; + foreach (@{$NG{$node}}) { + push(@alias,"$N{ALIAS}".($shown ? " $N{NAME}":"").""); + push(@aliascsv,$N{ALIAS}); + } + @alias = ($alias[0]) if (!$showg); + push(@html,""); + push(@csvf,"\"".join(",",@aliascsv)."\""); + } + case "name" { + my @name; + my @namecsv; + foreach (@{$NG{$node}}) { + push(@name,"$N{NAME}"); + $N{NAME} =~ s/\"//g; + push(@namecsv,$N{NAME}); + } + @name = ($name[0]) if (!$showg); + push(@html,""); + push(@csvf,"\"".join(",",@namecsv)."\""); + } + case "feature" { + push(@html,""); + push(@csvf,"\"$feature\""); + } + case "author" { + push(@html,""); + push(@csvf,"\"".join(",",@authors)."\""); + } + case "remote" { + push(@html,""); + push(@csvf,"\"".join(",",@remotes)."\""); + } + case "startdate" { + push(@html,""); + push(@csvf,"\"$date1 $time1\""); + } + case "enddate" { + push(@html,""); + push(@csvf,"\"$date2 $time2\""); + } + case "title" { + push(@html,""); + push(@csvf,"\"$title\""); + } + case "comment" { + push(@html,""); + push(@csvf,"\"$commentcsv\""); + } + case "notebook" { + push(@html,"") if (isok($NODES{EVENTNODE_NOTEBOOK})); + push(@csvf,"\"$notebook\""); + } + case "outcome" { + push(@html,""); + push(@csvf,"\"$outcome\""); + } + } + } + push(@csv,join(";",@csvf)); + push(@html,""); + push(@html,"\n"); + $n = ($n + 1) % 2; } push(@html,"
        $catdisplay{$_}$catdisplay{$_}

        No match.

        No match.

        ".join("
        ",@nodes)."        		".join("
        ",$nodes[0])."        		".join("
        ",@grids)."        		".join(",",@alias)."".join(",",@name)."$hfeature$hauthors$hremotes$hdate1 $time1$hdate2 $time2$htitle$comment$notebook".($outcome > 0 ? "":"")."".($#attach > 0 ? "":"")."
        ".join("
        ",@nodes)."        		".join("
        ",$nodes[0])."        		".join("
        ",@grids)."        		".join(",",@alias)."".join(",",@name)."$hfeature$hauthors$hremotes$hdate1 $time1$hdate2 $time2$htitle$comment$notebook".($outcome > 0 ? "":"")."".($#attach > 0 ? "":"")."
        \n"); @@ -487,112 +492,122 @@ =head1 DESCRIPTION ENDBOTOFPAGE - ############################################################################### # this function uses external commands (find, grep, awk ...) to get the list of # requested events following the different search criteria sub searchEvents { - my ($target,$str,$in) = @_; - my $struc = uc($str); - my $not = my $notlike = ''; - if ($struc =~ /^!/) { - $not = '!'; - $notlike = 'not'; - $struc = substr($struc,1); # removes the first character - } - my ($GRIDType,$GRIDName,$NodeID) = split(/\./,$target); - - my @evt; - my $cmd; - - # default command is all events... - my $node = ($NodeID eq "" ? "*":$NodeID); - my $base = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a ! -name \"*_Projet.txt\" \\)"; - - # alias will look for $str in the node's ALIAS and NAME configuration - if ($in eq "alias") { - $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^ALIAS\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; - } - if ($in eq "name") { - $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^NAME\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; - } - # grid will look for $str in the grid's NAME configuration - if ($in eq "grid") { - # search for grid names - my @GRIDlist = qx(find $WEBOBS{ROOT_CONF}/PROCS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1); - push(@GRIDlist,qx(find $WEBOBS{ROOT_CONF}/VIEWS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1)); - chomp(@GRIDlist); - if ($#GRIDlist < 0) { - $cmd = ""; - } else { - $cmd = "find -L $WEBOBS{PATH_GRIDS2NODES} \\( ! -name \"*_Projet.txt\" -a -name \"*.txt\" -a -path \"$node/$NODES{SPATH_INTERVENTIONS}*\" -a \\( -path \"*".join('*" -o -path "*',@GRIDlist)."*\" \\) \\)"; - } - } - # startdate will look for $str in event's start date - if ($in eq "startdate") { - my $s = $struc; - $s =~ s/:/-/; - $s =~ s/ /_/; - $cmd = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a $not -name \"*$s*\" -a ! -name \"*_Projet.txt\" \\)"; - } - # author and remote will look for $str in author's full names - if ($in eq "author" || $in eq "remote") { - # must replaces author names by their UID - my @UIDlist = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "select UID from users where FULLNAME $notlike like '%$str%'"); - chomp(@UIDlist); - if ($#UIDlist < 0) { - $cmd = ""; - } else { - my $f = "1"; - $f = "2" if ($in eq "remote"); - $cmd = $base."|xargs awk -F '[|/]' 'FNR>1 {nextfile} \$$f ~ /".join('|',@UIDlist)."/ { print FILENAME ; nextfile }'"; - } - } - # title will look for $str in event's title (2nd field in header line) - if ($in eq "title") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$2) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # enddate will look for $str in event's end date (3rd field in header line) - if ($in eq "enddate") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$3) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # feature will look for $str in event's feature (4th field in header line) - if ($in eq "feature") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$4) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # outcome will look for $str in event's outcome (5th field in header line) - if ($in eq "outcome") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$6) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # notebook will look for $str in event's outcome (6th field in header line) - if ($in eq "notebook") { - $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$7) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - # comment will look for $str in event's full text (except header line) - if ($in eq "comment") { - $cmd = $base."| xargs awk 'BEGIN{ RS = \"\" ; FS = \"\\n\" } FNR>1 && toupper(\$0) $not~ /$struc/ { print FILENAME ; nextfile }'"; - } - - @evt = qx($cmd); - chomp(@evt); - return @evt; + my ($target,$str,$in) = @_; + my $struc = uc($str); + my $not = my $notlike = ''; + if ($struc =~ /^!/) { + $not = '!'; + $notlike = 'not'; + $struc = substr($struc,1); # removes the first character + } + my ($GRIDType,$GRIDName,$NodeID) = split(/\./,$target); + + my @evt; + my $cmd; + + # default command is all events... + my $node = ($NodeID eq "" ? "*":$NodeID); + my $base = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a ! -name \"*_Projet.txt\" \\)"; + + # alias will look for $str in the node's ALIAS and NAME configuration + if ($in eq "alias") { + $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^ALIAS\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; + } + if ($in eq "name") { + $cmd = "find $WEBOBS{PATH_NODES}/$node -name \"*.cnf\" | xargs awk -F'|' '\$1 ~ /^NAME\$/ && toupper(\$2) $not~ /$struc/ { print FILENAME }' | awk -F'/[^/]*\$' '{ print \$1 \"/$NODES{SPATH_INTERVENTIONS}\" }' | xargs find | grep \".txt\$\" | grep -v \"_Projet.txt\""; + } + + # grid will look for $str in the grid's NAME configuration + if ($in eq "grid") { + + # search for grid names + my @GRIDlist = qx(find $WEBOBS{ROOT_CONF}/PROCS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1); + push(@GRIDlist,qx(find $WEBOBS{ROOT_CONF}/VIEWS/* -name "*.conf" | xargs awk -F "|" '\$1 == "NAME" && toupper(\$2) $not~ /$struc/ { print FILENAME }' | LC_ALL=C sed -e 's|.*CONF/||g;s|PROCS/|PROC.|g;s|VIEWS/|VIEW.|g;s|/.*||g' 2>&1)); + chomp(@GRIDlist); + if ($#GRIDlist < 0) { + $cmd = ""; + } else { + $cmd = "find -L $WEBOBS{PATH_GRIDS2NODES} \\( ! -name \"*_Projet.txt\" -a -name \"*.txt\" -a -path \"$node/$NODES{SPATH_INTERVENTIONS}*\" -a \\( -path \"*".join('*" -o -path "*',@GRIDlist)."*\" \\) \\)"; + } + } + + # startdate will look for $str in event's start date + if ($in eq "startdate") { + my $s = $struc; + $s =~ s/:/-/; + $s =~ s/ /_/; + $cmd = "find $WEBOBS{PATH_NODES}/$node/$NODES{SPATH_INTERVENTIONS} \\( -name \"*.txt\" -a $not -name \"*$s*\" -a ! -name \"*_Projet.txt\" \\)"; + } + + # author and remote will look for $str in author's full names + if ($in eq "author" || $in eq "remote") { + + # must replaces author names by their UID + my @UIDlist = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "select UID from users where FULLNAME $notlike like '%$str%'"); + chomp(@UIDlist); + if ($#UIDlist < 0) { + $cmd = ""; + } else { + my $f = "1"; + $f = "2" if ($in eq "remote"); + $cmd = $base."|xargs awk -F '[|/]' 'FNR>1 {nextfile} \$$f ~ /".join('|',@UIDlist)."/ { print FILENAME ; nextfile }'"; + } + } + + # title will look for $str in event's title (2nd field in header line) + if ($in eq "title") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$2) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # enddate will look for $str in event's end date (3rd field in header line) + if ($in eq "enddate") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$3) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # feature will look for $str in event's feature (4th field in header line) + if ($in eq "feature") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$4) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # outcome will look for $str in event's outcome (5th field in header line) + if ($in eq "outcome") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$6) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # notebook will look for $str in event's outcome (6th field in header line) + if ($in eq "notebook") { + $cmd = $base."| xargs awk -F \"|\" 'FNR>1 {nextfile} toupper(\$7) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + # comment will look for $str in event's full text (except header line) + if ($in eq "comment") { + $cmd = $base."| xargs awk 'BEGIN{ RS = \"\" ; FS = \"\\n\" } FNR>1 && toupper(\$0) $not~ /$struc/ { print FILENAME ; nextfile }'"; + } + + @evt = qx($cmd); + chomp(@evt); + return @evt; } - sub sort_by_date ($$) { - my ($c,$d) = @_; - # keeps only the date info (removes path and nodeid) - $c = basename($c); - $c =~ s/[^_]*//; - $d = basename($d); - $d =~ s/[^_]*//; - # replaces undefined time by 00:00 - $c =~ s/_NA/_00:00/; - $d =~ s/_NA/00:00/; - return $d cmp $c; + my ($c,$d) = @_; + + # keeps only the date info (removes path and nodeid) + $c = basename($c); + $c =~ s/[^_]*//; + $d = basename($d); + $d =~ s/[^_]*//; + + # replaces undefined time by 00:00 + $c =~ s/_NA/_00:00/; + $d =~ s/_NA/00:00/; + return $d cmp $c; } - =pod =head1 AUTHOR(S) diff --git a/CODE/cgi-bin/wdir.pl b/CODE/cgi-bin/wdir.pl index f5c68990..89f44e56 100755 --- a/CODE/cgi-bin/wdir.pl +++ b/CODE/cgi-bin/wdir.pl @@ -62,16 +62,17 @@ =head1 Query string parameters # del file first if requested if ($del ne "" && -e $absdir.$del) { - if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { - unlink $absdir.$del if (-f $absdir.$del); - remove_tree $absdir.$del if (-d $absdir.$del); - } + if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { + unlink $absdir.$del if (-f $absdir.$del); + remove_tree $absdir.$del if (-d $absdir.$del); + } } + # then handle subdir creation if ($sdir ne "" && ! -e $absdir.$sdir) { - if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { - make_path($absdir.$sdir); - } + if (WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { + make_path($absdir.$sdir); + } } # ---- 'dir' directory list ---------------- --------------------------------- @@ -82,7 +83,7 @@ =head1 Query string parameters @files = sort {$a cmp $b} @files; if ( WebObs::Users::clientHasEdit(type=>'authwikis',name=>'*') ) { - $editALL = 1; + $editALL = 1; } # ---- create the HTML now ! ------------------------------------------------- @@ -104,54 +105,58 @@ =head1 Query string parameters print "
        "; print "
        "; print ""; + # new file + new subdir row if ( ($editALL == 1) || WebObs::Users::clientHasAdm(type=>'authwikis',name=>$dir) ) { - print ""; - print ""; - print ""; - print ""; - print ""; + print ""; + print ""; + print ""; + print ""; + print ""; } + # updir rows first if ($updir ne "") { - print ""; - if (-d "$abs/$updir" && WebObs::Users::clientHasRead(type=>'authwikis',name=>$updir) ) { - print ""; - } - print ""; + print ""; + if (-d "$abs/$updir" && WebObs::Users::clientHasRead(type=>'authwikis',name=>$updir) ) { + print ""; + } + print ""; } + # subdirs rows for $aFile (@files) { - print ""; - if (-d "$absdir/$aFile") { - if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { - print ""; - print ""; - print ""; - } - } - print ""; + print ""; + if (-d "$absdir/$aFile") { + if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { + print ""; + print ""; + print ""; + } + } + print ""; } + # files rows for $aFile (@files) { - print ""; - if (-f "$absdir/$aFile") { - my $title = qx(head -n1 $absdir/$aFile); - if (grep(/^TITRE.*\|/,$title)) { $title =~ s/^TITRE.*\|//; $title="($title)"} else { $title = ""; } - if ( ($editALL == 1) || WebObs::Users::clientHasEdit(type=>'authwikis',name=>$aFile) ) { - print ""; - print ""; - } - if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { - print ""; - } - } - print ""; + print ""; + if (-f "$absdir/$aFile") { + my $title = qx(head -n1 $absdir/$aFile); + if (grep(/^TITRE.*\|/,$title)) { $title =~ s/^TITRE.*\|//; $title="($title)"} else { $title = ""; } + if ( ($editALL == 1) || WebObs::Users::clientHasEdit(type=>'authwikis',name=>$aFile) ) { + print ""; + print ""; + } + if ( WebObs::Users::clientHasRead(type=>'authwikis',name=>$aFile) ) { + print ""; + } + } + print ""; } print "
        "; - print ""; - print ""; - print ""; - print ""; - print "
        "; + print ""; + print ""; + print ""; + print ""; + print "
        ..
        ..
        $aFile/
        $aFile/
        $aFile $title
        $aFile $title
        "; print "
        "; diff --git a/CODE/cgi-bin/wedit.pl b/CODE/cgi-bin/wedit.pl index 1aee77f8..993a2f26 100755 --- a/CODE/cgi-bin/wedit.pl +++ b/CODE/cgi-bin/wedit.pl @@ -108,52 +108,53 @@ =head1 Markitup customization # ---- new file (create) initialization # if ($file ne "") { - $absfile = "$WEBOBS{PATH_DATA_WEB}/$file"; - #?# $absfile =~ s/^\.\.?\///; - $editOK = clientHasEdit(type=>"authwikis",name=>$file); - $admOK = clientHasAdm(type=>"authwikis",name=>$file); - unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } - if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } - if ( (!$editOK) && (!-e $absfile) ) { die "$file $__{'not found'} or $__{'not authorized'}" } + $absfile = "$WEBOBS{PATH_DATA_WEB}/$file"; + + #?# $absfile =~ s/^\.\.?\///; + $editOK = clientHasEdit(type=>"authwikis",name=>$file); + $admOK = clientHasAdm(type=>"authwikis",name=>$file); + unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } + if ( (!-e $absfile) && $admOK ) { qx(echo "$MDMeta\n\n" > $absfile) } + if ( (!$editOK) && (!-e $absfile) ) { die "$file $__{'not found'} or $__{'not authorized'}" } } else { die "$__{'No filename specified'}" } # ---- action is 'save' # if ($action eq 'save') { - if ($TS0 != (stat("$absfile"))[9]) { - htmlMsgNotOK("$file has been modified while you were editing !"); - exit; - } - if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $file..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $absfile $absfile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - if ($conv eq "1") { - $txt = WebObs::Wiki::wiki2MMD($txt); - $txt = "WebObs: converted with wiki2MMD\n\n$txt"; - } - if ($html == 1) { - @lignes = ("TITRE_HTML|$titre\n"); - } elsif ($titre ne "") { - @lignes = ("TITRE|$titre\n"); - } - $txt = "$metain$txt"; - $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lignes,$txt); - print FILE @lignes ; - close(FILE); - htmlMsgOK($file); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $file"); - } - } else { htmlMsgNotOK("$me opening $file - $!") } - exit; + if ($TS0 != (stat("$absfile"))[9]) { + htmlMsgNotOK("$file has been modified while you were editing !"); + exit; + } + if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $file..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $absfile $absfile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + if ($conv eq "1") { + $txt = WebObs::Wiki::wiki2MMD($txt); + $txt = "WebObs: converted with wiki2MMD\n\n$txt"; + } + if ($html == 1) { + @lignes = ("TITRE_HTML|$titre\n"); + } elsif ($titre ne "") { + @lignes = ("TITRE|$titre\n"); + } + $txt = "$metain$txt"; + $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lignes,$txt); + print FILE @lignes ; + close(FILE); + htmlMsgOK($file); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $file"); + } + } else { htmlMsgNotOK("$me opening $file - $!") } + exit; } # ---- action is 'edit' (default) @@ -162,17 +163,19 @@ =head1 Markitup customization @lignes = readFile($absfile); $TS0 = (stat($absfile))[9] ; chomp(@lignes); + # strip off and remember the first line's optional tags TITLE* (my $x, my $y) = split(/\|/, $lignes[0]); if ( $x eq "TITRE_HTML" ) { - $titre = $y; - shift(@lignes); - $legacyhtml = 1; + $titre = $y; + shift(@lignes); + $legacyhtml = 1; } if ( $x eq "TITRE" ) { - $titre = $y; - shift(@lignes); + $titre = $y; + shift(@lignes); } + # file contents as a string and determine markup type (WO or MMD) $txt = join("\n",@lignes); ($txt, my $meta) = WebObs::Wiki::stripMDmetadata($txt); @@ -211,10 +214,10 @@ =head1 Markitup customization "; if (length($meta) > 0) { - print " + print " "; } else { - print " + print " "; } print ""; -print ""; +print ""; print "$titre @@ -108,19 +108,18 @@ =head1 Query string parameters
        $editor
        "; -print "
        "; +print "
        "; if ($titre ne "") { - print "

        $titre

        "; + print "

        $titre

        "; } if ($html) { - print @lines; + print @lines; } else { - print WebObs::Wiki::wiki2html(join("",@lines)); + print WebObs::Wiki::wiki2html(join("",@lines)); } print "
        \n"; print ""; - __END__ =pod diff --git a/CODE/cgi-bin/xedit.pl b/CODE/cgi-bin/xedit.pl index 71b710fd..516e42a4 100755 --- a/CODE/cgi-bin/xedit.pl +++ b/CODE/cgi-bin/xedit.pl @@ -104,7 +104,7 @@ =head1 CONFIGURATION VARIABLES # ---- see what file has to be edited, and corresponding authorization for client # -my $me = $ENV{SCRIPT_NAME}; +my $me = $ENV{SCRIPT_NAME}; my $QryParm = $cgi->Vars; my $fs = $QryParm->{'fs'} // ""; my $action = $QryParm->{'action'} // "edit"; @@ -118,59 +118,59 @@ =head1 CONFIGURATION VARIABLES my $fsmsg = ""; if ($fs ne "") { - if ($fs =~ /^CONF\//) { - ($absfile = $fs) =~ s/^CONF\//$WEBOBS{ROOT_CONF}\//; - } elsif ($fs =~ /^DATA\//) { - ($absfile = $fs) =~ s/^DATA\//$WEBOBS{ROOT_DATA}\//; - } else { - my @u = split(/[()]/, $fs); - if (scalar(@u) == 2) { - my %l = readCfg($WEBOBS{$u[0]}); - $absfile = $l{$u[1]}; - } else { $absfile = "$WEBOBS{$fs}"; } - } - if (($relfile = $absfile) =~ s/^$WEBOBS{ROOT_CONF}\/+|^$WEBOBS{ROOT_DATA}\/+//) { - $readOK = clientHasRead(type=>"authmisc",name=>"$relfile"); - if ( $readOK ) { - if ( !$fbrowse ) { - $editOK = clientHasEdit(type=>"authmisc",name=>"$relfile"); - $admOK = clientHasAdm(type=>"authmisc",name=>"$relfile"); - unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } - if ( (!-e $absfile) && $admOK ) { qx(/bin/touch $absfile); $fsmsg="New file" } + if ($fs =~ /^CONF\//) { + ($absfile = $fs) =~ s/^CONF\//$WEBOBS{ROOT_CONF}\//; + } elsif ($fs =~ /^DATA\//) { + ($absfile = $fs) =~ s/^DATA\//$WEBOBS{ROOT_DATA}\//; + } else { + my @u = split(/[()]/, $fs); + if (scalar(@u) == 2) { + my %l = readCfg($WEBOBS{$u[0]}); + $absfile = $l{$u[1]}; + } else { $absfile = "$WEBOBS{$fs}"; } + } + if (($relfile = $absfile) =~ s/^$WEBOBS{ROOT_CONF}\/+|^$WEBOBS{ROOT_DATA}\/+//) { + $readOK = clientHasRead(type=>"authmisc",name=>"$relfile"); + if ( $readOK ) { + if ( !$fbrowse ) { + $editOK = clientHasEdit(type=>"authmisc",name=>"$relfile"); + $admOK = clientHasAdm(type=>"authmisc",name=>"$relfile"); + unless (-e dirname($absfile) || !$admOK) { mkdir dirname($absfile) } + if ( (!-e $absfile) && $admOK ) { qx(/bin/touch $absfile); $fsmsg="New file" } else { $fsmsg="$relfile"; } - if ( (!$editOK) && (!-e $absfile) ) { die "$relfile $__{'not found'} or $__{'not authorized'}" } - } - } else { die "$relfile $__{'not authorized'}" } - } else { die "$relfile $__{'Not a CONF/ nor DATA/ file'}" } + if ( (!$editOK) && (!-e $absfile) ) { die "$relfile $__{'not found'} or $__{'not authorized'}" } + } + } else { die "$relfile $__{'not authorized'}" } + } else { die "$relfile $__{'Not a CONF/ nor DATA/ file'}" } } else { die "$__{'No filename specified'}" } # ---- action is 'save' # if ($action eq 'save') { - if ($TS0 != (stat("$absfile"))[9]) { - htmlMsgNotOK("$relfile has been modified while you were editing !"); - exit; - } - if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { - unless (flock(FILE, LOCK_EX|LOCK_NB)) { - warn "$me waiting for lock on $relfile..."; - flock(FILE, LOCK_EX); - } - qx(cp -a $absfile $absfile~ 2>&1); - if ( $? == 0 ) { - truncate(FILE, 0); - seek(FILE, 0, SEEK_SET); - $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a - push(@lignes,u2l($txt)); # forces ISO encoding in any conf file - print FILE @lignes ; - close(FILE); - htmlMsgOK($relfile); - } else { - close(FILE); - htmlMsgNotOK("$me couldn't backup $relfile"); - } - } else { htmlMsgNotOK("$me opening $relfile - $!") } - exit; + if ($TS0 != (stat("$absfile"))[9]) { + htmlMsgNotOK("$relfile has been modified while you were editing !"); + exit; + } + if ( sysopen(FILE, "$absfile", O_RDWR | O_CREAT) ) { + unless (flock(FILE, LOCK_EX|LOCK_NB)) { + warn "$me waiting for lock on $relfile..."; + flock(FILE, LOCK_EX); + } + qx(cp -a $absfile $absfile~ 2>&1); + if ( $? == 0 ) { + truncate(FILE, 0); + seek(FILE, 0, SEEK_SET); + $txt =~ s{\r\n}{\n}g; # 'cause js-serialize() forces 0d0a + push(@lignes,u2l($txt)); # forces ISO encoding in any conf file + print FILE @lignes ; + close(FILE); + htmlMsgOK($relfile); + } else { + close(FILE); + htmlMsgNotOK("$me couldn't backup $relfile"); + } + } else { htmlMsgNotOK("$me opening $relfile - $!") } + exit; } # ---- action is 'edit' (default) @@ -189,6 +189,7 @@ =head1 CONFIGURATION VARIABLES WebObs xedit "; + # - page, codemirror defs print " @@ -205,6 +206,7 @@ =head1 CONFIGURATION VARIABLES "; + # - page, xedit scripts print " "; print "\n"; + # - page, body print ""; print < html + # - page, edit or browse area -print "

        $relfile

        "; +print "

        $relfile

        "; print "
        @@ -238,6 +242,7 @@ =head1 CONFIGURATION VARIABLES print " readonly " if (not ($editOK || $admOK)); print ">$txt\n"; print "
        $fsmsg
        "; + # - page, button(s) area print "

        \n"; print "\n"; @@ -245,10 +250,10 @@ =head1 CONFIGURATION VARIABLES print "\n"; print "\n"; if ($editOK || $admOK) { - print "\n"; - print "\n"; + print "\n"; + print "\n"; } else { - print "\n"; + print "\n"; } print "

        "; print "
        "; @@ -259,13 +264,14 @@ =head1 CONFIGURATION VARIABLES # ---- helpers fns for returning 'save' information to client # sub htmlMsgOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - #[FBnote: does not suppress alert() window...] print "$_[0] updated successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); - print "$_[0] updated successfully !\n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + +#[FBnote: does not suppress alert() window...] print "$_[0] updated successfully !\n" if ($WEBOBS{CGI_CONFIRM_SUCCESSFUL} ne "NO"); + print "$_[0] updated successfully !\n"; } sub htmlMsgNotOK { - print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); - print "Update FAILED !\n $_[0] \n"; + print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); + print "Update FAILED !\n $_[0] \n"; } =pod diff --git a/CODE/perl/exposerc.pl b/CODE/perl/exposerc.pl index 395bb3aa..b987d0da 100755 --- a/CODE/perl/exposerc.pl +++ b/CODE/perl/exposerc.pl @@ -45,20 +45,21 @@ =head1 DESCRIPTION $prefix ||= 'WO__'; $prefix =~ s/^\s+|\s+$//g ; $ptr ||= ''; $ptr =~ s/^\s+|\s+$//g ; +if ( $ptr eq '' ) { + for (keys(%WEBOBS)) { + printf ("%s%s%s%s\n", $prefix, $_, $sep, $WEBOBS{$_}); -if ( $ptr eq '' ) { - for (keys(%WEBOBS)) { - printf ("%s%s%s%s\n", $prefix, $_, $sep, $WEBOBS{$_}); - #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $WEBOBS{$_}); - } + #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $WEBOBS{$_}); + } } else { - if (defined($WEBOBS{$ptr})) { - my %TGT = readCfg($WEBOBS{$ptr}); - for (keys(%TGT)) { - printf ("%s%s%s%s\n", $prefix, $_, $sep, $TGT{$_}) ; - #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $TGT{$_}) ; - } - } + if (defined($WEBOBS{$ptr})) { + my %TGT = readCfg($WEBOBS{$ptr}); + for (keys(%TGT)) { + printf ("%s%s%s%s\n", $prefix, $_, $sep, $TGT{$_}) ; + + #[XB-r1240:] printf ("%s%s%s'%s'\n", $prefix, $_, $sep, $TGT{$_}) ; + } + } } __END__ diff --git a/CODE/perl/fbgstd.pl b/CODE/perl/fbgstd.pl index 240bad0b..1c6b2e80 100755 --- a/CODE/perl/fbgstd.pl +++ b/CODE/perl/fbgstd.pl @@ -9,21 +9,23 @@ my $u = qx(lsof -a -p $$ -d0,1,2); print LOG "---- lsof:\n$u\n"; if (-t STDIN) { print LOG "---- -t STDIN true \n" } else { print LOG "---- -t STDIN false\n"} if (-t STDOUT) { print LOG "---- -t STDOUT true \n" } else { print LOG "---- -t STDOUT false\n"} + #$u = qx(ps T -o pid,ppid,pgid,pgrp,user,args | grep $0); $u = qx(ps -u $< f -o stat,pid,ppid,pgid,tpgid,tty,sid,user,args); print LOG "---- ps:\n$u"; if (!open(TTY, "/dev/tty")) { - print LOG "---- open /dev/tty failed\n"; + print LOG "---- open /dev/tty failed\n"; } else { - my $tpgrp = tcgetpgrp(fileno(*TTY)); - #my $tpgrp = tcgetpgrp(fileno(*STDIN)); - my $pgrp = getpgrp(); - print LOG "---- pgrp = $pgrp , tpgrp = $tpgrp ==> "; - if ($tpgrp == $pgrp) { - print LOG "foreground\n"; - } else { - print LOG "background\n"; - } + my $tpgrp = tcgetpgrp(fileno(*TTY)); + + #my $tpgrp = tcgetpgrp(fileno(*STDIN)); + my $pgrp = getpgrp(); + print LOG "---- pgrp = $pgrp , tpgrp = $tpgrp ==> "; + if ($tpgrp == $pgrp) { + print LOG "foreground\n"; + } else { + print LOG "background\n"; + } } close LOG; diff --git a/CODE/perl/fdsnws-event2mc3.pl b/CODE/perl/fdsnws-event2mc3.pl index c184c779..45a48502 100755 --- a/CODE/perl/fdsnws-event2mc3.pl +++ b/CODE/perl/fdsnws-event2mc3.pl @@ -61,122 +61,123 @@ =head1 DEPENDENCIES # ---- help text when no arguments if (@ARGV == 0) { - print "WebObs FDSN event webservice to MC3 seismic bulletin\n\n", - "Usage: $0 COMMAND [OPTIONS]\n\n", - "\tThe script checks new events in FDSN event webservice and updates\n", - "\tif necessary the MC3 database by creating new events entries. List of\n", - "\tavailable commands and options:\n\n", - "\tupdate\n", - "\t\tUpdates MC3 database.\n", - "\tcheck\n", - "\t\tchecks MC3 database (read only).\n", - "\tdumper\n", - "\t\tchecks and dumps XML tree (read only).\n", - "\t-f MC3NAME\n", - "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", - "\t-s FDSN WebService server\n", - "\t\tSpecifies FDSN WebService server to use (variable name FDSNWS_EVENTS_URL_server).Default is FDSNWS_EVENTS_URL in MC3 conf file.\n", - "\t-n SEFRAN3 name\n", - "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", - "\n\tFrançois Beauducel, Jean-Marie Saurel, WEBOBS/IPGP\n\n" - ; - exit(0); + print "WebObs FDSN event webservice to MC3 seismic bulletin\n\n", + "Usage: $0 COMMAND [OPTIONS]\n\n", + "\tThe script checks new events in FDSN event webservice and updates\n", + "\tif necessary the MC3 database by creating new events entries. List of\n", + "\tavailable commands and options:\n\n", + "\tupdate\n", + "\t\tUpdates MC3 database.\n", + "\tcheck\n", + "\t\tchecks MC3 database (read only).\n", + "\tdumper\n", + "\t\tchecks and dumps XML tree (read only).\n", + "\t-f MC3NAME\n", + "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", + "\t-s FDSN WebService server\n", + "\t\tSpecifies FDSN WebService server to use (variable name FDSNWS_EVENTS_URL_server).Default is FDSNWS_EVENTS_URL in MC3 conf file.\n", + "\t-n SEFRAN3 name\n", + "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", + "\n\tFrançois Beauducel, Jean-Marie Saurel, WEBOBS/IPGP\n\n" + ; + exit(0); } # ---- check for command and option my $arg; if (@ARGV > 0) { - $arg = shift; - if (!($arg =~ /update|check|dumper/)) { - print "'$arg' invalid command\n"; - exit(1); - } - my $opt = shift || ''; - if ( $opt =~ /-f/ ) { - $opt = shift; - if ( $opt ) { - if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { - $mc3 = $opt; - $opt = shift || ''; - } else { - print "'$opt' does not exists\n"; - exit(1); - } - } else { - print "invalid -f option\n"; - exit(1); - } - } - if ( $opt =~ /-s/ ) { - $opt = shift; - if ( $opt ) { - $fdsnws_server = $opt; - print "-s option $fdsnws_server\n"; - $opt = shift || ''; - } else { - print "invalid -s option\n"; - exit(1); - } - } - if ( $opt =~ /-n/ ) { - $opt = shift; - if ( $opt ) { - $sefran3_name = $opt; - print "-n option $sefran3_name\n"; - $opt = shift || ''; - } else { - print "invalid -n option\n"; - exit(1); - } - } + $arg = shift; + if (!($arg =~ /update|check|dumper/)) { + print "'$arg' invalid command\n"; + exit(1); + } + my $opt = shift || ''; + if ( $opt =~ /-f/ ) { + $opt = shift; + if ( $opt ) { + if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { + $mc3 = $opt; + $opt = shift || ''; + } else { + print "'$opt' does not exists\n"; + exit(1); + } + } else { + print "invalid -f option\n"; + exit(1); + } + } + if ( $opt =~ /-s/ ) { + $opt = shift; + if ( $opt ) { + $fdsnws_server = $opt; + print "-s option $fdsnws_server\n"; + $opt = shift || ''; + } else { + print "invalid -s option\n"; + exit(1); + } + } + if ( $opt =~ /-n/ ) { + $opt = shift; + if ( $opt ) { + $sefran3_name = $opt; + print "-n option $sefran3_name\n"; + $opt = shift || ''; + } else { + print "invalid -n option\n"; + exit(1); + } + } } # ---- read config my %MC3 = readCfg("$WEBOBS{ROOT_CONF}/$mc3.conf"); my $oper = $MC3{SC3_USER}; my @blacklist_types = split(/,/,$MC3{SC3_EVENT_TYPES_BLACKLIST}); + # ---- FDSN WebService server my $fdsnws_url = ""; my $fdsnws_search = ""; my $fdsnws_detail = ""; if (defined($MC3{FDSNWS_EVENTS_URL})) { - $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; + $fdsnws_url = $MC3{FDSNWS_EVENTS_URL}; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; } if (defined($MC3{FDSNWS_EVENTS_OPT})) { - $fdsnws_search = $MC3{FDSNWS_EVENTS_OPT}; + $fdsnws_search = $MC3{FDSNWS_EVENTS_OPT}; } elsif (defined($MC3{FDSNWS_EVENTS_SEARCH})) { - $fdsnws_search = $MC3{FDSNWS_EVENTS_SEARCH}; + $fdsnws_search = $MC3{FDSNWS_EVENTS_SEARCH}; } if (defined($MC3{FDSNWS_EVENTS_DETAIL})) { - $fdsnws_detail = $MC3{FDSNWS_EVENTS_DETAIL}; + $fdsnws_detail = $MC3{FDSNWS_EVENTS_DETAIL}; } if (length($fdsnws_server) > 0) { - my $varname = "FDSNWS_EVENTS_URL_$fdsnws_server"; - $fdsnws_url = $MC3{$varname}; - ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); - $fdsnws_url = $fdsnws_url."?"; - $varname = "FDSNWS_EVENTS_OPT_$fdsnws_server"; - if (defined($MC3{$varname})) { - $fdsnws_search = $MC3{$varname}; - } - else { - $varname = "FDSNWS_EVENTS_SEARCH_$fdsnws_server"; - if (defined($MC3{$varname})) { - $fdsnws_search = $MC3{$varname}; - } - } - $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_server"; - if (defined($MC3{$varname})) { - $fdsnws_detail = $MC3{$varname}; - } + my $varname = "FDSNWS_EVENTS_URL_$fdsnws_server"; + $fdsnws_url = $MC3{$varname}; + ($fdsnws_url,$fdsnws_detail) = split(/\?/,$fdsnws_url); + $fdsnws_url = $fdsnws_url."?"; + $varname = "FDSNWS_EVENTS_OPT_$fdsnws_server"; + if (defined($MC3{$varname})) { + $fdsnws_search = $MC3{$varname}; + } + else { + $varname = "FDSNWS_EVENTS_SEARCH_$fdsnws_server"; + if (defined($MC3{$varname})) { + $fdsnws_search = $MC3{$varname}; + } + } + $varname = "FDSNWS_EVENTS_DETAIL_$fdsnws_server"; + if (defined($MC3{$varname})) { + $fdsnws_detail = $MC3{$varname}; + } } if (! -d $MC3{SC3_EVENTS_ROOT} ) { - print "creating $MC3{SC3_EVENTS_ROOT}\n"; - my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); + print "creating $MC3{SC3_EVENTS_ROOT}\n"; + my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); } # ---- gets the list of last events @@ -187,286 +188,293 @@ =head1 DEPENDENCIES # checks if events exist in MC database for (@last) { - my $evt_id = $_; - print "--- $evt_id ---\n"; - - my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; - my @lines = qx(grep "${fdsnws_server}:\/\/${evt_id}" $mc_path|xargs echo -n); - my $mc_file; - - if (@lines) { - # event's ID already exists in MC: do nothing (for the moment...) - $mc_file = ""; - } else { - - # ------------------------------------------------------------------------- - # event seems new: updates MC file - - my @tab; - my $s; - - my @event = qx(curl -s -S --globoff "${fdsnws_url}${fdsnws_detail}&format=xml&eventid=$evt_id" | $WEBOBS{XML2_PRGM}); - - $s = '/q:quakeml/eventParameters/event'; - foreach (@event) { s/^$s//g; } - - if ($arg =~ /dumper/) { - print join('',@event); - } - chomp(@event); - - # --- gets event type - my $evt_type = findvalue('/type=',\@event) // ''; - print "event type = $evt_type\n"; - if (grep(/^$evt_type$/,@blacklist_types)) { - print "Warning: Event type '$evt_type' is blacklisted!\n"; - } else { - - # --- gets preferred origin ID - my $evt_origID = findvalue('/preferredOriginID=',\@event); - print "origin ID = $evt_origID\n"; - - # --- selects preferred origin - my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); - - # --- gets origin:time - my $evt_time = findvalue('/time/value=',\@origin); - print "origin time = $evt_time\n"; - - # --- gets origin:latitude - my $evt_lat = findvalue('/latitude/value=',\@origin); - print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; - - # --- gets origin:longitude - my $evt_lon = findvalue('/longitude/value=',\@origin); - print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; - - # --- gets origin:methodID - my $evt_mcID = findvalue('/methodID=',\@origin) // ''; - print "origin methodID (MCID) = $evt_mcID\n"; - my $mcIDname = (split(/\//,$evt_mcID))[-3]; - my $mcIDym = (split(/\//,$evt_mcID))[-2]; - my $mcIDid = (split(/\//,$evt_mcID))[-1]; - - # --- gets origin:depth - my $evt_dep = findvalue('/depth/value=',\@origin); - $evt_dep /= 1000 if ($evt_dep ne ""); - print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; - - # --- gets description:text - my $evt_txt = findvalue('/description/text=',\@event); - print "origin description = $evt_txt \n"; - - # --- gets origin:evaluationMode and origin:evaluationStatus - my $evt_mode = findvalue('/evaluationMode=',\@origin); - my $evt_status = findvalue('/evaluationStatus=',\@origin); - if ($evt_status && $evt_status eq 'confirmed') { - $evt_type = 'UNKNOWN'; - } else { - $evt_type = 'AUTO'; - } - - print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; - print "origin status = ".($evt_status ? "$evt_status":"")."\n"; - - # --- gets preferred magnitude ID - my $evt_magID = findvalue('/preferredMagnitudeID=',\@event); - - my $evt_mag = ''; - my $evt_magtyp = ''; - my $evt_smag = ''; - my @magnitude; - if ($evt_magID) { - print "origin magnitude ID = $evt_magID\n"; - @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@event); - } else { - @magnitude = findnode('/magnitude','/\@publicID=',\@event); - print "* Warning: no preferred magnitude! Takes first...\n"; - } - if (@magnitude) { - $evt_mag = findvalue('/mag/value=',\@magnitude); - print "origin magnitude = $evt_mag\n"; - $evt_smag = $evt_mag; - $evt_magtyp = findvalue('/type=',\@magnitude); - print "origin magnitude type = $evt_magtyp\n"; - } else { - print "* Warning: no magnitude!\n"; - } - - - # --- selects first pick - # sorting pick:time:value = chronological order - @tab = sort(findvalues('/pick/time/value=',\@event)); - my $evt_pick = $tab[0]; - my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); - my $evt_pickID = findvalue('/\@publicID=',\@pick); - my $evt_sdate = substr($evt_pick,0,10) // ''; - my $evt_stime = substr($evt_pick,11,11) // ''; - $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" - my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; - my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; - my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; - my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; - my $evt_scode = "$NET.$STA.$LOC.$CHA"; - print "station pickID = $evt_pickID\n"; - print "station time = $evt_pick\n"; - print "station code = $evt_scode\n"; - - - my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); - - my $evt_pha = ''; - my $evt_dist = ''; - my $evt_unique = 0; - my $evt_SP = ''; - if (@arrival) { - # --- unique arrival or not - if (scalar(@arrival) == 1) { - $evt_unique = 1; - } - - # --- finds first station phase and distance (using "origin:arrival") - $evt_pha = findvalue('/phase=',\@arrival); - $evt_dist = findvalue('/distance=',\@arrival); - $evt_dist *= 111 if ($evt_dist); - print "station phase = $evt_pha\n"; - print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; - # --- computes S-P and duration from distance and magnitude - $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); - print "station S-P = $evt_SP\n"; - } else { - print "* Warning: no arrivals (phase, distance, S-P)!\n"; - } - - # --- computes duration from distance and magnitude - my $evt_dur = ''; - if ($evt_smag && $evt_dist) { - $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); - print "station duration = $evt_dur\n"; - if ($evt_dur == 0) { - $evt_dur = ''; - } - } else { - print "* Warning: no duration!\n"; - } - - - my $lockFile = "/tmp/.$mc3.lock"; - - if ($arg =~ /update/) { - # --- checks lock file - if (-e $lockFile) { - my $lockWho = qx(cat $lockFile | xargs echo -n); - die "WEBOBS: MC is presently edited by $lockWho ..."; - } else { - my $retLock = qx(echo "$oper" > $lockFile); - } - } - - my $mc_id; - my $newID = 1; - my $maxID = 0; - - # --- reads MC file - my ($mcy,$mcm) = split(/-/,$evt_sdate); - $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; - my @lignes; - if (-e $mc_file) { - print "MC file: $mc_file ..."; - open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); - while() { - my $line = $_; - ($mc_id) = split(/\|/,$line); - # --- check if $evt_mcID found - if ($evt_mcID ne '' && $mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { - $newID = 0; - my @txt = split(/\|/,$line); - $txt[13] = "$fdsnws_server:\/\/$evt_id"; - # @txt last field already contains "\n" - $line = join('|',@txt); - } - $maxID = abs($mc_id) if (abs($mc_id) > $maxID); - push(@lignes,$line); - } - close(FILE); - print " imported (max ID = $maxID).\n"; - } else { - # MC file does not exist: need to create directory and empty file. - if ($arg =~ /update/) { - qx(mkdir -p `dirname $mc_file`); - open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); - print FILE (""); - close(FILE); - $mc_id = 1; - } - } - - # --- outputs for MC - if ($newID > 0) { - $mc_id = $maxID + 1; - my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$fdsnws_server:\/\/$evt_id||$oper|$evt_magtyp$evt_mag $evt_txt\n"; - print "$newline\n"; - push(@lignes,$newline); - } - - - if ($arg =~ /update/) { - @lignes = sort Sort_date_with_id(@lignes); - - # Temporary file for sanity check before replacing - my $mc_file_temp="$mc_file.tmp"; - # Open temporary file for writing - open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); - # Write the updated lines - print FILE @lignes; - close(FILE); - # Sanity check : the columns number must always be 17 - if (system("awk -F'|' 'NF!=17{exit 1}' $mc_file") == 0) { - # Test passed, the file isn't corrupted - # The update should have increased the file size - if ( -s $mc_file_temp >= -s $mc_file ) { - # The file size is increased - # Replace the old file by the new one - if ( system("mv $mc_file_temp $mc_file") == 0 ) { - print "MC file: $mc_file updated\n"; - } else { - Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); - } - } - } else { - print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; - } - - # --- deletes lock file - if (-e $lockFile) { - unlink $lockFile; - } - } - } - } - - setlocale(LC_NUMERIC,$old_locale); + my $evt_id = $_; + print "--- $evt_id ---\n"; + + my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; + my @lines = qx(grep "${fdsnws_server}:\/\/${evt_id}" $mc_path|xargs echo -n); + my $mc_file; + + if (@lines) { + + # event's ID already exists in MC: do nothing (for the moment...) + $mc_file = ""; + } else { + + # ------------------------------------------------------------------------- + # event seems new: updates MC file + + my @tab; + my $s; + + my @event = qx(curl -s -S --globoff "${fdsnws_url}${fdsnws_detail}&format=xml&eventid=$evt_id" | $WEBOBS{XML2_PRGM}); + + $s = '/q:quakeml/eventParameters/event'; + foreach (@event) { s/^$s//g; } + + if ($arg =~ /dumper/) { + print join('',@event); + } + chomp(@event); + + # --- gets event type + my $evt_type = findvalue('/type=',\@event) // ''; + print "event type = $evt_type\n"; + if (grep(/^$evt_type$/,@blacklist_types)) { + print "Warning: Event type '$evt_type' is blacklisted!\n"; + } else { + + # --- gets preferred origin ID + my $evt_origID = findvalue('/preferredOriginID=',\@event); + print "origin ID = $evt_origID\n"; + + # --- selects preferred origin + my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); + + # --- gets origin:time + my $evt_time = findvalue('/time/value=',\@origin); + print "origin time = $evt_time\n"; + + # --- gets origin:latitude + my $evt_lat = findvalue('/latitude/value=',\@origin); + print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; + + # --- gets origin:longitude + my $evt_lon = findvalue('/longitude/value=',\@origin); + print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; + + # --- gets origin:methodID + my $evt_mcID = findvalue('/methodID=',\@origin) // ''; + print "origin methodID (MCID) = $evt_mcID\n"; + my $mcIDname = (split(/\//,$evt_mcID))[-3]; + my $mcIDym = (split(/\//,$evt_mcID))[-2]; + my $mcIDid = (split(/\//,$evt_mcID))[-1]; + + # --- gets origin:depth + my $evt_dep = findvalue('/depth/value=',\@origin); + $evt_dep /= 1000 if ($evt_dep ne ""); + print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; + + # --- gets description:text + my $evt_txt = findvalue('/description/text=',\@event); + print "origin description = $evt_txt \n"; + + # --- gets origin:evaluationMode and origin:evaluationStatus + my $evt_mode = findvalue('/evaluationMode=',\@origin); + my $evt_status = findvalue('/evaluationStatus=',\@origin); + if ($evt_status && $evt_status eq 'confirmed') { + $evt_type = 'UNKNOWN'; + } else { + $evt_type = 'AUTO'; + } + + print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; + print "origin status = ".($evt_status ? "$evt_status":"")."\n"; + + # --- gets preferred magnitude ID + my $evt_magID = findvalue('/preferredMagnitudeID=',\@event); + + my $evt_mag = ''; + my $evt_magtyp = ''; + my $evt_smag = ''; + my @magnitude; + if ($evt_magID) { + print "origin magnitude ID = $evt_magID\n"; + @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@event); + } else { + @magnitude = findnode('/magnitude','/\@publicID=',\@event); + print "* Warning: no preferred magnitude! Takes first...\n"; + } + if (@magnitude) { + $evt_mag = findvalue('/mag/value=',\@magnitude); + print "origin magnitude = $evt_mag\n"; + $evt_smag = $evt_mag; + $evt_magtyp = findvalue('/type=',\@magnitude); + print "origin magnitude type = $evt_magtyp\n"; + } else { + print "* Warning: no magnitude!\n"; + } + + # --- selects first pick + # sorting pick:time:value = chronological order + @tab = sort(findvalues('/pick/time/value=',\@event)); + my $evt_pick = $tab[0]; + my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); + my $evt_pickID = findvalue('/\@publicID=',\@pick); + my $evt_sdate = substr($evt_pick,0,10) // ''; + my $evt_stime = substr($evt_pick,11,11) // ''; + $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" + my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; + my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; + my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; + my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; + my $evt_scode = "$NET.$STA.$LOC.$CHA"; + print "station pickID = $evt_pickID\n"; + print "station time = $evt_pick\n"; + print "station code = $evt_scode\n"; + + my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); + + my $evt_pha = ''; + my $evt_dist = ''; + my $evt_unique = 0; + my $evt_SP = ''; + if (@arrival) { + + # --- unique arrival or not + if (scalar(@arrival) == 1) { + $evt_unique = 1; + } + + # --- finds first station phase and distance (using "origin:arrival") + $evt_pha = findvalue('/phase=',\@arrival); + $evt_dist = findvalue('/distance=',\@arrival); + $evt_dist *= 111 if ($evt_dist); + print "station phase = $evt_pha\n"; + print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; + + # --- computes S-P and duration from distance and magnitude + $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); + print "station S-P = $evt_SP\n"; + } else { + print "* Warning: no arrivals (phase, distance, S-P)!\n"; + } + + # --- computes duration from distance and magnitude + my $evt_dur = ''; + if ($evt_smag && $evt_dist) { + $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); + print "station duration = $evt_dur\n"; + if ($evt_dur == 0) { + $evt_dur = ''; + } + } else { + print "* Warning: no duration!\n"; + } + + my $lockFile = "/tmp/.$mc3.lock"; + + if ($arg =~ /update/) { + + # --- checks lock file + if (-e $lockFile) { + my $lockWho = qx(cat $lockFile | xargs echo -n); + die "WEBOBS: MC is presently edited by $lockWho ..."; + } else { + my $retLock = qx(echo "$oper" > $lockFile); + } + } + + my $mc_id; + my $newID = 1; + my $maxID = 0; + + # --- reads MC file + my ($mcy,$mcm) = split(/-/,$evt_sdate); + $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; + my @lignes; + if (-e $mc_file) { + print "MC file: $mc_file ..."; + open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); + while() { + my $line = $_; + ($mc_id) = split(/\|/,$line); + + # --- check if $evt_mcID found + if ($evt_mcID ne '' && $mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { + $newID = 0; + my @txt = split(/\|/,$line); + $txt[13] = "$fdsnws_server:\/\/$evt_id"; + + # @txt last field already contains "\n" + $line = join('|',@txt); + } + $maxID = abs($mc_id) if (abs($mc_id) > $maxID); + push(@lignes,$line); + } + close(FILE); + print " imported (max ID = $maxID).\n"; + } else { + + # MC file does not exist: need to create directory and empty file. + if ($arg =~ /update/) { + qx(mkdir -p `dirname $mc_file`); + open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); + print FILE (""); + close(FILE); + $mc_id = 1; + } + } + + # --- outputs for MC + if ($newID > 0) { + $mc_id = $maxID + 1; + my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$fdsnws_server:\/\/$evt_id||$oper|$evt_magtyp$evt_mag $evt_txt\n"; + print "$newline\n"; + push(@lignes,$newline); + } + + if ($arg =~ /update/) { + @lignes = sort Sort_date_with_id(@lignes); + + # Temporary file for sanity check before replacing + my $mc_file_temp="$mc_file.tmp"; + + # Open temporary file for writing + open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); + + # Write the updated lines + print FILE @lignes; + close(FILE); + + # Sanity check : the columns number must always be 17 + if (system("awk -F'|' 'NF!=17{exit 1}' $mc_file") == 0) { + + # Test passed, the file isn't corrupted + # The update should have increased the file size + if ( -s $mc_file_temp >= -s $mc_file ) { + + # The file size is increased + # Replace the old file by the new one + if ( system("mv $mc_file_temp $mc_file") == 0 ) { + print "MC file: $mc_file updated\n"; + } else { + Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); + } + } + } else { + print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; + } + + # --- deletes lock file + if (-e $lockFile) { + unlink $lockFile; + } + } + } + } + + setlocale(LC_NUMERIC,$old_locale); } - #-------------------------------------------------------------------------------------------------------------------------------------- sub Sort_date_with_id ($$) { - my ($c,$d) = @_; + my ($c,$d) = @_; - # removes the first field (ID) - $c =~ s/^[\-0-9]+\|//; - $d =~ s/^[\-0-9]+\|//; + # removes the first field (ID) + $c =~ s/^[\-0-9]+\|//; + $d =~ s/^[\-0-9]+\|//; - return $d cmp $c; + return $d cmp $c; } #-------------------------------------------------------------------------------------------------------------------------------------- sub Quit { - if (-e $_[0]) { - unlink $_[0]; - } - die "WEBOBS: $_[1]"; + if (-e $_[0]) { + unlink $_[0]; + } + die "WEBOBS: $_[1]"; } __END__ diff --git a/CODE/perl/jobq.pl b/CODE/perl/jobq.pl index dab2b35b..3f392b8b 100755 --- a/CODE/perl/jobq.pl +++ b/CODE/perl/jobq.pl @@ -20,7 +20,7 @@ =head1 DESCRIPTION use strict; use warnings; use FindBin; -use lib $FindBin::Bin; +use lib $FindBin::Bin; use Time::HiRes qw/time gettimeofday tv_interval usleep/; use POSIX qw/strftime :signal_h :errno_h :sys_wait_h/; use IO::Socket; @@ -44,34 +44,35 @@ =head1 DESCRIPTION our %SCHED; if ($configf ne '' && -e $configf) { %SCHED = readCfg($configf) } else { if (defined($WEBOBS{CONF_SCHEDULER})) { %SCHED = readCfg($WEBOBS{CONF_SCHEDULER}) }} -if ( scalar(keys(%SCHED)) <= 1 ) { - printf ("%16.6f %s",time,"can't start: no|invalid configuration file\n"); - exit(1); +if ( scalar(keys(%SCHED)) <= 1 ) { + printf ("%16.6f %s",time,"can't start: no|invalid configuration file\n"); + exit(1); } # ---- send command / receive reply from scheduler # ---------------------------------------------------------------------------- my $SOCK = undef; -my $server = "localhost"; +my $server = "localhost"; my $TIMEOUT=5; # create socket $SOCK = IO::Socket::INET->new(Proto => 'udp', PeerPort => $SCHED{PORT}, PeerAddr => $server ); if ( !$SOCK ) { - printf "couldn't create socket on port $SCHED{PORT}\n"; - exit(2); + printf "couldn't create socket on port $SCHED{PORT}\n"; + exit(2); } + # send / receive if ( $SOCK->send($msg) ) { - if ( $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) ) { - print "Server ".$SOCK->peerhost.":".$SOCK->peerport." replied:\n$msg\n"; - } else { - print "socket recv error\n"; - exit(3); - } + if ( $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) ) { + print "Server ".$SOCK->peerhost.":".$SOCK->peerport." replied:\n$msg\n"; + } else { + print "socket recv error\n"; + exit(3); + } } else { - print "socket send error\n"; - exit(3); + print "socket send error\n"; + exit(3); } exit(0); diff --git a/CODE/perl/lib/Config.pm b/CODE/perl/lib/Config.pm index 48f629e7..bce27a33 100644 --- a/CODE/perl/lib/Config.pm +++ b/CODE/perl/lib/Config.pm @@ -99,31 +99,30 @@ $VERSION = "2.00"; my $confF1 = "/etc/webobs.d/WEBOBS.rc"; if (-e $confF1) { - %WEBOBS = readCfg($confF1) ; - $WEBOBS_LFN = "from $confF1 (".(stat($confF1))[9].")"; + %WEBOBS = readCfg($confF1) ; + $WEBOBS_LFN = "from $confF1 (".(stat($confF1))[9].")"; } our $cgi_msg_html = ""; if ( defined($WEBOBS{CGI_MSG}) && -e $WEBOBS{CGI_MSG} ) { - if (open(FILE, "<$WEBOBS{CGI_MSG}")) { - while() { $cgi_msg_html .= $_ } - close(FILE); - } + if (open(FILE, "<$WEBOBS{CGI_MSG}")) { + while() { $cgi_msg_html .= $_ } + close(FILE); + } } else { - $cgi_msg_html = "

        WebObs Error

        "; + $cgi_msg_html = "

        WebObs Error

        "; } sub webobs_cgi_msg { - my $msg = shift; - print $cgi_msg_html; - $msg =~ s/\n/ /g; # \n once found nullifying the following match - $msg =~ /^(.*)( at.*line.*)/; - my $p1 = "$1
        "; - my $p2 = "".basename($2)." on ".localtime(time())."<\/span>"; - print "

        $p1

        $p2"; + my $msg = shift; + print $cgi_msg_html; + $msg =~ s/\n/ /g; # \n once found nullifying the following match + $msg =~ /^(.*)( at.*line.*)/; + my $p1 = "$1
        "; + my $p2 = "".basename($2)." on ".localtime(time())."<\/span>"; + print "

        $p1

        $p2"; } - =pod =head2 readFile @@ -144,22 +143,22 @@ readFile blocks until it acquires a shared lock on the file to be read. sub readFile { - my $File=$_[0]; - my @raw; my @contenu; - my $line = ""; - if (-f $File) { - open(FILE, "<$File") || die "couldn't open file $File. $!"; - unless ( flock(FILE, LOCK_SH | LOCK_NB)) { - warn "waiting for lock on $File..."; - flock(FILE, LOCK_SH); - } - seek(FILE, 0, SEEK_SET); - if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } - else { while() { push(@raw,$_)} } - close(FILE); # close automatically releases LOCK - } - for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } - return @contenu; + my $File=$_[0]; + my @raw; my @contenu; + my $line = ""; + if (-f $File) { + open(FILE, "<$File") || die "couldn't open file $File. $!"; + unless ( flock(FILE, LOCK_SH | LOCK_NB)) { + warn "waiting for lock on $File..."; + flock(FILE, LOCK_SH); + } + seek(FILE, 0, SEEK_SET); + if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } + else { while() { push(@raw,$_)} } + close(FILE); # close automatically releases LOCK + } + for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } + return @contenu; } =pod @@ -183,23 +182,23 @@ Reference (pointer) to file contents might help perf/storage on huge files. sub xreadFile { - my $File=$_[0]; - my @raw; my @contenu; my $ts=''; - my $line = ""; - if (-f $File) { - open(FILE, "<$File") || die "couldn't open file $File. $!"; - unless ( flock(FILE, LOCK_SH | LOCK_NB)) { - warn "waiting for lock on $File..."; - flock(FILE, LOCK_SH); - } - $ts = (stat($File))[9]; - seek(FILE, 0, SEEK_SET); - if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } - else { while() { push(@raw,$_)} } - close(FILE); # close automatically releases LOCK - } - for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } - return (\@contenu, $ts); + my $File=$_[0]; + my @raw; my @contenu; my $ts=''; + my $line = ""; + if (-f $File) { + open(FILE, "<$File") || die "couldn't open file $File. $!"; + unless ( flock(FILE, LOCK_SH | LOCK_NB)) { + warn "waiting for lock on $File..."; + flock(FILE, LOCK_SH); + } + $ts = (stat($File))[9]; + seek(FILE, 0, SEEK_SET); + if (@_ == 2) { while() { push(@raw,$_) if ($_ =~ /$_[1]/) } } + else { while() { push(@raw,$_)} } + close(FILE); # close automatically releases LOCK + } + for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } + return (\@contenu, $ts); } =pod @@ -215,20 +214,20 @@ and removing commented lines (# in col1), blank lines, and all \r (CR). sub readCfgFile { - my $configFile = $_[0]; - my $utf8 = $_[1]; - my @raw; my @contenu; - my $line = ""; - my @fraw = readFile($configFile); - for (@fraw) { - $_ =~ s/\r//g; - chomp($_); - push(@contenu,($utf8 ? $_:l2u($_))); - } - @contenu = grep(!/^#/, @contenu); - @contenu = grep(!/^$/, @contenu); - for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } - return @contenu; + my $configFile = $_[0]; + my $utf8 = $_[1]; + my @raw; my @contenu; + my $line = ""; + my @fraw = readFile($configFile); + for (@fraw) { + $_ =~ s/\r//g; + chomp($_); + push(@contenu,($utf8 ? $_:l2u($_))); + } + @contenu = grep(!/^#/, @contenu); + @contenu = grep(!/^$/, @contenu); + for (@raw) { $line .= $_; if (m/\\(\r\n|\n)$/) { $line =~ s/\\(\r\n|\n)$// } else { push(@contenu,$line); $line='' } } + return @contenu; } =pod @@ -247,58 +246,60 @@ if none is specified). See DESCRIPTION above for a description of readCfg interp sub readCfg { - my $fn = $_[0]; - my $sort = grep( /^sorted$/, @_[1..$#_] ); - my $escape = grep ( /^escape$/, @_[1..$#_] ); - my $novsub = grep ( /^novsub$/, @_[1..$#_] ); - my $id = 0; - my (@df, @wrk, $i, $l, %H, @A); - my @fraw = readFile($fn); - chomp(@fraw); - for (@fraw) { - s/(? 2) { # key|val1|...|valN ? build an HoH - for ($i = 1; $i < @df; $i++) { - $H{$wrk[0]}{$df[$i]} = $wrk[$i]; - } - $H{$wrk[0]}{_SO_} = sprintf("%03d",++$id) if ($sort); - next; - } - push(@A, [@wrk]); # otherwise build an AoA - } - if (@A) { return @A; } - if (%H) { - no warnings "uninitialized"; - if (!$novsub) { + my $fn = $_[0]; + my $sort = grep( /^sorted$/, @_[1..$#_] ); + my $escape = grep ( /^escape$/, @_[1..$#_] ); + my $novsub = grep ( /^novsub$/, @_[1..$#_] ); + my $id = 0; + my (@df, @wrk, $i, $l, %H, @A); + my @fraw = readFile($fn); + chomp(@fraw); + for (@fraw) { + s/(? 2) { # key|val1|...|valN ? build an HoH + for ($i = 1; $i < @df; $i++) { + $H{$wrk[0]}{$df[$i]} = $wrk[$i]; + } + $H{$wrk[0]}{_SO_} = sprintf("%03d",++$id) if ($sort); + next; + } + push(@A, [@wrk]); # otherwise build an AoA + } + if (@A) { return @A; } + if (%H) { + no warnings "uninitialized"; + if (!$novsub) { for my $key (keys %H) { $H{$key} =~ s/[\$][\{](.*?)[\}]/$H{$1}/g; } + # need two passes, last one also handling %WEBOBS substitution - for my $key (keys %H) { - $H{$key} =~ s/[\$][\{](.*?)[\}]/$H{$1}/g; - $H{$key} =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; - } - } - use warnings; - return %H; - } - # Use an explicit return in case $fn is undefined or the file is empty - # (otherwise an implicit return would return [0]). - return; + for my $key (keys %H) { + $H{$key} =~ s/[\$][\{](.*?)[\}]/$H{$1}/g; + $H{$key} =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; + } + } + use warnings; + return %H; + } + + # Use an explicit return in case $fn is undefined or the file is empty + # (otherwise an implicit return would return [0]). + return; } =pod @@ -331,42 +332,47 @@ Return codes from notify: =cut sub notify { - my $req = shift; - - if (not $WEBOBS{POSTBOARD_NPIPE}) { - # Cannot contact postboard: fifo is not defined - return 98; - } - if (not $req) { - # No argument: nothing to send - return 97; - } - - my @cmd = (time, split(/\|/, $req)); - if (@cmd == 3) { - # The message argument may be empty (action without argument). - push(@cmd, ''); - } - - if (@cmd != 4) { - # There must be 4 fields in the notification message - return 99; - } - - my $rc = sysopen(my $fifo, "$WEBOBS{POSTBOARD_NPIPE}", O_NONBLOCK|O_WRONLY); - if (not $rc) { - # Error while opening the fifo - return 96; - } - - # Rebuild and write the final request to the pipe - # avoiding any \n over the pipe. - my $postboard_request = join('|', @cmd) =~ s/\n/\0/gr; - print($fifo "$postboard_request\n"); - close($fifo) - or warn "An error occurred while closing '$WEBOBS{POSTBOARD_NPIPE}'"; - - return 0; + my $req = shift; + + if (not $WEBOBS{POSTBOARD_NPIPE}) { + + # Cannot contact postboard: fifo is not defined + return 98; + } + if (not $req) { + + # No argument: nothing to send + return 97; + } + + my @cmd = (time, split(/\|/, $req)); + if (@cmd == 3) { + + # The message argument may be empty (action without argument). + push(@cmd, ''); + } + + if (@cmd != 4) { + + # There must be 4 fields in the notification message + return 99; + } + + my $rc = sysopen(my $fifo, "$WEBOBS{POSTBOARD_NPIPE}", O_NONBLOCK|O_WRONLY); + if (not $rc) { + + # Error while opening the fifo + return 96; + } + + # Rebuild and write the final request to the pipe + # avoiding any \n over the pipe. + my $postboard_request = join('|', @cmd) =~ s/\n/\0/gr; + print($fifo "$postboard_request\n"); + close($fifo) + or warn "An error occurred while closing '$WEBOBS{POSTBOARD_NPIPE}'"; + + return 0; } 1; diff --git a/CODE/perl/lib/DBForm.pm b/CODE/perl/lib/DBForm.pm index dc7112a4..47735e58 100644 --- a/CODE/perl/lib/DBForm.pm +++ b/CODE/perl/lib/DBForm.pm @@ -146,219 +146,221 @@ set_message(\&webobs_cgi_msg); # DBFORM constructor sub new { my ( $class, $Name ) = @_; - my $self = {}; + my $self = {}; - # name : Form name + # name : Form name die "Missing form name" if !defined($Name); - $self->{name} = $Name; + $self->{name} = $Name; + + # path : path to configs dir + $self->{path} = "$WEBOBS{PATH_FORMS}/$Name"; + + # conf : full path to this config + die "No configuration found for $Name" if (! -e $self->{path}."/$Name.conf"); + $self->{conf} = { readCfg($self->{path}."/$Name.conf") }; + + # dbname : database name - create if needed and ddl is available + $self->{dbname} = "$WEBOBS{PATH_DATA_DB}/".$self->{conf}{DBNAME}; + if (! -e $self->{dbname}) { + die "No database and no ddl to create it for $Name" if (! -e $self->{path}."/$Name.ddl"); + xddl($self->{dbname}, $self->{path}."/$Name.ddl"); + } + + # _procs : PROCS referencing this form + opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); + my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; + for my $proc ( @Ps ) { + my %P = readProc($proc); + $self->{_procs}{$proc} = $P{$proc}{NAME} ; + } + closedir(DIR); - # path : path to configs dir - $self->{path} = "$WEBOBS{PATH_FORMS}/$Name"; + # dbh : DB Handle from connect to DB + my %dbattr = ( RaiseError => 0, PrintError => 0 ); + $self->{dbh} = DBI->connect("dbi:SQLite:$self->{dbname}","","",\%dbattr) + or die "couldn't connect to $self->{dbname}: $DBI::errstr\n"; + $self->{dbh}->do("pragma foreign_keys = ON"); - # conf : full path to this config - die "No configuration found for $Name" if (! -e $self->{path}."/$Name.conf"); - $self->{conf} = { readCfg($self->{path}."/$Name.conf") }; + # _icols , _dcols : resp. hash of IDS and DATA columns' info + $self->{_icols} = $self->{dbh}->selectall_hashref("pragma table_info(ids)","cid") ; + $self->{_dcols} = $self->{dbh}->selectall_hashref("pragma table_info(data)","cid"); - # dbname : database name - create if needed and ddl is available - $self->{dbname} = "$WEBOBS{PATH_DATA_DB}/".$self->{conf}{DBNAME}; - if (! -e $self->{dbname}) { - die "No database and no ddl to create it for $Name" if (! -e $self->{path}."/$Name.ddl"); - xddl($self->{dbname}, $self->{path}."/$Name.ddl"); - } + # the sql 'where' clause used by select method (without leading "and") + $self->{where} = " ids.hidden = 'N' "; - # _procs : PROCS referencing this form - opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); - my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; - for my $proc ( @Ps ) { - my %P = readProc($proc); - $self->{_procs}{$proc} = $P{$proc}{NAME} ; - } - closedir(DIR); - - # dbh : DB Handle from connect to DB - my %dbattr = ( RaiseError => 0, PrintError => 0 ); - $self->{dbh} = DBI->connect("dbi:SQLite:$self->{dbname}","","",\%dbattr) - or die "couldn't connect to $self->{dbname}: $DBI::errstr\n"; - $self->{dbh}->do("pragma foreign_keys = ON"); - - # _icols , _dcols : resp. hash of IDS and DATA columns' info - $self->{_icols} = $self->{dbh}->selectall_hashref("pragma table_info(ids)","cid") ; - $self->{_dcols} = $self->{dbh}->selectall_hashref("pragma table_info(data)","cid"); - - # the sql 'where' clause used by select method (without leading "and") - $self->{where} = " ids.hidden = 'N' "; - - # the sql 'order by' clause used by select method - $self->{order} = " ORDER BY ids.ts1 ASC"; - - bless $self, $class; + # the sql 'order by' clause used by select method + $self->{order} = " ORDER BY ids.ts1 ASC"; + + bless $self, $class; return $self; } # system's resource mngt might use DESTROY: make sure we disconnect from DB sub DESTROY { - my $self = shift; - $self->{sth}->finish if ($self->{sth}); - $self->{dbh}->disconnect if $self->{dbh}; + my $self = shift; + $self->{sth}->finish if ($self->{sth}); + $self->{dbh}->disconnect if $self->{dbh}; } # get the configuration parameter named $k sub conf { - my ($self, $k) = @_; - return $self->{conf}{$k} if (defined($k)); -} + my ($self, $k) = @_; + return $self->{conf}{$k} if (defined($k)); +} # select all rows or row matching the optional $id (ie. column 'id') argument # following a call to 'select', the 'fetch' method is used to retrieve # results one row at a time. sub select { - my ($self, $id) = @_; - undef($self->{errstr}) if ($self->{errstr}); - undef($self->{cols}) if ($self->{cols}); - $self->{sth}->finish if ($self->{sth}); - my $where = ($self->{where} && $self->{where} ne "") ? " and $self->{where} " : ""; - $where .= (defined($id)) ? " AND ids.id = $id " : ""; - - $self->{cols} = join(',', map { "ids.$self->{_icols}{$_}{name}" } sort keys($self->{_icols})) . "," ; - $self->{cols} .= join(",", map { "data.$self->{_dcols}{$_}{name}" } grep { $self->{_dcols}{$_}{name} !~ /ID/ } sort keys($self->{_dcols})); - - my $stmt = "SELECT $self->{cols} FROM ids, data WHERE ids.id = data.id $where $self->{order}"; - - if ($self->{sth} = $self->{dbh}->prepare($stmt)) { - if (! $self->{sth}->execute) { $self->{errstr} = "failed to execute: $DBI::errstr"; } - } else { $self->{errstr} = "failed to prepare: $DBI::errstr"; } - return; + my ($self, $id) = @_; + undef($self->{errstr}) if ($self->{errstr}); + undef($self->{cols}) if ($self->{cols}); + $self->{sth}->finish if ($self->{sth}); + my $where = ($self->{where} && $self->{where} ne "") ? " and $self->{where} " : ""; + $where .= (defined($id)) ? " AND ids.id = $id " : ""; + + $self->{cols} = join(',', map { "ids.$self->{_icols}{$_}{name}" } sort keys($self->{_icols})) . "," ; + $self->{cols} .= join(",", map { "data.$self->{_dcols}{$_}{name}" } grep { $self->{_dcols}{$_}{name} !~ /ID/ } sort keys($self->{_dcols})); + + my $stmt = "SELECT $self->{cols} FROM ids, data WHERE ids.id = data.id $where $self->{order}"; + + if ($self->{sth} = $self->{dbh}->prepare($stmt)) { + if (! $self->{sth}->execute) { $self->{errstr} = "failed to execute: $DBI::errstr"; } + } else { $self->{errstr} = "failed to prepare: $DBI::errstr"; } + return; } # fetch next single row of a previously 'select' result set # returns a reference to a hash of column => value sub fetch { - my $self = shift; - undef($self->{errstr}) if ($self->{errstr}); - return $self->{sth}->fetchrow_hashref if ($self->{sth}); + my $self = shift; + undef($self->{errstr}) if ($self->{errstr}); + return $self->{sth}->fetchrow_hashref if ($self->{sth}); } # returns array of column-names used in last select sub cols { - my ($self, $k) = @_; - return grep { s/^.*\.// } split(/,/,$self->{cols}) if ($self->{cols}); -} + my ($self, $k) = @_; + return grep { s/^.*\.// } split(/,/,$self->{cols}) if ($self->{cols}); +} # insert : insert row from a CGI query-parameters reference $QP ($QP = $cgi->Vars) # returns ID of new row if successfull, -1 otherwise with {errstr} sub insert { - my ($self, $QP) = @_; - undef($self->{errstr}) if ($self->{errstr}); - $self->{sth}->finish if ($self->{sth}); - my $value = my $id = ''; - my $cIDS = my $cDATA = my $vIDS = my $vDATA = my $val = ""; - # scanning all defined columns, build the cols and values lists of the insert statement : - # only the columns found in QueryString (ie: colname=val); quote values when needed; - for (sort keys($self->{_icols})) { - next if ($_ == 0); # ignore 1st col that must be ID - $val = $QP->{$self->{_icols}{$_}{name}} || undef ; - next if ( !defined($val) ); - $cIDS .= "$self->{_icols}{$_}{name},"; - if ( uc($self->{_icols}{$_}{type}) eq 'TEXT' || uc($self->{_icols}{$_}{type}) eq 'TIMESTAMP' ) { - $vIDS .= "'".$val."'," ; - } else { $vIDS .= $val."," } - } - $cIDS =~ s/,$//; $vIDS =~ s/,$//; # remove extra trailing comma - for (sort keys($self->{_dcols})) { - next if ($_ == 0); # ignore 1st col that must be ID - $val = $QP->{$self->{_dcols}{$_}{name}} || undef ; - next if ( !defined($val) ); - $cDATA .= "$self->{_dcols}{$_}{name},"; - if ( uc($self->{_dcols}{$_}{type}) eq 'TEXT' || uc($self->{_dcols}{$_}{type}) eq 'TIMESTAMP' ) { - $vDATA .= "'".$val."'," ; - } else { $vDATA .= $val."," } - } - $cDATA =~ s/,$//; $vDATA =~ s/,$//; # remove extra trailing comma - # inserts transaction - my $i1 = "INSERT INTO ids($cIDS) VALUES($vIDS)"; - $self->{dbh}->begin_work(); - eval { - local $self->{dbh}->{RaiseError} = 1; - $self->{dbh}->do($i1); - $id = $self->{dbh}->last_insert_id(undef, undef, qw(ids id)); - my $i2 = "INSERT INTO data(id,$cDATA) VALUES($id,$vDATA)\n"; - $self->{dbh}->do($i2); - $self->{dbh}->commit(); - }; - if ($@) { - $self->{errstr} = "insert aborted: $@"; - $id = -1; - eval { $self->{dbh}->rollback }; - } - return $id; + my ($self, $QP) = @_; + undef($self->{errstr}) if ($self->{errstr}); + $self->{sth}->finish if ($self->{sth}); + my $value = my $id = ''; + my $cIDS = my $cDATA = my $vIDS = my $vDATA = my $val = ""; + +# scanning all defined columns, build the cols and values lists of the insert statement : +# only the columns found in QueryString (ie: colname=val); quote values when needed; + for (sort keys($self->{_icols})) { + next if ($_ == 0); # ignore 1st col that must be ID + $val = $QP->{$self->{_icols}{$_}{name}} || undef ; + next if ( !defined($val) ); + $cIDS .= "$self->{_icols}{$_}{name},"; + if ( uc($self->{_icols}{$_}{type}) eq 'TEXT' || uc($self->{_icols}{$_}{type}) eq 'TIMESTAMP' ) { + $vIDS .= "'".$val."'," ; + } else { $vIDS .= $val."," } + } + $cIDS =~ s/,$//; $vIDS =~ s/,$//; # remove extra trailing comma + for (sort keys($self->{_dcols})) { + next if ($_ == 0); # ignore 1st col that must be ID + $val = $QP->{$self->{_dcols}{$_}{name}} || undef ; + next if ( !defined($val) ); + $cDATA .= "$self->{_dcols}{$_}{name},"; + if ( uc($self->{_dcols}{$_}{type}) eq 'TEXT' || uc($self->{_dcols}{$_}{type}) eq 'TIMESTAMP' ) { + $vDATA .= "'".$val."'," ; + } else { $vDATA .= $val."," } + } + $cDATA =~ s/,$//; $vDATA =~ s/,$//; # remove extra trailing comma + + # inserts transaction + my $i1 = "INSERT INTO ids($cIDS) VALUES($vIDS)"; + $self->{dbh}->begin_work(); + eval { + local $self->{dbh}->{RaiseError} = 1; + $self->{dbh}->do($i1); + $id = $self->{dbh}->last_insert_id(undef, undef, qw(ids id)); + my $i2 = "INSERT INTO data(id,$cDATA) VALUES($id,$vDATA)\n"; + $self->{dbh}->do($i2); + $self->{dbh}->commit(); + }; + if ($@) { + $self->{errstr} = "insert aborted: $@"; + $id = -1; + eval { $self->{dbh}->rollback }; + } + return $id; } # get an array of all CHECKS constraints in table DATA sub datachecks { - my $self = shift; - my $row = $self->{dbh}->selectrow_array("SELECT sql FROM sqlite_master WHERE type='table' and name='data' ;"); - return ($row =~ m/check.*\((.*)\)/g); + my $self = shift; + my $row = $self->{dbh}->selectrow_array("SELECT sql FROM sqlite_master WHERE type='table' and name='data' ;"); + return ($row =~ m/check.*\((.*)\)/g); } # delete data : delete row matching $id (ie. column 'id') # delete ID from both 'ids' and 'data' table (using on cascade) sub delete { - my ($self, $id) = @_; - undef($self->{errstr}) if ($self->{errstr}); - $self->{sth}->finish if ($self->{sth}); - if (defined($id)) { - $self->{dbh}->do("DELETE FROM ids WHERE id=$id"); - $self->{errstr} = $self->{dbh}->errstr() if ($self->{dbh}->err()); - } - return; + my ($self, $id) = @_; + undef($self->{errstr}) if ($self->{errstr}); + $self->{sth}->finish if ($self->{sth}); + if (defined($id)) { + $self->{dbh}->do("DELETE FROM ids WHERE id=$id"); + $self->{errstr} = $self->{dbh}->errstr() if ($self->{dbh}->err()); + } + return; } # get PROC(s) of this FORM as a hash of their 'long' name (NAME) sub procs { my ($self) = @_; - return %{$self->{_procs}} if ($self->{_procs}); + return %{$self->{_procs}} if ($self->{_procs}); } # get valid nodes of a PROC of this FORM, returned as a hash of their NAME, ALIAS and FID sub nodes { - my ($self, $proc) = @_; - undef($self->{errstr}) if ($self->{errstr}); - if (defined($proc)) { - if (! $proc ~~ [ map "$_", keys(%{$self->{_procs}})] ) { - my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); - return %L; - } else { - $self->{errstr} = "$proc not in ".$self->{name}."\n" ; - } - } else { - $self->{errstr} = "no proc requested\n" if (!defined($proc)); - } + my ($self, $proc) = @_; + undef($self->{errstr}) if ($self->{errstr}); + if (defined($proc)) { + if (! $proc ~~ [ map "$_", keys(%{$self->{_procs}})] ) { + my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); + return %L; + } else { + $self->{errstr} = "$proc not in ".$self->{name}."\n" ; + } + } else { + $self->{errstr} = "no proc requested\n" if (!defined($proc)); + } } # get a dump of this DBFORM as a string # usage: print $F->dump sub dump { my ($self) = @_; - my $dmp = ''; + my $dmp = ''; $dmp .= sprintf( "Name: %s\n", $self->{name} ); $dmp .= sprintf( "Configuration: %s\n", $self->{path} ); - map { $dmp .= sprintf " $_ => $self->{conf}{$_}\n" } keys %{ $self->{conf}}; + map { $dmp .= sprintf " $_ => $self->{conf}{$_}\n" } keys %{ $self->{conf}}; $dmp .= sprintf( "Database: %s\n", $self->{dbname} ); $dmp .= sprintf( " specific columns: %s\n", join(', ', map { $self->{_dcols}{$_}{name}."($self->{_dcols}{$_}{type})" } sort keys($self->{_dcols})) ); - $dmp .= sprintf( " number of rows: %s\n", $self->{dbh}->selectrow_array( "SELECT COUNT(*) FROM ids") ); - $dmp .= "Related PROC(s): "; - for ( keys(%{$self->{_procs}}) ) { - $dmp .= sprintf(" %s(%s) ", $_, $self->{_procs}{$_}); - } - $dmp .= "\n"; - return $dmp; + $dmp .= sprintf( " number of rows: %s\n", $self->{dbh}->selectrow_array( "SELECT COUNT(*) FROM ids") ); + $dmp .= "Related PROC(s): "; + for ( keys(%{$self->{_procs}}) ) { + $dmp .= sprintf(" %s(%s) ", $_, $self->{_procs}{$_}); + } + $dmp .= "\n"; + return $dmp; } # execute a DDL file $ddl for DataBase $db # ** not requiring db connection ** -sub xddl { - my ($db, $ddl) = @_; - my @qrs = qx(sqlite3 $db < $ddl); +sub xddl { + my ($db, $ddl) = @_; + my @qrs = qx(sqlite3 $db < $ddl); } 1; diff --git a/CODE/perl/lib/Dates.pm b/CODE/perl/lib/Dates.pm index 0bd5f3b9..ba6acd8f 100644 --- a/CODE/perl/lib/Dates.pm +++ b/CODE/perl/lib/Dates.pm @@ -44,7 +44,7 @@ use CGI::Cookie; # Find out if Calendar() can use Date::Calc or has to use our own hack our $HACK_DATE_CALC = 0 ; eval { require Date::Calc; }; -$HACK_DATE_CALC = 1 if (! $@) ; +$HACK_DATE_CALC = 1 if (! $@) ; =pod @@ -65,59 +65,61 @@ If it is not installed (ie. $HACK_DATE_CALC true), it computes the date with a s sub readFeries { - my $s; - - my %KWARGS = @_; - my $file = $KWARGS{conf} ? $KWARGS{conf} : $WEBOBS{FILE_DAYSOFF}; - my $year = $KWARGS{year} ? $KWARGS{year} : strftime('%Y',localtime()); - - my @data = (""); - my @feries = (""); - - # ---- Lecture du fichier de conf - open(FILE, "<$file") || die "readFeries couldn't open $file\n"; - while() { push(@data,l2u($_)); } - close(FILE); - - @data = grep(!/^(#|$)/, @data); - - my($pqy,$pqm,$pqd); - if ($HACK_DATE_CALC) { - eval { ($pqy,$pqm,$pqd)=Date::Calc::Easter_Sunday($year); }; - } else { - my $H = (19*($year%19) + int($year/100) - int($year/400) - int((8*int($year/100) + 13)/25) + 15)%30; - my $I = (int($H/28)*int(29/($H + 1)) * int((21 - $year%19)/11) - 1)*int($H/28) + $H; - my $J = (int($year/4) + $year + $I + 2 + int($year/400) - int($year/100))%7; - my $D = $I - $J; - ($pqy,$pqm,$pqd) = split(/\//,strftime('%Y/%m/%d',localtime(timelocal(0,0,0,28,2,$year-1900) + $D*86400))); # Easter Sunday - } - for (@data) { - my ($dt,$dn) = split(/\|/,$_); - chomp($dn); - if ($dt =~ /^\$Y-/) { - $dt =~ s/\$Y/$year/g; - $s=$dt; - # Easter Sunday (dimanche de Pâques) - } elsif ($dt =~ /^\$PQ /) { - $dt =~ s/\$PQ //g; - if ($HACK_DATE_CALC) { - eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Add_Delta_Days($pqy,$pqm,$pqd,$dt)); }; - } else { - $s = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$pqd,$pqm-1,$pqy-1900) + $dt*86400)); - } - # Nth weekday of the month (nième jour de la semaine dans le mois) - } elsif ($dt =~ /^\$NWM /) { - $dt =~ s/\$NWM //g; - my ($mm,$dw,$nn) = split(/ /,$dt); - if ($HACK_DATE_CALC) { - eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Nth_Weekday_of_Month_Year($year,$mm,$dw,$nn)); }; - } else { - $s = ""; - } - } - push(@feries,"$s|$dn"); - } - return @feries; + my $s; + + my %KWARGS = @_; + my $file = $KWARGS{conf} ? $KWARGS{conf} : $WEBOBS{FILE_DAYSOFF}; + my $year = $KWARGS{year} ? $KWARGS{year} : strftime('%Y',localtime()); + + my @data = (""); + my @feries = (""); + + # ---- Lecture du fichier de conf + open(FILE, "<$file") || die "readFeries couldn't open $file\n"; + while() { push(@data,l2u($_)); } + close(FILE); + + @data = grep(!/^(#|$)/, @data); + + my($pqy,$pqm,$pqd); + if ($HACK_DATE_CALC) { + eval { ($pqy,$pqm,$pqd)=Date::Calc::Easter_Sunday($year); }; + } else { + my $H = (19*($year%19) + int($year/100) - int($year/400) - int((8*int($year/100) + 13)/25) + 15)%30; + my $I = (int($H/28)*int(29/($H + 1)) * int((21 - $year%19)/11) - 1)*int($H/28) + $H; + my $J = (int($year/4) + $year + $I + 2 + int($year/400) - int($year/100))%7; + my $D = $I - $J; + ($pqy,$pqm,$pqd) = split(/\//,strftime('%Y/%m/%d',localtime(timelocal(0,0,0,28,2,$year-1900) + $D*86400))); # Easter Sunday + } + for (@data) { + my ($dt,$dn) = split(/\|/,$_); + chomp($dn); + if ($dt =~ /^\$Y-/) { + $dt =~ s/\$Y/$year/g; + $s=$dt; + + # Easter Sunday (dimanche de Pâques) + } elsif ($dt =~ /^\$PQ /) { + $dt =~ s/\$PQ //g; + if ($HACK_DATE_CALC) { + eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Add_Delta_Days($pqy,$pqm,$pqd,$dt)); }; + } else { + $s = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$pqd,$pqm-1,$pqy-1900) + $dt*86400)); + } + + # Nth weekday of the month (nième jour de la semaine dans le mois) + } elsif ($dt =~ /^\$NWM /) { + $dt =~ s/\$NWM //g; + my ($mm,$dw,$nn) = split(/ /,$dt); + if ($HACK_DATE_CALC) { + eval { $s = sprintf("%04d-%02d-%02d",Date::Calc::Nth_Weekday_of_Month_Year($year,$mm,$dw,$nn)); }; + } else { + $s = ""; + } + } + push(@feries,"$s|$dn"); + } + return @feries; } =pod @@ -134,63 +136,66 @@ eg. @calhtml = WebObs::Dates::Calendar(month=>'2012-12',ptri=>'Calendar',today=> sub Calendar { - my @tod = localtime(); - my %HEBDO = readCfg("$WEBOBS{HEBDO_CONF}"); - my %KWARGS = @_; - my $moisCalendrier = $KWARGS{month} ? $KWARGS{month} : strftime('%Y-%m',@tod); - my $parametreTri = $KWARGS{ptri} ? $KWARGS{ptri} : $HEBDO{DEFAULT_TRI}; - my $todayDate = $KWARGS{today} ? $KWARGS{today} : strftime('%Y-%m-%d',@tod); - my (@contenu,$j,$s); - - my $anneeCalendrier = substr($moisCalendrier,0,4); - my @feries = readFeries(year=>$anneeCalendrier); - my $displayMoisCalendrier = l2u(qx(date -d "$moisCalendrier-01" +"\%B \%Y")); chomp($displayMoisCalendrier); - my $moisPrecedent = qx(date -d "$moisCalendrier-01 1 month ago" +"\%Y-\%m"); - my $moisSuivant = qx(date -d "$moisCalendrier-01 1 month" +"\%Y-\%m"); - my $lundiCalendrier = WebObs::Dates::lundi("$moisCalendrier-01"); - - push(@contenu," + my @tod = localtime(); + my %HEBDO = readCfg("$WEBOBS{HEBDO_CONF}"); + my %KWARGS = @_; + my $moisCalendrier = $KWARGS{month} ? $KWARGS{month} : strftime('%Y-%m',@tod); + my $parametreTri = $KWARGS{ptri} ? $KWARGS{ptri} : $HEBDO{DEFAULT_TRI}; + my $todayDate = $KWARGS{today} ? $KWARGS{today} : strftime('%Y-%m-%d',@tod); + my (@contenu,$j,$s); + + my $anneeCalendrier = substr($moisCalendrier,0,4); + my @feries = readFeries(year=>$anneeCalendrier); + my $displayMoisCalendrier = l2u(qx(date -d "$moisCalendrier-01" +"\%B \%Y")); chomp($displayMoisCalendrier); + my $moisPrecedent = qx(date -d "$moisCalendrier-01 1 month ago" +"\%Y-\%m"); + my $moisSuivant = qx(date -d "$moisCalendrier-01 1 month" +"\%Y-\%m"); + my $lundiCalendrier = WebObs::Dates::lundi("$moisCalendrier-01"); + + push(@contenu,"
        \n"); - push(@contenu,""); - # il faut balayer 6 semaines pour être sûr d'avoir le mois complet dans toutes les situations... - for (0..41) { - $j = qx(date -I -d "$lundiCalendrier $_ days"); chomp($j); - if (($_ % 7) == 0) { - if (($_ != 0) && (substr($j,5,2) ne substr($moisCalendrier,5,2))) { - last; - } else { - #$s = qx(date -d "$j" +"\%W"); chomp($s); - # permet de choisir le n° semaine suivant l'année du calendrier (dernière semaine Y ou première semaine Y+1) - if (substr($j,0,4) != $anneeCalendrier) { $s = qx(date -d "$j 6 days" +%V); } - else { $s = qx(date -d "$j" +%V); } - chomp($s); - #push(@contenu,"\n"); - push(@contenu,"\n"); - } - } - if (substr($j,5,2) ne substr($moisCalendrier,5,2)) { - $s = "class=\"CalendarOutMonth\""; - } else { - $s = "class=\"CalendarInMonth\""; - if (($_%7) >= 5) { $s = "class=\"CalendarWeekend\""; } - my @jf = grep(/$j/,@feries); - if (@jf and length($jf[0]) > 0) { - my ($dd,$ss) = split(/\|/,$jf[0]); - chomp($ss); - $ss =~ s/\'/’/g; - $ss =~ s/\"/"/g; - $s = "class=\"CalendarFerie\" onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\""; - } - } - if ($j eq $todayDate) { $s = "class=\"CalendarToday\""; } - push(@contenu,""); - } - push(@contenu,"
        ⇐ $displayMoisCalendrier ⇒
        ".join("",split(/,/,"$__{'hebdo_weekday_first_letter'}"))."
        $s
        $s".sprintf("%1.0f",substr($j,8,2))."
        "); - - return @contenu; + push(@contenu,"
        		".join("",split(/,/,"$__{'hebdo_weekday_first_letter'}"))."
        $s
        $s".sprintf("%1.0f",substr($j,8,2))."
        "); + + return @contenu; } =pod @@ -207,59 +212,59 @@ Newer version of Calendar function. =cut sub DCalendar { - my @tod = localtime(); - my %KWARGS = @_; - my ($nowY, $nowM, $nowD) = split(/ /,strftime('%Y %m %d',@tod)); - my ($YY, $MM, $DD) = $KWARGS{month} ? split(/-/,"$KWARGS{month}-01") : ($nowY, $nowM, $nowD ); - my $url = $KWARGS{url} ? $KWARGS{url} : ""; - my @feries = readFeries(year=>$YY); - my (@html,$w); - - my $DOW1 = qx(date -d "$YY-$MM-01" +'%u'); chomp($DOW1); - my $nextM = ($MM == 12) ? 1 : sprintf("%02d",$MM+1); my $nextY = $YY+1 ; - my $prevM = ($MM == 1) ? 12 : sprintf("%02d",$MM-1); my $prevY = $YY-1 ; - my $days = qx(date -d "$nextY-$nextM-1 yesterday" +'%d'); chomp($days); - my $th1 = qx(date -d "$YY-$MM-01" '+%b %Y'); chomp($th1); - my $th2 = qx(locale -k LC_TIME | awk 'BEGIN {FS=";"} /^abday=/ { for(i=2;i<=7;i++){ printf "%2.2s ",\$i}; printf "%2.2s",substr(\$1,8,2)}') ; - chomp($th2); - - push(@html,"\n"); - push(@html,"\n"); - - $w = qx(date -d "$YY-$MM-01" +'%-V'); chomp($w); - push(@html,sprintf("
        «"); - push(@html,"‹$th1"); - push(@html,"›»
        $th2
        %02d",$w,$w)); - - for (my $ix = 1; $ix <= $DOW1-1; $ix++) { push(@html,"") } - - my $ixW = $DOW1; my $ixM = 1; - while ( $ixM <= $days ) { - my $class=""; my $hattr=""; - my $aDay = sprintf("$YY-$MM-%02s",$ixM); - if ( $aDay eq "$nowY-$nowM-$nowD" ) { $class .= "today " } - if (($ixW%8) >= 6) { $class .= "SD "; } - my @jf = grep(/$aDay/,@feries); - if (@jf and length($jf[0]) > 0) { - my ($dd,$ss) = split(/\|/,$jf[0]); chomp($ss); - $ss =~ s/\'/’/g; $ss =~ s/\"/"/g; - $class .= "off "; - $hattr = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\" "; - } - - push(@html,sprintf("%2d",$class,$hattr,$ixM)); - if ( ++$ixM <= $days ) { - if ( $ixW >= 7 ) { - $w = qx(date -d "$YY-$MM-$ixM" +'%-V'); chomp($w); - push(@html,sprintf("\n
        %02d ",$w,$w)); - $ixW = 0; - } - } - $ixW++; - } - for (my $ix = 1; $ix <= 8-$ixW; $ix++) { push(@html,"") } - push(@html,"
        "); - return @html; + my @tod = localtime(); + my %KWARGS = @_; + my ($nowY, $nowM, $nowD) = split(/ /,strftime('%Y %m %d',@tod)); + my ($YY, $MM, $DD) = $KWARGS{month} ? split(/-/,"$KWARGS{month}-01") : ($nowY, $nowM, $nowD ); + my $url = $KWARGS{url} ? $KWARGS{url} : ""; + my @feries = readFeries(year=>$YY); + my (@html,$w); + + my $DOW1 = qx(date -d "$YY-$MM-01" +'%u'); chomp($DOW1); + my $nextM = ($MM == 12) ? 1 : sprintf("%02d",$MM+1); my $nextY = $YY+1 ; + my $prevM = ($MM == 1) ? 12 : sprintf("%02d",$MM-1); my $prevY = $YY-1 ; + my $days = qx(date -d "$nextY-$nextM-1 yesterday" +'%d'); chomp($days); + my $th1 = qx(date -d "$YY-$MM-01" '+%b %Y'); chomp($th1); + my $th2 = qx(locale -k LC_TIME | awk 'BEGIN {FS=";"} /^abday=/ { for(i=2;i<=7;i++){ printf "%2.2s ",\$i}; printf "%2.2s",substr(\$1,8,2)}') ; + chomp($th2); + + push(@html,"\n"); + push(@html,"\n"); + + $w = qx(date -d "$YY-$MM-01" +'%-V'); chomp($w); + push(@html,sprintf("
        «"); + push(@html,"‹$th1"); + push(@html,"›»
        $th2
        %02d",$w,$w)); + + for (my $ix = 1; $ix <= $DOW1-1; $ix++) { push(@html,"") } + + my $ixW = $DOW1; my $ixM = 1; + while ( $ixM <= $days ) { + my $class=""; my $hattr=""; + my $aDay = sprintf("$YY-$MM-%02s",$ixM); + if ( $aDay eq "$nowY-$nowM-$nowD" ) { $class .= "today " } + if (($ixW%8) >= 6) { $class .= "SD "; } + my @jf = grep(/$aDay/,@feries); + if (@jf and length($jf[0]) > 0) { + my ($dd,$ss) = split(/\|/,$jf[0]); chomp($ss); + $ss =~ s/\'/’/g; $ss =~ s/\"/"/g; + $class .= "off "; + $hattr = "onMouseOut=\"nd()\" onMouseOver=\"overlib('$__{Holiday}: $ss')\" "; + } + + push(@html,sprintf("%2d",$class,$hattr,$ixM)); + if ( ++$ixM <= $days ) { + if ( $ixW >= 7 ) { + $w = qx(date -d "$YY-$MM-$ixM" +'%-V'); chomp($w); + push(@html,sprintf("\n
        %02d ",$w,$w)); + $ixW = 0; + } + } + $ixW++; + } + for (my $ix = 1; $ix <= 8-$ixW; $ix++) { push(@html,"") } + push(@html,"
        "); + return @html; } #fixJul added ymdhms2s @@ -282,19 +287,19 @@ eg. $secs = WebObs::Dates::ymdhms2s('2012-09-15 10:25:02') # secs = 1347697502 =cut -sub ymdhms2s +sub ymdhms2s { - my($s) = @_; - my($year, $month, $day, $hour, $minute, $second); - - if ($s =~ m{^\s*(\d{1,4})\W*0*(\d{1,2})\W*0*(\d{1,2})\W*0*(\d{0,2})\W*0*(\d{0,2})\W*0*(\d{0,2})}x) { - $year = $1; $month = $2; $day = $3; - $hour = $4; $minute = $5; $second = $6; - $hour ||= 0; $minute ||= 0; $second ||= 0; # default hms = 00:00:00 - $year = ($year<100 ? ($year<70 ? 2000+$year : 1900+$year) : $year); - return timelocal($second,$minute,$hour,$day,$month-1,$year); - } - return -1; + my($s) = @_; + my($year, $month, $day, $hour, $minute, $second); + + if ($s =~ m{^\s*(\d{1,4})\W*0*(\d{1,2})\W*0*(\d{1,2})\W*0*(\d{0,2})\W*0*(\d{0,2})\W*0*(\d{0,2})}x) { + $year = $1; $month = $2; $day = $3; + $hour = $4; $minute = $5; $second = $6; + $hour ||= 0; $minute ||= 0; $second ||= 0; # default hms = 00:00:00 + $year = ($year<100 ? ($year<70 ? 2000+$year : 1900+$year) : $year); + return timelocal($second,$minute,$hour,$day,$month-1,$year); + } + return -1; } =pod @@ -309,14 +314,14 @@ eg. $monday = lundi('2012-09-14'); # $monday = 2012-09-10 sub lundi { - my ($y,$m,$d) = split(/[-\/]/,shift); - - my $j = strftime('%w',0,0,0,$d,$m-1,$y-1900); - $j = ($j+6)%7; - my $lundi = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$d,$m-1,$y-1900) - $j*86400)); - chomp($lundi); - - return $lundi; + my ($y,$m,$d) = split(/[-\/]/,shift); + + my $j = strftime('%w',0,0,0,$d,$m-1,$y-1900); + $j = ($j+6)%7; + my $lundi = strftime('%Y-%m-%d',localtime(timelocal(0,0,0,$d,$m-1,$y-1900) - $j*86400)); + chomp($lundi); + + return $lundi; } =pod @@ -326,18 +331,18 @@ sub lundi =cut sub weton { - my ($year,$month,$day) = split(/-/,shift); - - my @pasaran = ('Pon','Wagé','Kliwon','Legi','Pahing'); - my @minggu = ('Senèn','Selasa','Rebo','Kemis','Jemuwah','Setu','Akad'); - - my $sec = strftime('%s',0,0,0,$day,$month-1,$year-1900) - strftime('%s',0,0,0,1,0,70); - my $ndays = int($sec/86400) + 3500*35; - my $p = ($ndays+1)%5; - my $m = ($ndays+3)%7; - - #return l2u(sprintf("%s %s",$minggu[$m],$pasaran[$p])); - return sprintf("%s %s",$minggu[$m],$pasaran[$p]); + my ($year,$month,$day) = split(/-/,shift); + + my @pasaran = ('Pon','Wagé','Kliwon','Legi','Pahing'); + my @minggu = ('Senèn','Selasa','Rebo','Kemis','Jemuwah','Setu','Akad'); + + my $sec = strftime('%s',0,0,0,$day,$month-1,$year-1900) - strftime('%s',0,0,0,1,0,70); + my $ndays = int($sec/86400) + 3500*35; + my $p = ($ndays+1)%5; + my $m = ($ndays+3)%7; + + #return l2u(sprintf("%s %s",$minggu[$m],$pasaran[$p])); + return sprintf("%s %s",$minggu[$m],$pasaran[$p]); } 1; diff --git a/CODE/perl/lib/Events.pm b/CODE/perl/lib/Events.pm index 15685ad9..b77e63e4 100644 --- a/CODE/perl/lib/Events.pm +++ b/CODE/perl/lib/Events.pm @@ -104,13 +104,13 @@ NOTE: nodename will be made equals to gridname for normalized grids. =cut sub struct { - return undef if (@_ != 1); - my @obj = split(/\./,$_[0]); - return ($obj[0],$obj[1],$obj[2],"$NODES{PATH_NODES}/$obj[2]/$NODES{SPATH_INTERVENTIONS}","$NODES{PATH_EVENTNODE_TRASH}","N") if ($#obj == 2); - if (defined($GRIDS{PATH_GRIDS}) && $#obj == 1) { - return ($obj[0],$obj[1],$obj[1],"$GRIDS{PATH_GRIDS}/$obj[0]/$obj[1]/$GRIDS{SPATH_INTERVENTIONS}","$GRIDS{PATH_EVENTGRID_TRASH}","G"); - } - return undef; + return undef if (@_ != 1); + my @obj = split(/\./,$_[0]); + return ($obj[0],$obj[1],$obj[2],"$NODES{PATH_NODES}/$obj[2]/$NODES{SPATH_INTERVENTIONS}","$NODES{PATH_EVENTNODE_TRASH}","N") if ($#obj == 2); + if (defined($GRIDS{PATH_GRIDS}) && $#obj == 1) { + return ($obj[0],$obj[1],$obj[1],"$GRIDS{PATH_GRIDS}/$obj[0]/$obj[1]/$GRIDS{SPATH_INTERVENTIONS}","$GRIDS{PATH_EVENTGRID_TRASH}","G"); + } + return undef; } # ------------------------------------------------------------------------------------------- @@ -129,18 +129,19 @@ eventnameSplit(eventname) decodes event name string and returns an array of elem =cut sub eventnameSplit { - # grid name might contain '_' so reads date and time by splitting '-' first - my @pn = split(/-/,$_[0]); # object_year month day_hour minute_version - my @p1 = split(/_/,$pn[0]); - my @p2 = split(/_/,$pn[2]); - my @p3 = split(/_/,$pn[3]); - my $obj = join('_',$p1[0 .. $#p1-1]); - my $date = "$p1[$#p1]-$pn[1]-$p2[0]"; - my $time = "$p2[1]:$p3[0]"; - $time =~ s/NA//; - my $ver = ($#p3 > 0 ? $p3[1]:""); - - return ($obj,$date,$time,$ver); + + # grid name might contain '_' so reads date and time by splitting '-' first + my @pn = split(/-/,$_[0]); # object_year month day_hour minute_version + my @p1 = split(/_/,$pn[0]); + my @p2 = split(/_/,$pn[2]); + my @p3 = split(/_/,$pn[3]); + my $obj = join('_',$p1[0 .. $#p1-1]); + my $date = "$p1[$#p1]-$pn[1]-$p2[0]"; + my $time = "$p2[1]:$p3[0]"; + $time =~ s/NA//; + my $ver = ($#p3 > 0 ? $p3[1]:""); + + return ($obj,$date,$time,$ver); } # ------------------------------------------------------------------------------------------- @@ -164,28 +165,29 @@ headersplit(header) decodes header string and returns an array of elements: =cut sub headersplit { - my ($title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = ""; - # event metadata are stored in the header line of file as pipe-separated fields: - # UID1[+UID2+...][/RUID1[+RUID2+...]]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd - my $pipes = $_[0] =~ tr/\|//; # count the number of pipes in header - my @header = split(/\|/,$_[0]); # splits pipe-separated arguments - my @people = split(/\//,$header[0]); # splits authors and remotes (forward slash separator) - my @UIDs = split(/\+/,$people[0]); # array of authors - my @RUIDs = split(/\+/,$people[1]) if ($#people > 0); # array of remotes - if ($pipes > 1 && $pipes < 6) { - $title = join("\|",@header[1..$#header]); # rare case of a former header with unescaped pipe in the title... - } else { - $title = $header[1] if ($#header > 0); - ($date2,$time2) = split(/ /,$header[2]) if ($#header > 1); - $feature = $header[3] if ($#header > 2); - $channel = $header[4] if ($#header > 3); - $outcome = $header[5] if ($#header > 4); - $notebook = $header[6] if ($#header > 5); - $notebookfwd = $header[7] if ($#header > 6); - } - $title =~ s/\"/\'\'/g; - - return (\@UIDs,\@RUIDs,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd); + my ($title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = ""; + +# event metadata are stored in the header line of file as pipe-separated fields: +# UID1[+UID2+...][/RUID1[+RUID2+...]]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd + my $pipes = $_[0] =~ tr/\|//; # count the number of pipes in header + my @header = split(/\|/,$_[0]); # splits pipe-separated arguments + my @people = split(/\//,$header[0]); # splits authors and remotes (forward slash separator) + my @UIDs = split(/\+/,$people[0]); # array of authors + my @RUIDs = split(/\+/,$people[1]) if ($#people > 0); # array of remotes + if ($pipes > 1 && $pipes < 6) { + $title = join("\|",@header[1..$#header]); # rare case of a former header with unescaped pipe in the title... + } else { + $title = $header[1] if ($#header > 0); + ($date2,$time2) = split(/ /,$header[2]) if ($#header > 1); + $feature = $header[3] if ($#header > 2); + $channel = $header[4] if ($#header > 3); + $outcome = $header[5] if ($#header > 4); + $notebook = $header[6] if ($#header > 5); + $notebookfwd = $header[7] if ($#header > 6); + } + $title =~ s/\"/\'\'/g; + + return (\@UIDs,\@RUIDs,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd); } # ------------------------------------------------------------------------------------------- @@ -207,18 +209,19 @@ sorted by descending dates. =cut sub eventsTree { - return if (@_ != 2) ; - my ($list, $path) = @_; - return if(ref($list) ne 'ARRAY'); - my @entries = sort {$b cmp $a} glob($path."/*"); - foreach my $entry (@entries) { - next if ($entry =~ /_Projet\.txt$|.*\.txt~$|.*backup$/); - next if ($entry =~ /\/PHOTOS\//); - #DL-err5.10: push($list, $entry) if -f $entry; - push(@$list, $entry) if -f $entry; - eventsTree($list, $entry) if -d $entry; - } - return; + return if (@_ != 2) ; + my ($list, $path) = @_; + return if(ref($list) ne 'ARRAY'); + my @entries = sort {$b cmp $a} glob($path."/*"); + foreach my $entry (@entries) { + next if ($entry =~ /_Projet\.txt$|.*\.txt~$|.*backup$/); + next if ($entry =~ /\/PHOTOS\//); + + #DL-err5.10: push($list, $entry) if -f $entry; + push(@$list, $entry) if -f $entry; + eventsTree($list, $entry) if -d $entry; + } + return; } # ------------------------------------------------------------------------------------------- @@ -239,14 +242,15 @@ eventsChrono(list, path) appends to list the sorted (dates descending) events fi =cut sub eventsChrono { - return if (@_ != 2) ; - my ($list, $path) = @_; - return if(ref($list) ne 'ARRAY'); - my @tree; - eventsTree(\@tree, $path); - #DL-err5.10: map { push($list,$_) } sort {basename($b) cmp basename($a)} @tree; - map { push(@$list,$_) } sort {basename($b) cmp basename($a)} @tree; - return; + return if (@_ != 2) ; + my ($list, $path) = @_; + return if(ref($list) ne 'ARRAY'); + my @tree; + eventsTree(\@tree, $path); + + #DL-err5.10: map { push($list,$_) } sort {basename($b) cmp basename($a)} @tree; + map { push(@$list,$_) } sort {basename($b) cmp basename($a)} @tree; + return; } # ------------------------------------------------------------------------------------------- @@ -263,12 +267,12 @@ countProject is an alias for existProject. =cut sub existProject { - return 0 if (@_ != 1); - my ($gt,$gn,$n,$p,$t) = struct($_[0]); - if (defined($p)) { - return 1 if (-e "$p/$n\_Projet.txt"); - } - return 0; + return 0 if (@_ != 1); + my ($gt,$gn,$n,$p,$t) = struct($_[0]); + if (defined($p)) { + return 1 if (-e "$p/$n\_Projet.txt"); + } + return 0; } sub countProject { return existProject(@_) } @@ -286,12 +290,12 @@ countEvents is an alias for existEvents. =cut sub existEvents { - return 0 if (@_ != 1); - my ($gt,$gn,$n,$p,$t) = struct($_[0]); - if (defined($p)) { - return qx(/usr/bin/find $p -name "$n*.txt" 2>/dev/null | wc -l); - } - return 0; + return 0 if (@_ != 1); + my ($gt,$gn,$n,$p,$t) = struct($_[0]); + if (defined($p)) { + return qx(/usr/bin/find $p -name "$n*.txt" 2>/dev/null | wc -l); + } + return 0; } sub countEvents { return existEvents(@_) } @@ -311,96 +315,101 @@ editYN indicates wether current viewing client has authorization to edit events =cut sub eventsShow { - return undef if (@_ != 3); - my ($sortedBy, $objectname, $editOK) = @_; - return undef if ($sortedBy !~ /events|date|feature/i); - - my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); - return undef if (!defined($GRIDType)); - my $html = ''; - my @list; - - eventsTree(\@list, $path) if ($sortedBy =~ /events/i); - eventsChrono(\@list, $path) if ($sortedBy =~ /date|feature/i); - - $html .= "
          \n"; - my $currentIndent = 0; - for my $evt (@list) { - (my $relevt = $evt) =~ s/$path\/// ; # evt = full path to event file; relevt = relative path to event file - (my $extevt = $evt) =~ s/\.txt//; # extevt = full path to event extensions directory - (my $relextevt = $extevt) =~ s/$path\/// ; # relextevt = relative path to event extensions directory - #my ($obj,$date,$time,$ver) = split(/_/,basename($extevt)); + return undef if (@_ != 3); + my ($sortedBy, $objectname, $editOK) = @_; + return undef if ($sortedBy !~ /events|date|feature/i); + + my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); + return undef if (!defined($GRIDType)); + my $html = ''; + my @list; + + eventsTree(\@list, $path) if ($sortedBy =~ /events/i); + eventsChrono(\@list, $path) if ($sortedBy =~ /date|feature/i); + + $html .= "
            \n"; + my $currentIndent = 0; + for my $evt (@list) { + (my $relevt = $evt) =~ s/$path\/// ; # evt = full path to event file; relevt = relative path to event file + (my $extevt = $evt) =~ s/\.txt//; # extevt = full path to event extensions directory + (my $relextevt = $extevt) =~ s/$path\/// ; # relextevt = relative path to event extensions directory + + #my ($obj,$date,$time,$ver) = split(/_/,basename($extevt)); # grid name might contain '_' so reads date and time by splitting '-' - my ($obj,$date,$time,$ver) = eventnameSplit(basename($extevt)); - - my @file = readFile($evt); - #DL-beforeMMD # ignore blank lines and LF - #DL-beforeMMD @file = grep(!/^$/, @file); - #DL-beforeMMD chomp(@file); - - # first line = usersList|title with usersList = a + separated list of userIds, and optional |title - if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' - unshift(@file,"|untitled\n"); # force our own default (add a line) - } - my ($author,$remote,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = headersplit($file[0]); - my @authors = @$author; - my @remotes = @$remote; - my $EVTusers = join(", ",WebObs::Users::userName(@authors)); - my $EVTroper = join(", ",WebObs::Users::userName(@remotes)); - if ($EVTusers ne "" || $EVTroper ne "") { - $EVTusers = "(".($EVTusers ne "" ? $EVTusers:"").($EVTroper ne "" ? " / $EVTroper":"").")"; - } - my $EVTtitle = "".ucfirst($title).""; - my $EVTdate = "$date $time".($date eq $date2 ? ($time eq $time2 || $time2 eq "" ? "":" → $time2"):" → $date2 $time2"); - #my $EVTver = (defined($ver)) ? " v$ver" : ""; - my $EVToutcome = ($outcome > 0 ? "":""); - my $EVTinfo = ucfirst($feature); - $EVTinfo .= ($channel ne "" ? " • $__{Channel} $channel":""); - $EVTinfo .= ($notebook > 0 ? " • $__{Notebook} # $notebook".($notebookfwd > 0 ? " ($__{forward})":""):""); - - # remaining lines = event text contents - shift(@file); - #DL-beforeMMD my $EVTtext = wiki2html(join("\n",@file)); - my $EVTtext = wiki2html(join("",@file)); - - # event's photos if any - my $direvtphotos = $extevt."/PHOTOS"; - my @photos = qx(/usr/bin/find $direvtphotos -maxdepth 1 -type f 2>/dev/null); - chomp(@photos); - my $EVTphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; - - # event's edit icons - my $EVTedit = ""; - if ($editOK) { - $EVTedit .= "\"$__{'Edit...'}\""; - $EVTedit .= "\"$__{'Remove...'}\""; - $EVTedit .= " \"$__{'Manage"; - $EVTedit .= " \"$__{'Add"; - } - - # indent this event in "events" list - if ($sortedBy =~ /events/i) { - my $thisLevel = ($relevt =~ tr/\///); # count "/"s - if ($thisLevel > $currentIndent) { - for (1..($thisLevel-$currentIndent)) { $html .= "
              \n"; $currentIndent++ } - } elsif ($thisLevel < $currentIndent) { - for (1..($currentIndent-$thisLevel)) { $html .= "
            \n"; $currentIndent-- } - } - } - - # event header - $html .= ""; - $html .= "

          • "; - $html .= "$EVTdate $EVTtitle $EVTusers " if ($sortedBy =~ /date|feature/i); - $html .= "$EVTtitle $EVTdate $EVTusers " if ($sortedBy =~ /events/i); - $html .= "$EVToutcome $EVTedit

            \n"; - # event body - $html .= "

            ".parents($path,$relextevt)."

            \n"; - $html .= "

            $EVTinfo

            \n" if ($EVTinfo ne ""); - $html .= "
            $EVTphotos$EVTtext
            • \n"; - } - $html .= "
          \n"; - return $html; + my ($obj,$date,$time,$ver) = eventnameSplit(basename($extevt)); + + my @file = readFile($evt); + + #DL-beforeMMD # ignore blank lines and LF + #DL-beforeMMD @file = grep(!/^$/, @file); + #DL-beforeMMD chomp(@file); + +# first line = usersList|title with usersList = a + separated list of userIds, and optional |title + if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' + unshift(@file,"|untitled\n"); # force our own default (add a line) + } + my ($author,$remote,$title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = headersplit($file[0]); + my @authors = @$author; + my @remotes = @$remote; + my $EVTusers = join(", ",WebObs::Users::userName(@authors)); + my $EVTroper = join(", ",WebObs::Users::userName(@remotes)); + if ($EVTusers ne "" || $EVTroper ne "") { + $EVTusers = "(".($EVTusers ne "" ? $EVTusers:"").($EVTroper ne "" ? " / $EVTroper":"").")"; + } + my $EVTtitle = "".ucfirst($title).""; + my $EVTdate = "$date $time".($date eq $date2 ? ($time eq $time2 || $time2 eq "" ? "":" → $time2"):" → $date2 $time2"); + + #my $EVTver = (defined($ver)) ? " v$ver" : ""; + my $EVToutcome = ($outcome > 0 ? "":""); + my $EVTinfo = ucfirst($feature); + $EVTinfo .= ($channel ne "" ? " • $__{Channel} $channel":""); + $EVTinfo .= ($notebook > 0 ? " • $__{Notebook} # $notebook".($notebookfwd > 0 ? " ($__{forward})":""):""); + + # remaining lines = event text contents + shift(@file); + + #DL-beforeMMD my $EVTtext = wiki2html(join("\n",@file)); + my $EVTtext = wiki2html(join("",@file)); + + # event's photos if any + my $direvtphotos = $extevt."/PHOTOS"; + my @photos = qx(/usr/bin/find $direvtphotos -maxdepth 1 -type f 2>/dev/null); + chomp(@photos); + my $EVTphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; + + # event's edit icons + my $EVTedit = ""; + if ($editOK) { + $EVTedit .= "\"$__{'Edit...'}\""; + $EVTedit .= "\"$__{'Remove...'}\""; + $EVTedit .= " \"$__{'Manage"; + $EVTedit .= " \"$__{'Add"; + } + + # indent this event in "events" list + if ($sortedBy =~ /events/i) { + my $thisLevel = ($relevt =~ tr/\///); # count "/"s + if ($thisLevel > $currentIndent) { + for (1..($thisLevel-$currentIndent)) { $html .= "
            \n"; $currentIndent++ } + } elsif ($thisLevel < $currentIndent) { + for (1..($currentIndent-$thisLevel)) { $html .= "
          \n"; $currentIndent-- } + } + } + + # event header + $html .= ""; + $html .= "

        • "; + $html .= "$EVTdate $EVTtitle $EVTusers " if ($sortedBy =~ /date|feature/i); + $html .= "$EVTtitle $EVTdate $EVTusers " if ($sortedBy =~ /events/i); + $html .= "$EVToutcome $EVTedit

          \n"; + + # event body + $html .= "

          ".parents($path,$relextevt)."

          \n"; + $html .= "

          $EVTinfo

          \n" if ($EVTinfo ne ""); + $html .= "
          $EVTphotos$EVTtext
          • \n"; + } + $html .= "
        \n"; + return $html; } # ------------------------------------------------------------------------------------------- @@ -417,53 +426,53 @@ editYN indicates wether current viewing client has authorization to edit Project =cut sub projectShow { - return undef if (@_ != 2); - my ($objectname, $editOK) = @_; - - my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); - return undef if (!defined($GRIDType)); - my $projdir = "$NODEName\_Projet" ; - my $projphotos = "$path/$projdir/PHOTOS" ; - my $projname = "$projdir.txt"; - my $projpath = "$path/$projname"; - - my $html = ''; - if (-e $projpath) { - my $Pts = Time::Piece->strptime((stat($projpath))[9],"%s"); - my @file = readFile($projpath); - chomp(@file); - - # first line = usersList|title with usersList = a + separated list of userIds, and optional |title - if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' - unshift(@file,"|untitled\n"); # force our own default (add a line) - } - my @firstline = split(/\|/,$file[0]); - my @users = split(/\+/,$firstline[0]); - my $Pusers = join(", ",WebObs::Users::userName(@users)); - my $Ptitle = ($#firstline > 0) ? ucfirst($firstline[1]) : "NA" ; - - # remaining lines = event text contents - shift(@file); - my $Ptext = wiki2html(join("\n",@file)); - - # event's photos if any - my @photos = qx(/usr/bin/find $projphotos -maxdepth 1 -type f 2>/dev/null); - chomp(@photos); - my $Pphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; - - my $Pedit = ""; - if ($editOK) { - $Pedit .= "\"$__{'Edit...'}\""; - $Pedit .= "\"$__{'Remove...'}\""; - $Pedit .= "\"$__{'Manage"; - } - my $Pfts = $Pts->strftime("%Y-%m-%d %H:%M"); - $html .= "
        "; - $html .= "

        $Ptitle".($Pusers ne "" ? " ($Pusers)":"")." modified:$Pfts $Pedit

        \n"; - $html .= "
        $Pphotos$Ptext
        "; - $html .= "
        "; - } - return $html; + return undef if (@_ != 2); + my ($objectname, $editOK) = @_; + + my ($GRIDType, $GRIDName, $NODEName, $path, $trash) = struct($objectname); + return undef if (!defined($GRIDType)); + my $projdir = "$NODEName\_Projet" ; + my $projphotos = "$path/$projdir/PHOTOS" ; + my $projname = "$projdir.txt"; + my $projpath = "$path/$projname"; + + my $html = ''; + if (-e $projpath) { + my $Pts = Time::Piece->strptime((stat($projpath))[9],"%s"); + my @file = readFile($projpath); + chomp(@file); + +# first line = usersList|title with usersList = a + separated list of userIds, and optional |title + if ($file[0] !~ /\|/) { # if firstline doesn't look like 'something|someotherthing' + unshift(@file,"|untitled\n"); # force our own default (add a line) + } + my @firstline = split(/\|/,$file[0]); + my @users = split(/\+/,$firstline[0]); + my $Pusers = join(", ",WebObs::Users::userName(@users)); + my $Ptitle = ($#firstline > 0) ? ucfirst($firstline[1]) : "NA" ; + + # remaining lines = event text contents + shift(@file); + my $Ptext = wiki2html(join("\n",@file)); + + # event's photos if any + my @photos = qx(/usr/bin/find $projphotos -maxdepth 1 -type f 2>/dev/null); + chomp(@photos); + my $Pphotos = scalar(@photos) > 0 ? photoStrip(@photos) : ""; + + my $Pedit = ""; + if ($editOK) { + $Pedit .= "\"$__{'Edit...'}\""; + $Pedit .= "\"$__{'Remove...'}\""; + $Pedit .= "\"$__{'Manage"; + } + my $Pfts = $Pts->strftime("%Y-%m-%d %H:%M"); + $html .= "
        "; + $html .= "

        $Ptitle".($Pusers ne "" ? " ($Pusers)":"")." modified:$Pfts $Pedit

        \n"; + $html .= "
        $Pphotos$Ptext
        "; + $html .= "
        "; + } + return $html; } # ------------------------------------------------------------------------------------------- @@ -477,20 +486,20 @@ photoStrip(photo-files-list) returns the html string displaying thumbnails =cut sub photoStrip { - my $ret = "
        "; - foreach(@_) { - my ( $name, $path ) = fileparse ( $_ ); - (my $urnpath = $path) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $urnpath =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... - my $thumb = makeThumbnail( "$path/$name", "x$NODES{THUMBNAILS_PIXV}", "$path/THUMBNAILS","$NODES{THUMBNAILS_EXT}"); - if ( $thumb ne "" ) { - (my $turn = $thumb) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; - $turn =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... - my $olmsg = htmlspecialchars(__x("Click to enlarge
        Image={image}",image=>$name)); - $ret .= "\"".__x('Image$urnpath."/".$name)."\">\n"; - } - } - return $ret."
        "; + my $ret = "
        "; + foreach(@_) { + my ( $name, $path ) = fileparse ( $_ ); + (my $urnpath = $path) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $urnpath =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... + my $thumb = makeThumbnail( "$path/$name", "x$NODES{THUMBNAILS_PIXV}", "$path/THUMBNAILS","$NODES{THUMBNAILS_EXT}"); + if ( $thumb ne "" ) { + (my $turn = $thumb) =~ s/$NODES{PATH_NODES}/$WEBOBS{URN_NODES}/; + $turn =~ s/$WEBOBS{ROOT_DATA}/$WEBOBS{URN_DATA}/; # second pass for GRIDS... + my $olmsg = htmlspecialchars(__x("Click to enlarge
        Image={image}",image=>$name)); + $ret .= "\"".__x('Image$urnpath."/".$name)."\">\n"; + } + } + return $ret."
        "; } # ------------------------------------------------------------------------------------------- @@ -513,26 +522,26 @@ account for grids events as well as nodes events =cut sub parents { - my $html = ""; - if (@_ == 2) { - my ($path, $relextevt) = @_; - my @parents = split(/\//,$relextevt); - for (my $i=$#parents-1; $i>=0; $i--) { - my $f = "$path/".join("/",@parents[0..$i]).".txt"; - my ($s,$d,$h) = split(/_/,$parents[$i]); - $h =~ s/-/:/; - my $t = "???"; - if (-e $f) { - my @xx = readFile($f); - @xx = grep(!/^$/, @xx); - chomp(@xx); - my $o; - ($o,$t) = split(/\|/,$xx[0]); - } - $html .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; - } - } - return $html; + my $html = ""; + if (@_ == 2) { + my ($path, $relextevt) = @_; + my @parents = split(/\//,$relextevt); + for (my $i=$#parents-1; $i>=0; $i--) { + my $f = "$path/".join("/",@parents[0..$i]).".txt"; + my ($s,$d,$h) = split(/_/,$parents[$i]); + $h =~ s/-/:/; + my $t = "???"; + if (-e $f) { + my @xx = readFile($f); + @xx = grep(!/^$/, @xx); + chomp(@xx); + my $o; + ($o,$t) = split(/\|/,$xx[0]); + } + $html .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; + } + } + return $html; } # ------------------------------------------------------------------------------------------- @@ -553,25 +562,26 @@ a deleted event will overwrite a previously deleted one with the same name. =cut sub deleteit { - if (@_ == 3 && $_[2] =~ /.*\.txt$/) { - my ($evbase, $evtrash, $evpath) = @_; - qx(/bin/mkdir -p $evtrash 2>&1); # make sure root trash exists - qx(/bin/mv "$evbase/$evpath" "$evtrash/" 2>&1); - return "$__{'Could not move event to trash'} , $?" if ($? != 0); - $evpath =~ s/\.txt$//; # event extensions dir - my $evname = basename($evpath); # event extensions dir name - if (-e "$evbase/$evpath/") { - qx(mkdir -p "$evtrash/$evname/" 2>&1); - qx(/bin/mv "$evbase/$evpath/" "$evtrash/$evname/" 2>&1); - if ($? != 0) { - # extensions dir move failed, try reverting *txt move - # move $evname.txt -> back to $evbase/.../ - return "$__{'Could not move event extensions to trash'} , $?"; - } - } - return "OK"; - } - return "deleteit: $__{'invalid argument'}"; + if (@_ == 3 && $_[2] =~ /.*\.txt$/) { + my ($evbase, $evtrash, $evpath) = @_; + qx(/bin/mkdir -p $evtrash 2>&1); # make sure root trash exists + qx(/bin/mv "$evbase/$evpath" "$evtrash/" 2>&1); + return "$__{'Could not move event to trash'} , $?" if ($? != 0); + $evpath =~ s/\.txt$//; # event extensions dir + my $evname = basename($evpath); # event extensions dir name + if (-e "$evbase/$evpath/") { + qx(mkdir -p "$evtrash/$evname/" 2>&1); + qx(/bin/mv "$evbase/$evpath/" "$evtrash/$evname/" 2>&1); + if ($? != 0) { + + # extensions dir move failed, try reverting *txt move + # move $evname.txt -> back to $evbase/.../ + return "$__{'Could not move event extensions to trash'} , $?"; + } + } + return "OK"; + } + return "deleteit: $__{'invalid argument'}"; } # ------------------------------------------------------------------------------------------- @@ -591,16 +601,16 @@ eventfile = reference of the event full path name to be 'versioned' if needed. =cut sub versionit { - if (@_ == 1 && ref($_[0])eq "SCALAR") { - my $rf = $_[0]; - if (-e $$rf) { # if eventfile already exists - my ($n,$d,$s) = fileparse($$rf, qr/\.[^.]*/); - my @nx = split(/_/,$n); - my $nx = join('_',@nx[0..2]); - my @lst = qx(ls $d$nx\_*.txt 2>/dev/null); - $$rf = "$d$nx\_".(scalar(@lst)+1).".txt"; - } - } + if (@_ == 1 && ref($_[0])eq "SCALAR") { + my $rf = $_[0]; + if (-e $$rf) { # if eventfile already exists + my ($n,$d,$s) = fileparse($$rf, qr/\.[^.]*/); + my @nx = split(/_/,$n); + my $nx = join('_',@nx[0..2]); + my @lst = qx(ls $d$nx\_*.txt 2>/dev/null); + $$rf = "$d$nx\_".(scalar(@lst)+1).".txt"; + } + } } # ------------------------------------------------------------------------------------------- @@ -609,7 +619,6 @@ sub versionit { # @list = rev( ("a","b","c") ); # @list: ("c","b","a") sub rev { my @r; push @r, pop @_ while @_ ; return @r } - 1; __END__ diff --git a/CODE/perl/lib/Form.pm b/CODE/perl/lib/Form.pm index 3eb74c9e..ce706431 100644 --- a/CODE/perl/lib/Form.pm +++ b/CODE/perl/lib/Form.pm @@ -59,92 +59,92 @@ require Exporter; our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); @ISA = qw(Exporter); @EXPORT = qw(datetime2array datetime2maxmin - extract_formula extract_list extract_type extract_text count_inputs); + extract_formula extract_list extract_type extract_text count_inputs); # FORM constructor sub new { my ( $class, $Name ) = @_; - my $self = {}; + my $self = {}; die "Missing form name" if !defined($Name); - $self->{_name} = $Name; - - $self->{_path} = "$WEBOBS{PATH_FORMS}/$Name"; - die "No configuration found for FORM.$Name" if !(-e $self->{_path}."/$Name.conf"); - $self->{_conf} = { readCfg($self->{_path}."/$Name.conf") }; - $self->{_fnam} = "$WEBOBS{PATH_DATA_DB}/".$self->{_conf}{FILE_NAME}; - - opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); - my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; - for my $proc ( @Ps ) { - my %P = readProc($proc); - $self->{_procs}{$proc} = $P{$proc}{NAME} ; - } + $self->{_name} = $Name; + + $self->{_path} = "$WEBOBS{PATH_FORMS}/$Name"; + die "No configuration found for FORM.$Name" if !(-e $self->{_path}."/$Name.conf"); + $self->{_conf} = { readCfg($self->{_path}."/$Name.conf") }; + $self->{_fnam} = "$WEBOBS{PATH_DATA_DB}/".$self->{_conf}{FILE_NAME}; + + opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); + my @Ps = grep { s/\.$Name$//g && s/^PROC\.//g } readdir(DIR) ; + for my $proc ( @Ps ) { + my %P = readProc($proc); + $self->{_procs}{$proc} = $P{$proc}{NAME} ; + } closedir(DIR); - - bless $self, $class; + + bless $self, $class; return $self; } # get path to this FORM's configuration files sub path { - my ($self) = @_; - return $self->{_path}; + my ($self) = @_; + return $self->{_path}; } # get configuration parameter sub conf { - my ($self, $k) = @_; - return $self->{_conf}{$k} if (defined($k)); - return %{$self->{_conf}}; + my ($self, $k) = @_; + return $self->{_conf}{$k} if (defined($k)); + return %{$self->{_conf}}; } # get data (all or matching $id) for this FORM using WebObs::xreadFile sub data { - my ($self, $id) = @_; - my $fptr = 0; - my $fts = -1; - if (defined($id)) { - my $fid = qr/^$id\|/; - ($fptr,$fts) = xreadFile($self->{_fnam}, $fid); - } else { - ($fptr,$fts) = xreadFile($self->{_fnam}); - } - return ($fptr, $fts); + my ($self, $id) = @_; + my $fptr = 0; + my $fts = -1; + if (defined($id)) { + my $fid = qr/^$id\|/; + ($fptr,$fts) = xreadFile($self->{_fnam}, $fid); + } else { + ($fptr,$fts) = xreadFile($self->{_fnam}); + } + return ($fptr, $fts); } # get PROC(s) of this FORM as a hash of their 'long' name (NAME) sub procs { my ($self) = @_; - return %{$self->{_procs}}; + return %{$self->{_procs}}; } # get nodes of a PROC of this FORM, returned as a hash of their NAME, ALIAS and FID sub nodes { - my ($self, $proc) = @_; - die "no proc requested" unless defined($proc); - die "$proc not in ".$self->{_name} unless exists($self->{_procs}{$proc}); - my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); - return %L; + my ($self, $proc) = @_; + die "no proc requested" unless defined($proc); + die "$proc not in ".$self->{_name} unless exists($self->{_procs}{$proc}); + my %L = listGridNodes(grid=>"PROC.$proc", valid=>1); + return %L; } # get a dump of this FORM as a string # usage, eg: print $F->dump sub dump { my ($self) = @_; - my $dmp = ''; + my $dmp = ''; $dmp .= sprintf( "Form %s\n", $self->{_name} ); $dmp .= sprintf( "Form configuration path: %s\n", $self->{_path} ); - for my $k ( keys %{ $self->{_conf} } ) { - $dmp .= sprintf( " %s => %s\n",$k, $self->{_conf}{$k}); - } + for my $k ( keys %{ $self->{_conf} } ) { + $dmp .= sprintf( " %s => %s\n",$k, $self->{_conf}{$k}); + } $dmp .= sprintf( "Form data file is: %s\n", $self->{_fnam} ); - $dmp .= "Related proc(s): "; - for ( keys(%{$self->{_procs}}) ) { - $dmp .= sprintf("%s(%s) ", $_, $self->{_procs}{$_}); - } - $dmp .= "\n"; - return $dmp; + $dmp .= "Related proc(s): "; + for ( keys(%{$self->{_procs}}) ) { + $dmp .= sprintf("%s(%s) ", $_, $self->{_procs}{$_}); + } + $dmp .= "\n"; + return $dmp; } 1; @@ -152,86 +152,86 @@ sub dump { # ---- GENFORM sub sub datetime2array { - my $date = shift; - my $date_min = shift; - my @d = split(/[-: ]/,$date); - my @dm = split(/[-: ]/,$date_min); - if ($date eq $date_min || $date_min eq "") { return @d }; - @d = ($d[0], "", "", "","") if ($d[1] ne $dm[1]); - @d = ($d[0],$d[1], "", "","") if ($d[2] ne $dm[2]); - @d = ($d[0],$d[1],$d[2], "","") if ($d[3] ne $dm[3]); - @d = ($d[0],$d[1],$d[2],$d[3],"") if ($d[4] ne $dm[4]); - return @d; + my $date = shift; + my $date_min = shift; + my @d = split(/[-: ]/,$date); + my @dm = split(/[-: ]/,$date_min); + if ($date eq $date_min || $date_min eq "") { return @d }; + @d = ($d[0], "", "", "","") if ($d[1] ne $dm[1]); + @d = ($d[0],$d[1], "", "","") if ($d[2] ne $dm[2]); + @d = ($d[0],$d[1],$d[2], "","") if ($d[3] ne $dm[3]); + @d = ($d[0],$d[1],$d[2],$d[3],"") if ($d[4] ne $dm[4]); + return @d; } sub datetime2maxmin { - my ($y,$m,$d,$hr,$mn) = @_; - my $date_min = "$y-$m-$d $hr:$mn"; - my $date_max = "$y-$m-$d $hr:$mn"; - if ($m eq "") { - $date_min = "$y-01-01"; - $date_max = "$y-12-31"; - } elsif ($d eq "") { - $date_min = qx(date -d "$y-$m-01" "+%Y-%m-%d 00:00"); - chomp($date_min); - $date_max = qx(date -d "$y-$m-01 1 month 1 day ago" "+%Y-%m-%d 23:59"); - chomp($date_max); - } elsif ($hr eq "") { - $date_min = "$y-$m-$d 00:00"; - $date_max = "$y-$m-$d 23:59"; - } elsif ($mn eq "") { - $date_min = "$y-$m-$d $hr:00"; - $date_max = "$y-$m-$d $hr:59"; - } - return ("$date_max","$date_min"); + my ($y,$m,$d,$hr,$mn) = @_; + my $date_min = "$y-$m-$d $hr:$mn"; + my $date_max = "$y-$m-$d $hr:$mn"; + if ($m eq "") { + $date_min = "$y-01-01"; + $date_max = "$y-12-31"; + } elsif ($d eq "") { + $date_min = qx(date -d "$y-$m-01" "+%Y-%m-%d 00:00"); + chomp($date_min); + $date_max = qx(date -d "$y-$m-01 1 month 1 day ago" "+%Y-%m-%d 23:59"); + chomp($date_max); + } elsif ($hr eq "") { + $date_min = "$y-$m-$d 00:00"; + $date_max = "$y-$m-$d 23:59"; + } elsif ($mn eq "") { + $date_min = "$y-$m-$d $hr:00"; + $date_max = "$y-$m-$d $hr:59"; + } + return ("$date_max","$date_min"); } # extract_formula ($type) returns $formula and @x an array of used fields (input or output) sub extract_formula { - my $type = shift; - my @x; - my ($size, $formula) = extract_type($type); - while ($formula =~ /((IN|OUT)PUT[0-9]{2})/g) { - push(@x,$1); - } - return ($formula, $size, @x); + my $type = shift; + my @x; + my ($size, $formula) = extract_type($type); + while ($formula =~ /((IN|OUT)PUT[0-9]{2})/g) { + push(@x,$1); + } + return ($formula, $size, @x); } sub extract_list { - my $list = shift; - my $form = shift; - my $filename = (split /\: /, $list)[1]; - my %list = readCfg("$WEBOBS{PATH_FORMS}/$form/$filename"); + my $list = shift; + my $form = shift; + my $filename = (split /\: /, $list)[1]; + my %list = readCfg("$WEBOBS{PATH_FORMS}/$form/$filename"); - return %list; + return %list; } sub extract_type { - my $type = shift; - my ($size, $default) = (split /:/, $type); - if ($size =~ /\(\d+\)$/) { - $size =~ s/^[a-z]+\((\d+)\)/$1/; - } else { - $size = 5; - } - return ($size, $default); + my $type = shift; + my ($size, $default) = (split /:/, $type); + if ($size =~ /\(\d+\)$/) { + $size =~ s/^[a-z]+\((\d+)\)/$1/; + } else { + $size = 5; + } + return ($size, $default); } sub extract_text { - my $text = shift; - $text =~ s/^text[:]*//; - return (trim($text)); + my $text = shift; + $text =~ s/^text[:]*//; + return (trim($text)); } # count_inputs (@keys) returns max index of INPUTnn fields in array @keys sub count_inputs { - my $count = 0; - foreach(@_) { - if ($_ =~ /INPUT([0-9]{2})_NAME/) { - $count = $1 if ($count < $1); - } - } - return $count; + my $count = 0; + foreach(@_) { + if ($_ =~ /INPUT([0-9]{2})_NAME/) { + $count = $1 if ($count < $1); + } + } + return $count; } __END__ diff --git a/CODE/perl/lib/GML.pm b/CODE/perl/lib/GML.pm index cf9cd466..dcdbec7a 100644 --- a/CODE/perl/lib/GML.pm +++ b/CODE/perl/lib/GML.pm @@ -9,252 +9,255 @@ #--------------------------------------------------------------s use strict; use WebObs::XML2; + #-------------------------------------------------------------- sub gmlarray2nodearray { - # - # Convert **reference** XML/GeodesyML array - # (imported with xml2 buildin fct) - # to - # a "Node Array" i.e. one device change - # OR - # a list of Node Arrays if 'all' is used as index - - ### Inputs - my @GmlArray = @{$_[0]}; # an **reference** GeodesyML array parsed with XML2 Linux bin - my $nodename = $_[1]; # rec, ant, etc.... - my $idx = $_[2]; # node index, we recommend -1 (last one per default) - # OR - # 'all' to get all the nodes - my $root ; - my $root0 ; - - $root0 = '/geo:GeodesyML/geo:siteLog'; - - if ( $nodename eq "rec" ) { - $root = "$root0/geo:gnssReceiver/geo:GnssReceiver"; - } elsif ( $nodename eq "ant" ) { - $root = "$root0/geo:gnssAntenna/geo:GnssAntenna"; - } else { - die ("nodename not defined !!") - } - - ## get all ids for all nodes - my @Ids = findvalues("$root/\@gml:id=",\@GmlArray); - - ## Case 1: we want all nodes (idx == "all") - if ( $idx eq "all" ){ - my @NodesList; - my $id; - foreach $id (@Ids){ - $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed - ## Get the Node we want - my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); - ## stack it - push(@NodesList,[ @Node ]); # [] are very important, to force Node as a list - } - return @NodesList; - - ## Case 2: we want a specific node (idx € int) - } else { - ## find id of the node we want - my $id = @Ids[$idx]; - $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed - ## Get the Node we want - my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); - return @Node; - } + # + # Convert **reference** XML/GeodesyML array + # (imported with xml2 buildin fct) + # to + # a "Node Array" i.e. one device change + # OR + # a list of Node Arrays if 'all' is used as index + + ### Inputs + my @GmlArray = @{$_[0]}; # an **reference** GeodesyML array parsed with XML2 Linux bin + my $nodename = $_[1]; # rec, ant, etc.... + my $idx = $_[2]; # node index, we recommend -1 (last one per default) + + # OR + # 'all' to get all the nodes + my $root ; + my $root0 ; + + $root0 = '/geo:GeodesyML/geo:siteLog'; + + if ( $nodename eq "rec" ) { + $root = "$root0/geo:gnssReceiver/geo:GnssReceiver"; + } elsif ( $nodename eq "ant" ) { + $root = "$root0/geo:gnssAntenna/geo:GnssAntenna"; + } else { + die ("nodename not defined !!") + } + + ## get all ids for all nodes + my @Ids = findvalues("$root/\@gml:id=",\@GmlArray); + + ## Case 1: we want all nodes (idx == "all") + if ( $idx eq "all" ){ + my @NodesList; + my $id; + foreach $id (@Ids){ + $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed + ## Get the Node we want + my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); + ## stack it + push(@NodesList,[ @Node ]); # [] are very important, to force Node as a list + } + return @NodesList; + + ## Case 2: we want a specific node (idx € int) + } else { + ## find id of the node we want + my $id = @Ids[$idx]; + $id =~ s/^\s+|\s+$//g ; # very important, id must be trimmed + ## Get the Node we want + my @Node = findnodes($root,"/\@gml:id=",$id,\@GmlArray); + return @Node; + } } sub rec_nodearray2hash { - # - # Convert a **reference** Receiver Node Array - # (created with gmlarray2nodearray) - # to - # a hash (i.e. a dict-like) - # - my @Rec = @{$_[0]}; - my %hashrec; - - $hashrec{model} = findvalue('/geo:igsModelCode=',\@Rec); - $hashrec{satsys} = findvalue('/geo:satelliteSystem=',\@Rec); - $hashrec{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Rec); - $hashrec{vfirm} = findvalue('/geo:firmwareVersion=',\@Rec); - $hashrec{cutoff} = findvalue('/geo:elevationCutoffSetting=',\@Rec); - $hashrec{dinsta} = findvalue('/geo:dateInstalled=',\@Rec); - $hashrec{dremov} = findvalue('/geo:dateRemoved=',\@Rec); - - return %hashrec; + # + # Convert a **reference** Receiver Node Array + # (created with gmlarray2nodearray) + # to + # a hash (i.e. a dict-like) + # + my @Rec = @{$_[0]}; + my %hashrec; + + $hashrec{model} = findvalue('/geo:igsModelCode=',\@Rec); + $hashrec{satsys} = findvalue('/geo:satelliteSystem=',\@Rec); + $hashrec{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Rec); + $hashrec{vfirm} = findvalue('/geo:firmwareVersion=',\@Rec); + $hashrec{cutoff} = findvalue('/geo:elevationCutoffSetting=',\@Rec); + $hashrec{dinsta} = findvalue('/geo:dateInstalled=',\@Rec); + $hashrec{dremov} = findvalue('/geo:dateRemoved=',\@Rec); + + return %hashrec; } sub ant_nodearray2hash { - # - # Convert a **reference** Antenna Node Array - # (created with gmlarray2nodearray) - # to - # a hash (i.e. a dict-like) - # - my @Ant = @{$_[0]}; - my %hashant; - - $hashant{model} = findvalue('/geo:igsModelCode=',\@Ant); - $hashant{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Ant); - $hashant{radome} = findvalue('/geo:antennaRadomeType=',\@Ant); - $hashant{alignN} = findvalue('/geo:alignmentFromTrueNorth=',\@Ant); - $hashant{lcable} = findvalue('/geo:antennaCableLength=',\@Ant); - $hashant{dinsta} = findvalue('/geo:dateInstalled=',\@Ant); - $hashant{dremov} = findvalue('/geo:dateRemoved=',\@Ant); - - return %hashant; + # + # Convert a **reference** Antenna Node Array + # (created with gmlarray2nodearray) + # to + # a hash (i.e. a dict-like) + # + my @Ant = @{$_[0]}; + my %hashant; + + $hashant{model} = findvalue('/geo:igsModelCode=',\@Ant); + $hashant{sn} = findvalue('/geo:manufacturerSerialNumber=',\@Ant); + $hashant{radome} = findvalue('/geo:antennaRadomeType=',\@Ant); + $hashant{alignN} = findvalue('/geo:alignmentFromTrueNorth=',\@Ant); + $hashant{lcable} = findvalue('/geo:antennaCableLength=',\@Ant); + $hashant{dinsta} = findvalue('/geo:dateInstalled=',\@Ant); + $hashant{dremov} = findvalue('/geo:dateRemoved=',\@Ant); + + return %hashant; } sub gmlread_feature { - # - # Wrapper function - # - # Convert a XML/GeodesyML file - # to - # **reference** hashes (rec, ant, misc) - # for the CURRENT instrumentation - # - my $file = $_[0]; - my %hashrec; - my %hashant; - my %hashmisc; - my @Gml; - - if ( not -f $file) - { - die "$file not found" - } - - #### HARDCODED XML2 -# my @Gml = qx($WEBOBS{XML2_PRGM} < $file); - my @Gml = qx(/usr/bin/xml2 < $file); - - ###### Receiver - my @Rec = gmlarray2nodearray(\@Gml,"rec",-1); - %hashrec = rec_nodearray2hash(\@Rec); - - ###### Antenna - my @Ant = gmlarray2nodearray(\@Gml,"ant",-1); - %hashant = ant_nodearray2hash(\@Ant); - - ####### Misc Info - ## common root path - my $rootdomes = '/geo:GeodesyML/geo:siteLog/geo:siteIdentification/geo:iersDOMESNumber'; - $hashmisc{'domes'} = findvalue("$rootdomes",\@Gml); - - ## backslash because we need to output a reference - # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html - return (\%hashrec, \%hashant, \%hashmisc); + # + # Wrapper function + # + # Convert a XML/GeodesyML file + # to + # **reference** hashes (rec, ant, misc) + # for the CURRENT instrumentation + # + my $file = $_[0]; + my %hashrec; + my %hashant; + my %hashmisc; + my @Gml; + + if ( not -f $file) + { + die "$file not found" + } + + #### HARDCODED XML2 + # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); + my @Gml = qx(/usr/bin/xml2 < $file); + + ###### Receiver + my @Rec = gmlarray2nodearray(\@Gml,"rec",-1); + %hashrec = rec_nodearray2hash(\@Rec); + + ###### Antenna + my @Ant = gmlarray2nodearray(\@Gml,"ant",-1); + %hashant = ant_nodearray2hash(\@Ant); + + ####### Misc Info + ## common root path + my $rootdomes = '/geo:GeodesyML/geo:siteLog/geo:siteIdentification/geo:iersDOMESNumber'; + $hashmisc{'domes'} = findvalue("$rootdomes",\@Gml); + + ## backslash because we need to output a reference + # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html + return (\%hashrec, \%hashant, \%hashmisc); } sub gml2mmdfeature { - # - # Wrapper function - # - # Convert a XML/GeodesyML file - # to - # a WebObs markdown feature text for the CURRENT instrumentation - # + # + # Wrapper function + # + # Convert a XML/GeodesyML file + # to + # a WebObs markdown feature text for the CURRENT instrumentation + # my $gmlfile = $_[0]; my $featsection = $_[1]; - - - if ( not -f $gmlfile) - { - die "$gmlfile not found" - } - - ## dollar sign ($) because we need to get references - # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html - my ($hashrec, $hashant, $hashmisc) = gmlread_feature($gmlfile); - - my @outlines ; - - # here we need $hashrec->{'blabla'} and not simply $hashrec{'blabla'} - # because $hashrec is a reference of a hash - # abd not a hash it self - if ( $featsection eq "gnssrec" ) { - push(@outlines,"//Model//: $hashrec->{'model'} \n"); - push(@outlines,"Satellite system: $hashrec->{'satsys'}\n"); - push(@outlines,"Serial number: $hashrec->{'sn'}\n"); - push(@outlines,"Firmware version: $hashrec->{'vfirm'} \n"); - push(@outlines,"Date installed: $hashrec->{'dinsta'}\n"); - push(@outlines,"Date removed: $hashrec->{'dremov'}\n"); - } elsif ( $featsection eq "gnssant" ) { - push(@outlines,"Model: $hashant->{'model'} \n"); - push(@outlines,"Radome: $hashant->{'radome'} \n"); - push(@outlines,"Serial number: $hashant->{'sn'}\n"); - push(@outlines,"Alignment from North: $hashant->{'alignN'} \n"); - push(@outlines,"Cable length (m): $hashant->{'lcable'} \n"); - push(@outlines,"Date installed: $hashant->{'dinsta'}\n"); - push(@outlines,"Date removed: $hashant->{'dremov'}\n"); - } - - return @outlines; - #### !!!! EXCEPTION HERE IF FILE NOT FOUND GMLFILE!!!! - #### !!!! EXCEPTION HERE IF $featsection NOT FOUND !!!! + + if ( not -f $gmlfile) + { + die "$gmlfile not found" + } + + ## dollar sign ($) because we need to get references + # https://www.oreilly.com/library/view/perl-cookbook/1565922433/ch10s10.html + my ($hashrec, $hashant, $hashmisc) = gmlread_feature($gmlfile); + + my @outlines ; + + # here we need $hashrec->{'blabla'} and not simply $hashrec{'blabla'} + # because $hashrec is a reference of a hash + # abd not a hash it self + if ( $featsection eq "gnssrec" ) { + push(@outlines,"//Model//: $hashrec->{'model'} \n"); + push(@outlines,"Satellite system: $hashrec->{'satsys'}\n"); + push(@outlines,"Serial number: $hashrec->{'sn'}\n"); + push(@outlines,"Firmware version: $hashrec->{'vfirm'} \n"); + push(@outlines,"Date installed: $hashrec->{'dinsta'}\n"); + push(@outlines,"Date removed: $hashrec->{'dremov'}\n"); + } elsif ( $featsection eq "gnssant" ) { + push(@outlines,"Model: $hashant->{'model'} \n"); + push(@outlines,"Radome: $hashant->{'radome'} \n"); + push(@outlines,"Serial number: $hashant->{'sn'}\n"); + push(@outlines,"Alignment from North: $hashant->{'alignN'} \n"); + push(@outlines,"Cable length (m): $hashant->{'lcable'} \n"); + push(@outlines,"Date installed: $hashant->{'dinsta'}\n"); + push(@outlines,"Date removed: $hashant->{'dremov'}\n"); + } + + return @outlines; + #### !!!! EXCEPTION HERE IF FILE NOT FOUND GMLFILE!!!! + #### !!!! EXCEPTION HERE IF $featsection NOT FOUND !!!! } sub gml2mmdtable { - # - # Wrapper function - # - # Convert a XML/GeodesyML file - # to - # a WebObs markdown table for the COMPLETE history - # - my $gmlfile = $_[0]; - my $featsection = $_[1]; - - if ( not -f $gmlfile) - { - die "$gmlfile not found" - } - - my @outlines; - ### add the "meta" line, thus the text is considered as MarkDown - push(@outlines,"WebObs: converted with wiki2MMD\n\n"); - - #### HARDCODED XML2 -# my @Gml = qx($WEBOBS{XML2_PRGM} < $file); - my @Gml = qx(/usr/bin/xml2 < $gmlfile); - - ###### Receiver - if ( $featsection eq "gnssrec" ) { - push(@outlines,"| Date installed | Date removed | Model | Satellite system | Serial number | Firmware version |\n"); - push(@outlines,"| ---------------------------------------------------------------------------------------------------------------------|\n"); - #my @RecList = [ gmlarray2nodearray(\@Gml,"rec",-1) ]; - my @RecList = gmlarray2nodearray(\@Gml,"rec","all"); - my $Rec; - foreach $Rec ( @RecList ){ - my %hashrec; - %hashrec = rec_nodearray2hash($Rec); - my $line = sprintf("|%22s|%22s|%18s|%18s|%15s|%18s|",$hashrec{'dinsta'},$hashrec{'dremov'},$hashrec{'model'},$hashrec{'satsys'},$hashrec{'sn'},$hashrec{'vfirm'}); - push(@outlines,$line); - } - } elsif ( $featsection eq "gnssant" ) { - - push(@outlines,"| Date installed | Date removed | Model | Radome | Serial number | N. Align. (°) | Cable len. (m) |\n"); - push(@outlines,"| -------------------------------------------------------------------------------------------------------------------------|\n"); - #my @AntList = [ gmlarray2nodearray(\@Gml,"ant",-1) ]; - my @AntList = gmlarray2nodearray(\@Gml,"ant","all"); - my $Ant; - foreach $Ant ( @AntList ){ - my %hashant; - %hashant = ant_nodearray2hash($Ant); - my $line = sprintf("|%22s|%22s|%18s|%8s|%15s|%16s|%16s|",$hashant{'dinsta'},$hashant{'dremov'},$hashant{'model'},$hashant{'radome'},$hashant{'sn'},$hashant{'alignN'},$hashant{'lcable'}); - push(@outlines,$line); - } - } - - return @outlines; + # + # Wrapper function + # + # Convert a XML/GeodesyML file + # to + # a WebObs markdown table for the COMPLETE history + # + my $gmlfile = $_[0]; + my $featsection = $_[1]; + + if ( not -f $gmlfile) + { + die "$gmlfile not found" + } + + my @outlines; + ### add the "meta" line, thus the text is considered as MarkDown + push(@outlines,"WebObs: converted with wiki2MMD\n\n"); + + #### HARDCODED XML2 + # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); + my @Gml = qx(/usr/bin/xml2 < $gmlfile); + + ###### Receiver + if ( $featsection eq "gnssrec" ) { + push(@outlines,"| Date installed | Date removed | Model | Satellite system | Serial number | Firmware version |\n"); + push(@outlines,"| ---------------------------------------------------------------------------------------------------------------------|\n"); + + #my @RecList = [ gmlarray2nodearray(\@Gml,"rec",-1) ]; + my @RecList = gmlarray2nodearray(\@Gml,"rec","all"); + my $Rec; + foreach $Rec ( @RecList ){ + my %hashrec; + %hashrec = rec_nodearray2hash($Rec); + my $line = sprintf("|%22s|%22s|%18s|%18s|%15s|%18s|",$hashrec{'dinsta'},$hashrec{'dremov'},$hashrec{'model'},$hashrec{'satsys'},$hashrec{'sn'},$hashrec{'vfirm'}); + push(@outlines,$line); + } + } elsif ( $featsection eq "gnssant" ) { + + push(@outlines,"| Date installed | Date removed | Model | Radome | Serial number | N. Align. (°) | Cable len. (m) |\n"); + push(@outlines,"| -------------------------------------------------------------------------------------------------------------------------|\n"); + + #my @AntList = [ gmlarray2nodearray(\@Gml,"ant",-1) ]; + my @AntList = gmlarray2nodearray(\@Gml,"ant","all"); + my $Ant; + foreach $Ant ( @AntList ){ + my %hashant; + %hashant = ant_nodearray2hash($Ant); + my $line = sprintf("|%22s|%22s|%18s|%8s|%15s|%16s|%16s|",$hashant{'dinsta'},$hashant{'dremov'},$hashant{'model'},$hashant{'radome'},$hashant{'sn'},$hashant{'alignN'},$hashant{'lcable'}); + push(@outlines,$line); + } + } + + return @outlines; } sub gml2date { - + } 1; diff --git a/CODE/perl/lib/Gazette.pm b/CODE/perl/lib/Gazette.pm index a2fe0e2e..8dcd8fab 100644 --- a/CODE/perl/lib/Gazette.pm +++ b/CODE/perl/lib/Gazette.pm @@ -31,7 +31,7 @@ use WebObs::Grids; use POSIX qw(ceil); use WebObs::i18n; use Locale::TextDomain('webobs'); - + our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); require Exporter; @@ -44,7 +44,7 @@ our $dbname = $GAZETTE{DB_NAME}; our $dbtable = "gazette"; our %GAZETTECAT = readCfg("$GAZETTE{CATEGORIES_FILE}"); foreach (keys %GAZETTECAT) { - delete $GAZETTECAT{$_} if (!WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") && !WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE")); + delete $GAZETTECAT{$_} if (!WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") && !WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE")); } our $allCATlist = join(',',keys(%GAZETTECAT)); our @editableCat; @@ -55,21 +55,22 @@ our $calweekn = (defined($GAZETTE{CALENDAR_WEEKNUMBER})) ? $GAZETTE{CALENDAR_W our $ongoing = (defined($GAZETTE{SHOW_BYDATE_ONGOING})) ? $GAZETTE{SHOW_BYDATE_ONGOING} : "TEXT"; our $tdtrunc = (defined($GAZETTE{CALENDAR_TRUNCLENGTH})) ? $GAZETTE{CALENDAR_TRUNCLENGTH} : 25; -use constant { - # column indexes for a full DB table row array - G_ID => 0, - G_STARTDATE => 1, - G_STARTTIME => 2, - G_ENDDATE => 3, - G_ENDTIME => 4, - G_CATEGORY => 5, - G_UID => 6, - G_OTHERS => 7, - G_PLACE => 8, - G_SUBJECT => 9, - G_LASTUPD => 10, - G_LASTUPDUID => 11, -}; +use constant { + + # column indexes for a full DB table row array + G_ID => 0, + G_STARTDATE => 1, + G_STARTTIME => 2, + G_ENDDATE => 3, + G_ENDTIME => 4, + G_CATEGORY => 5, + G_UID => 6, + G_OTHERS => 7, + G_PLACE => 8, + G_SUBJECT => 9, + G_LASTUPD => 10, + G_LASTUPDUID => 11, + }; # ------------------------------------------------------------------------------------------- @@ -103,418 +104,435 @@ Arguments: =cut sub Show { - # parse/check arguments - my %KWARGS = @_; - return undef if ( !exists($KWARGS{view}) || !($KWARGS{view} =~ /calendar|datelist|categorylist|ical|dump|stats/i) ); - return undef if ( !exists($KWARGS{from}) ); - my $dtfrom = eval { Time::Piece->strptime($KWARGS{from},'%Y-%m-%d');} or return undef; - my $dtto = $dtfrom; - if ( exists($KWARGS{to}) ) { - $dtto = eval { Time::Piece->strptime($KWARGS{to},'%Y-%m-%d');} or return undef; - if ($KWARGS{view} =~ /calendar/i && $dtfrom == $dtto ) { $KWARGS{view} = "day" } - } - my $filter = (exists($KWARGS{textfilter})) ? $KWARGS{textfilter} : ""; - my $jsedit = (exists($KWARGS{jseditor})) ? $KWARGS{jseditor} : ""; - my $jsevent = (exists($KWARGS{jsevent})) ? $KWARGS{jsevent} : ""; - my @html = (); - # @cat : valid and $CLIENT-readable categories (all or within $KWARGS{categories} subset) - # $incat : @cat suitable for an sql select IN clause - my $categories = (!exists($KWARGS{categories}) || $KWARGS{categories} =~ /^$|all/i) ? $allCATlist : $KWARGS{categories}; - my @cat = grep { exists($GAZETTECAT{$_}) && (WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") || WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE") ) } split(/,/,$categories); - return @html if (@cat == 0) ; - my $incat = join( ',', map { "'$_'" } @cat); - # build holidays for $dtfrom year and $dtto year - my @daysoff = (WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtfrom->year)); - push(@daysoff,WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtto->year)) if ($dtfrom->year != $dtto->year); - my $today = new Time::Piece; - - # ---- Show as weekly calendar ----------------------------------------------------------- - - if ($KWARGS{view} =~ /calendar/i ) { - # make sure $dtfrom and $dtto are week boundaries - $dtfrom = $dtfrom - (($dtfrom->day_of_week+6)%7)*86400; - $dtto = $dtto + ((0-$dtto->day_of_week)%7)*86400; - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - # from 'number of weeks displayed' in requested date frame, derive the preceeding and next date frames - my $wn = ($dtto->epoch - $dtfrom->epoch)/(60*60*24*7); # nb of weeks in requested date frame - # previous date frame is same nunber of weeks before requested frame's start - my $prevdtto = $dtfrom-86400 + ((0-($dtfrom-86400)->day_of_week)%7)*86400; - my $prevdtfrom = $prevdtto-(86400*7*$wn) -((($prevdtto-(86400*7*$wn))->day_of_week+6)%7)*86400; - # next date frame is same number of weeks after requested frame's end - my $nextdtfrom = $dtto+86400 -((($dtto+86400)->day_of_week+6)%7)*86400; - my $nextdtto = $nextdtfrom+(86400*7*$wn) + ((0-($nextdtfrom+(86400*7*$wn))->day_of_week)%7)*86400; - my $prevrange=$prevdtfrom->strftime('%Y-%m-%d').",".$prevdtto->strftime('%Y-%m-%d'); - my $prevw=sprintf("w%02s",$prevdtfrom->week); if ($prevdtto->week ne $prevdtfrom->week) { $prevw .= sprintf(",w%02s",$prevdtto->week) }; - my $nextrange=$nextdtfrom->strftime('%Y-%m-%d').",".$nextdtto->strftime('%Y-%m-%d'); - my $nextw=sprintf("w%02s",$nextdtfrom->week); if ($nextdtto->week ne $nextdtfrom->week) { $nextw .= sprintf(",w%02s",$nextdtto->week) }; - my $prevnextbar = "$prevw"; - $prevnextbar .= "$nextw"; - my $caltr = ""; - push(@html, "
        $prevnextbar
        "); - my $ww; # week first day's Time::Piece object - for ( my $w=$dtfrom, my $cnt=0; $w<=$dtto; $w+=7*86400, $cnt++) { # for each week starting on $w - my $altclass = ($cnt%2 == 0) ? 'even' : 'odd'; - push(@html,"\n\n"); - # identify week (iso notation) - if ($calweekn eq "VERTICAL") { - push(@html,"\n"); - push(@html,""); - $caltr = "\n"; - } else { - push(@html,''); - $caltr = "\n"; - push(@html,$caltr); - } - # 1 row to identify each day of week - for ($ww=$w; $ww<$w+(7*86400); $ww+=86400 ) { - my $dclass=""; my $tst = $ww->strftime('%Y-%m-%d'); - $dclass .= "\"holidays\"" if (grep(/$tst/,@daysoff)); - $dclass .= " today" if ($tst eq $today->strftime('%Y-%m-%d')); - $dclass = "class=$dclass" if($dclass ne ""); - push(@html,""); - } - my @prehtml = ([(undef)x7]); - # now 1 row per article occuring this week and identified by its result-set-array index - my $actualRowsInWeek = 0; - my @ixs = ixApplicable($articles,$w,$w+(6*86400)); # all articles indexes in result set this week - for my $ix (@ixs) { # for each article - my $art = @{$articles}[$ix]; - my $artstart = Time::Piece->strptime($art->[G_STARTDATE],'%Y-%m-%d'); - my $artend = ($art->[G_ENDDATE] eq '') ? Time::Piece->strptime($maxdate,'%Y-%m-%d') : Time::Piece->strptime($art->[G_ENDDATE],'%Y-%m-%d'); - if ($artstart != $artend) { - # article spans n-days ==> 1 row per article & 'long' ") if ($before > 0); - - my $tdtext = calendarTD($w, $art, $artstart, $artend); # td contents - my $bgcolor = "transparent"; # td 'no-category' color just in case - if ( $art->[G_CATEGORY] ne "" ) { - $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; - } - my $tip = articleTip($art); - my $click = ""; - if ($jsedit ne "") { - $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; - } - if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { - $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; - } - my $attr = " colspan='$item' onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word; background-color: $bgcolor' $click "; - push(@html, ""); - - push(@html, "") if ($after > 0); - } else { - # article spans 1-day ==> optimize placement (less rows) for this single "); - } else { - push(@html, ""); - } - } - } - } - if ($calweekn eq "VERTICAL") { - push(@html, "") for (1..3-$actualRowsInWeek); # make week have 3 rows minimum - push(@html,"\n
        ".$w->strftime('%G-w%V')."
        '.$w->strftime('%G-w%V').'
        ".l2u($ww->strftime('%a %d %b'))." - push(@html,$caltr);$actualRowsInWeek++; - my $dur = 1+($artend-$artstart)/86400; - my $before = (($artstart-$w)/86400); if ($before <= 0) { $dur += $before; $before = 0; }; - my $item = ($dur,7-$before)[$dur > 7-$before]; - my $after = 7 - ($before+$item); - - push(@html, "$tdtext. - # @prehtml initially represents an empty week row (ie. 7 spots) populated as required with articles; - # number of rows grows as required (ie. when new articles use already populated spots). - my $i = ($artstart-$w)/86400; - my $done=0; - for my $row (@prehtml) { - if (!defined($row->[$i])) { $row->[$i] = [($w,@{$articles}[$ix],$artstart)]; $done=1; last } - } - if (!$done) { push(@prehtml,[(undef)x7]); $prehtml[-1]->[$i]= [($w,@{$articles}[$ix],$artstart)] } - } - } - # format the @prehtml rows , adding them to calendar - for my $row (@prehtml) { - push(@html,$caltr);$actualRowsInWeek++; - for my $d ($row) { - for my $i (0..6) { - if (defined($d->[$i])) { - my ($w, $art, $artstart) = @{$d->[$i]}; - my $tdtext = calendarTD($w, $art, $artstart, $artstart); - my $bgcolor = "transparent"; - if ( $art->[G_CATEGORY] ne "" ) { - $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; - } - my $tip = articleTip($art); - my $click = ""; - if ($jsedit ne "") { - $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; - } - if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { - $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; - } - my $attr = " onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word;background-color: $bgcolor' $click "; - push(@html, "$tdtext
        \n"); - } else { - push(@html,"\n\n"); - } - } - push(@html, "
        $prevnextbar
        "); - return @html; - } - - # ---- Show one day, calendar like ------------------------------------------------------- - - if ($KWARGS{view} =~ /day/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtfrom->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - my $prevday=($dtfrom-86400)->strftime('%Y-%m-%d'); - my $nextday=($dtfrom+86400)->strftime('%Y-%m-%d'); - my $prevnextbar = "$prevday"; - $prevnextbar .= "$nextday"; - push(@html, "
        $prevnextbar
        "); - push(@html,""); - push(@html,''); - # now 1 row per article - for my $art (@{$articles}) { - push(@html,''); - - my $tdtext = ""; - $tdtext .= articleTimes($art,$art->[G_STARTDATE]); - $tdtext .= $art->[G_SUBJECT]." "; - $tdtext .= articleWho($art)." "; - my $bgcolor = "transparent"; # td 'no-category' color just in case - if ( $art->[G_CATEGORY] ne "" ) { - $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; - } - # TODO: mouseover - my $tip = articleTip($art); - my $click = ""; - if ($jsedit ne "") { - $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; - } - if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { - $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; - } - my $attr = " onMouseOver='showtip(event,\"$art->[G_CATEGORY]\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='background-color: $bgcolor' $click "; - push(@html, ""); - } - push(@html,'
        '.l2u($dtfrom->strftime("$__{'gzt_fmt_long_date'}")).'
        $tdtext
        '); - - return @html; - } - # ---- Show by date -------------------------------------------------------- - - if ($KWARGS{view} =~ /datelist/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - for ( my $d=$dtfrom, my $cnt=0; $d<=$dtto; $d+=86400, $cnt++) { # for each day starting on $d - my $ymd = $d->strftime('%Y-%m-%d'); - my $dayhtml = ""; - my @ixs = ixApplicable($articles,$d); # all articles indexes in result set, this day - for my $ix (@ixs) { # for each article - my $li = ""; - # find wether article starts or ends on currently processed day - if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] || $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { - if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] && $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { - $li .= '
      • '.articleTimes(@{$articles}[$ix],$ymd)." "; - } else { - if ($ymd eq @{$articles}[$ix]->[G_STARTDATE]) { - my $until = @{$articles}[$ix]->[G_ENDDATE] eq '' ? "$__{'from now on'}" : "$__{until} @{$articles}[$ix]->[G_ENDDATE]"; - $li .= '
      • '."$until "; - } elsif ($ymd eq @{$articles}[$ix]->[G_ENDDATE]) { - $li .= '
      • '."$__{since} @{$articles}[$ix]->[G_STARTDATE] "; - } - } - } else { - # not starting nor ending this day => report depending on SHOW_BYDATE_ONGOING variable - if ($ongoing !~ /NO/i) { - $li .= '
      • '; - $li .= "$__{'on going'} " if ($ongoing =~ /TEXT/i); - $li .= "$__{'since'} @{$articles}[$ix]->[G_STARTDATE] $__{until} @{$articles}[$ix]->[G_ENDDATE] " if ($ongoing =~ /DATE/i); - } else { next; } - } - my $rqcat = @{$articles}[$ix]->[G_CATEGORY]; - $li .= "$GAZETTECAT{$rqcat}{Name} "; - $li .= "@{$articles}[$ix]->[G_PLACE] "; - $li .= "- @{$articles}[$ix]->[G_SUBJECT] "; - $li .= "- ".articleWho(@{$articles}[$ix])." " ; - if ($jsedit ne "") { - $li .= (grep { /@{$articles}[$ix]->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; - } - $li .= "
        • "; - $dayhtml .= $li; - } - if ($dayhtml ne "") { # found things to display for this day - push(@html, "

        ".l2u($d->strftime("$__{gzt_fmt_date}"))."

        "."
          $dayhtml
        "); - } - - } - return @html; - } - - # ---- Show by category ------------------------------------------------ - - if ($KWARGS{view} =~ /categorylist/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'category,startdate,starttime'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - my $currentCat = ""; - for my $art (@{$articles}) { # for each article (ordered by category) - if ($art->[G_CATEGORY] ne $currentCat) { - push(@html,"") if ($currentCat ne ""); - $currentCat = $art->[G_CATEGORY]; - push(@html, "

        $GAZETTECAT{$currentCat}{Name}

          "); - } - my $htmlDate = ""; - if ($art->[G_STARTDATE] eq $art->[G_ENDDATE]) { - if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= $art->[G_STARTDATE]; } - elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME])" } - elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] (⇒ $art->[G_ENDTIME])"} - else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME] ⇒ $art->[G_ENDTIME])" } - } else { - if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE]" } - elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) " } - elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE] ($art->[G_ENDTIME])"} - else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) - $art->[G_ENDDATE] ($art->[G_ENDTIME])" } - } - - #articleWho() returns : [user1, user2] + others - my $allNames = articleWho($art); - my ($htmlNames,$htmlOthers) = split(/ \+ /,$allNames); - - my $htmlLi = ""; - if ($GAZETTECAT{$currentCat}{Format} eq "ndol") { - $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "ndlo") { - $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_PLACE] - $art->[G_SUBJECT]"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "ldon") { - $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "dlon") { - $htmlLi .= "$htmlDate - $art->[G_PLACE] - $art->[G_SUBJECT] - $htmlNames"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "andol") { - $htmlLi .= "$htmlOthers".($htmlNames ne "" ? ($htmlOthers ne "" ? ", ":"")."$htmlNames":"")." - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; - } - elsif ($GAZETTECAT{$currentCat}{Format} eq "adon") { - $htmlLi .= "$htmlOthers - [$htmlDate] - $art->[G_SUBJECT] - [$htmlNames]"; - } else { - $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; - } - my $editicon = ""; - if ($jsedit ne "") { - $editicon = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; - } - push(@html, "
        • $htmlLi $editicon
          • \n"); - } - push(@html, "
        ") if (@html); - return @html; - } - - # ---- Show raw selection for admins only------------------------------------------------ - - if ($KWARGS{view} =~ /dump/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { - my $articles; - if ($KWARGS{categories} =~ /^$|all/i) { # for dump, 'all' really means 'any' (known or unknown) categories - $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), order=> 'startdate,starttime,category'); - } else { - $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - } - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - push(@html,""); - for my $art (@{$articles}) { # each article - push(@html, "\n"); - } - push(@html, "
        IDSTARTDATESTARTTIMEENDDATEENDTIMECATEGORYUIDOTHERSPLACESUBJECTUpdatedUpdID
        ".join('', map { "$art->[$_]" } (0..11))."
        "); - return @html; - } - - # ---- Show statistics for admins only------------------------------------------------ - - if ($KWARGS{view} =~ /stats/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { - my ($dbh, $sql, $sth, $art); - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - push(@html,"

        Figures below apply to full Gazette (ie. selection criteria do NOT apply)

        "); - - $sql = "select count(*) from $dbtable"; - $sth = $dbh->prepare($sql); - $sth->execute(); - my $rsCountRows = $sth->fetchall_arrayref(); - push(@html,""); - for $art (@{$rsCountRows}) { - push(@html, "\n"); - } - push(@html, "
        Total number of articles
        $art->[0]
        "); - push(@html, "
        "); - - $sql = "select category, count(*) from $dbtable where category in (select distinct(category)) group by category order by category"; - $sth = $dbh->prepare($sql); - $sth->execute(); - my $rsCountCategories = $sth->fetchall_arrayref(); - push(@html,""); - for $art (@{$rsCountCategories}) { - my $catdef = "undefined"; - $catdef = "defined" if (exists($GAZETTECAT{$art->[0]})); - push(@html, "\n"); - } - push(@html, "
        Categoryin CATEGORIES_FILENumber of articles
        $art->[0]$catdef$art->[1]
        "); - - $dbh->disconnect; - return @html; - } - - # ---- Show as iCal --------------------------------------------------------------------- - - if ($KWARGS{view} =~ /ical/i) { - my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); - if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } - - push(@html,"BEGIN:VCALENDAR\n"); - push(@html,"PRODID:-//webobs.ipgp.fr/gazette//EN\n"); - push(@html,"VERSION:2.0\n"); - for my $art (@{$articles}) { # each article - # if "startdate starttime" can't parse : ignore article - # if "enddate endtime" can't parse : behave like no enddate specified - my $ds = eval { Time::Piece->strptime($art->[G_STARTDATE]." ".$art->[G_STARTTIME],'%Y-%m-%d %H:%M') } or next; - my $de = eval { Time::Piece->strptime($art->[G_ENDDATE]." ".$art->[G_ENDTIME],'%Y-%m-%d %H:%M') } or $art->[G_ENDDATE] = ""; - push(@html, "BEGIN:VEVENT\n"); - push(@html, "SUMMARY:$art->[G_SUBJECT]\n"); - push(@html, "DTSTART:".$ds->datetime."\n"); - if ($art->[G_ENDDATE] eq '') { - push(@html, "RRULE:FREQ=DAILY\n"); - } else { - push(@html, "DTEND:".$de->datetime."\n"); - } - push(@html, "LOCATION:$art->[G_PLACE]\n"); - push(@html, "CATEGORIES:$art->[G_CATEGORY]\n"); - my $id = $art->[G_UID]; $id =~ s/\+.*//; # take first id only - push(@html, "UID:$USERS{$USERIDS{$id}}{EMAIL}\n"); - push(@html, "END:VEVENT\n"); - } - push(@html, "END:VCALENDAR"); - - my $icsfn = "Gazette_".$WebObs::Users::CLIENT."_".$dtfrom->strftime('%Y-%m-%d')."_".$dtto->strftime('%Y-%m-%d').".ics"; - my $icsrc = ""; - if (open(WRT,">$WEBOBS{PATH_TMP_APACHE}/$icsfn")) { - print WRT @html; - close(WRT); - $icsrc = "$__{'saved as'} $icsfn"; - } else { $icsrc = "$__{'not saved'}" } - - #unshift(@html, "

        $icsrc

        "); - unshift(@html, "Download
        \n"); - - s/\n/
        / for @html; - return @html; - } + # parse/check arguments + my %KWARGS = @_; + return undef if ( !exists($KWARGS{view}) || !($KWARGS{view} =~ /calendar|datelist|categorylist|ical|dump|stats/i) ); + return undef if ( !exists($KWARGS{from}) ); + my $dtfrom = eval { Time::Piece->strptime($KWARGS{from},'%Y-%m-%d');} or return undef; + my $dtto = $dtfrom; + if ( exists($KWARGS{to}) ) { + $dtto = eval { Time::Piece->strptime($KWARGS{to},'%Y-%m-%d');} or return undef; + if ($KWARGS{view} =~ /calendar/i && $dtfrom == $dtto ) { $KWARGS{view} = "day" } + } + my $filter = (exists($KWARGS{textfilter})) ? $KWARGS{textfilter} : ""; + my $jsedit = (exists($KWARGS{jseditor})) ? $KWARGS{jseditor} : ""; + my $jsevent = (exists($KWARGS{jsevent})) ? $KWARGS{jsevent} : ""; + my @html = (); + +# @cat : valid and $CLIENT-readable categories (all or within $KWARGS{categories} subset) +# $incat : @cat suitable for an sql select IN clause + my $categories = (!exists($KWARGS{categories}) || $KWARGS{categories} =~ /^$|all/i) ? $allCATlist : $KWARGS{categories}; + my @cat = grep { exists($GAZETTECAT{$_}) && (WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE$_") || WebObs::Users::clientHasRead(type=>"authmisc",name=>"GAZETTE") ) } split(/,/,$categories); + return @html if (@cat == 0) ; + my $incat = join( ',', map { "'$_'" } @cat); + + # build holidays for $dtfrom year and $dtto year + my @daysoff = (WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtfrom->year)); + push(@daysoff,WebObs::Dates::readFeries(conf=>"$WEBOBS{FILE_DAYSOFF}",year=>$dtto->year)) if ($dtfrom->year != $dtto->year); + my $today = new Time::Piece; + +# ---- Show as weekly calendar ----------------------------------------------------------- + + if ($KWARGS{view} =~ /calendar/i ) { + + # make sure $dtfrom and $dtto are week boundaries + $dtfrom = $dtfrom - (($dtfrom->day_of_week+6)%7)*86400; + $dtto = $dtto + ((0-$dtto->day_of_week)%7)*86400; + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + +# from 'number of weeks displayed' in requested date frame, derive the preceeding and next date frames + my $wn = ($dtto->epoch - $dtfrom->epoch)/(60*60*24*7); # nb of weeks in requested date frame + + # previous date frame is same nunber of weeks before requested frame's start + my $prevdtto = $dtfrom-86400 + ((0-($dtfrom-86400)->day_of_week)%7)*86400; + my $prevdtfrom = $prevdtto-(86400*7*$wn) -((($prevdtto-(86400*7*$wn))->day_of_week+6)%7)*86400; + + # next date frame is same number of weeks after requested frame's end + my $nextdtfrom = $dtto+86400 -((($dtto+86400)->day_of_week+6)%7)*86400; + my $nextdtto = $nextdtfrom+(86400*7*$wn) + ((0-($nextdtfrom+(86400*7*$wn))->day_of_week)%7)*86400; + my $prevrange=$prevdtfrom->strftime('%Y-%m-%d').",".$prevdtto->strftime('%Y-%m-%d'); + my $prevw=sprintf("w%02s",$prevdtfrom->week); if ($prevdtto->week ne $prevdtfrom->week) { $prevw .= sprintf(",w%02s",$prevdtto->week) }; + my $nextrange=$nextdtfrom->strftime('%Y-%m-%d').",".$nextdtto->strftime('%Y-%m-%d'); + my $nextw=sprintf("w%02s",$nextdtfrom->week); if ($nextdtto->week ne $nextdtfrom->week) { $nextw .= sprintf(",w%02s",$nextdtto->week) }; + my $prevnextbar = "$prevw"; + $prevnextbar .= "$nextw"; + my $caltr = ""; + push(@html, "
        $prevnextbar
        "); + my $ww; # week first day's Time::Piece object + for ( my $w=$dtfrom, my $cnt=0; $w<=$dtto; $w+=7*86400, $cnt++) { # for each week starting on $w + my $altclass = ($cnt%2 == 0) ? 'even' : 'odd'; + push(@html,"\n\n"); + + # identify week (iso notation) + if ($calweekn eq "VERTICAL") { + push(@html,"\n"); + push(@html,""); + $caltr = "\n"; + } else { + push(@html,''); + $caltr = "\n"; + push(@html,$caltr); + } + + # 1 row to identify each day of week + for ($ww=$w; $ww<$w+(7*86400); $ww+=86400 ) { + my $dclass=""; my $tst = $ww->strftime('%Y-%m-%d'); + $dclass .= "\"holidays\"" if (grep(/$tst/,@daysoff)); + $dclass .= " today" if ($tst eq $today->strftime('%Y-%m-%d')); + $dclass = "class=$dclass" if($dclass ne ""); + push(@html,""); + } + my @prehtml = ([(undef)x7]); + +# now 1 row per article occuring this week and identified by its result-set-array index + my $actualRowsInWeek = 0; + my @ixs = ixApplicable($articles,$w,$w+(6*86400)); # all articles indexes in result set this week + for my $ix (@ixs) { # for each article + my $art = @{$articles}[$ix]; + my $artstart = Time::Piece->strptime($art->[G_STARTDATE],'%Y-%m-%d'); + my $artend = ($art->[G_ENDDATE] eq '') ? Time::Piece->strptime($maxdate,'%Y-%m-%d') : Time::Piece->strptime($art->[G_ENDDATE],'%Y-%m-%d'); + if ($artstart != $artend) { + + # article spans n-days ==> 1 row per article & 'long' ") if ($before > 0); + + my $tdtext = calendarTD($w, $art, $artstart, $artend); # td contents + my $bgcolor = "transparent"; # td 'no-category' color just in case + if ( $art->[G_CATEGORY] ne "" ) { + $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; + } + my $tip = articleTip($art); + my $click = ""; + if ($jsedit ne "") { + $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; + } + if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { + $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; + } + my $attr = " colspan='$item' onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word; background-color: $bgcolor' $click "; + push(@html, ""); + + push(@html, "") if ($after > 0); + } else { + +# article spans 1-day ==> optimize placement (less rows) for this single "); + } else { + push(@html, ""); + } + } + } + } + if ($calweekn eq "VERTICAL") { + push(@html, "") for (1..3-$actualRowsInWeek); # make week have 3 rows minimum + push(@html,"\n
        ".$w->strftime('%G-w%V')."
        '.$w->strftime('%G-w%V').'
        ".l2u($ww->strftime('%a %d %b'))." + push(@html,$caltr);$actualRowsInWeek++; + my $dur = 1+($artend-$artstart)/86400; + my $before = (($artstart-$w)/86400); if ($before <= 0) { $dur += $before; $before = 0; }; + my $item = ($dur,7-$before)[$dur > 7-$before]; + my $after = 7 - ($before+$item); + + push(@html, "$tdtext. +# @prehtml initially represents an empty week row (ie. 7 spots) populated as required with articles; +# number of rows grows as required (ie. when new articles use already populated spots). + my $i = ($artstart-$w)/86400; + my $done=0; + for my $row (@prehtml) { + if (!defined($row->[$i])) { $row->[$i] = [($w,@{$articles}[$ix],$artstart)]; $done=1; last } + } + if (!$done) { push(@prehtml,[(undef)x7]); $prehtml[-1]->[$i]= [($w,@{$articles}[$ix],$artstart)] } + } + } + + # format the @prehtml rows , adding them to calendar + for my $row (@prehtml) { + push(@html,$caltr);$actualRowsInWeek++; + for my $d ($row) { + for my $i (0..6) { + if (defined($d->[$i])) { + my ($w, $art, $artstart) = @{$d->[$i]}; + my $tdtext = calendarTD($w, $art, $artstart, $artstart); + my $bgcolor = "transparent"; + if ( $art->[G_CATEGORY] ne "" ) { + $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; + } + my $tip = articleTip($art); + my $click = ""; + if ($jsedit ne "") { + $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; + } + if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { + $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; + } + my $attr = " onMouseOver='showtip(event,\"$GAZETTECAT{$art->[G_CATEGORY]}{Name}\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='word-wrap: break-word;background-color: $bgcolor' $click "; + push(@html, "$tdtext
        \n"); + } else { + push(@html,"\n\n"); + } + } + push(@html, "
        $prevnextbar
        "); + return @html; + } + +# ---- Show one day, calendar like ------------------------------------------------------- + + if ($KWARGS{view} =~ /day/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtfrom->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + my $prevday=($dtfrom-86400)->strftime('%Y-%m-%d'); + my $nextday=($dtfrom+86400)->strftime('%Y-%m-%d'); + my $prevnextbar = "$prevday"; + $prevnextbar .= "$nextday"; + push(@html, "
        $prevnextbar
        "); + push(@html,""); + push(@html,''); + + # now 1 row per article + for my $art (@{$articles}) { + push(@html,''); + + my $tdtext = ""; + $tdtext .= articleTimes($art,$art->[G_STARTDATE]); + $tdtext .= $art->[G_SUBJECT]." "; + $tdtext .= articleWho($art)." "; + my $bgcolor = "transparent"; # td 'no-category' color just in case + if ( $art->[G_CATEGORY] ne "" ) { + $bgcolor = defined($GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}) ? $GAZETTECAT{$art->[G_CATEGORY]}{RGBlight} : "lightgrey"; + } + + # TODO: mouseover + my $tip = articleTip($art); + my $click = ""; + if ($jsedit ne "") { + $click = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "onclick=\"$jsedit(this,$art->[G_ID]);\"" : ""; + } + if ($click eq "" && $art->[G_CATEGORY] =~ /EVENT/i && $jsevent ne "") { + $click = "onclick=\"$jsevent('$art->[G_PLACE]')\""; + } + my $attr = " onMouseOver='showtip(event,\"$art->[G_CATEGORY]\",\"$tip\",\"$GAZETTECAT{$art->[G_CATEGORY]}{RGBlight}\")' onMouseOut='hidetip()' style='background-color: $bgcolor' $click "; + push(@html, ""); + } + push(@html,'
        '.l2u($dtfrom->strftime("$__{'gzt_fmt_long_date'}")).'
        $tdtext
        '); + + return @html; + } + + # ---- Show by date -------------------------------------------------------- + + if ($KWARGS{view} =~ /datelist/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + for ( my $d=$dtfrom, my $cnt=0; $d<=$dtto; $d+=86400, $cnt++) { # for each day starting on $d + my $ymd = $d->strftime('%Y-%m-%d'); + my $dayhtml = ""; + my @ixs = ixApplicable($articles,$d); # all articles indexes in result set, this day + for my $ix (@ixs) { # for each article + my $li = ""; + + # find wether article starts or ends on currently processed day + if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] || $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { + if ($ymd eq @{$articles}[$ix]->[G_STARTDATE] && $ymd eq @{$articles}[$ix]->[G_ENDDATE]) { + $li .= '
      • '.articleTimes(@{$articles}[$ix],$ymd)." "; + } else { + if ($ymd eq @{$articles}[$ix]->[G_STARTDATE]) { + my $until = @{$articles}[$ix]->[G_ENDDATE] eq '' ? "$__{'from now on'}" : "$__{until} @{$articles}[$ix]->[G_ENDDATE]"; + $li .= '
      • '."$until "; + } elsif ($ymd eq @{$articles}[$ix]->[G_ENDDATE]) { + $li .= '
      • '."$__{since} @{$articles}[$ix]->[G_STARTDATE] "; + } + } + } else { + +# not starting nor ending this day => report depending on SHOW_BYDATE_ONGOING variable + if ($ongoing !~ /NO/i) { + $li .= '
      • '; + $li .= "$__{'on going'} " if ($ongoing =~ /TEXT/i); + $li .= "$__{'since'} @{$articles}[$ix]->[G_STARTDATE] $__{until} @{$articles}[$ix]->[G_ENDDATE] " if ($ongoing =~ /DATE/i); + } else { next; } + } + my $rqcat = @{$articles}[$ix]->[G_CATEGORY]; + $li .= "$GAZETTECAT{$rqcat}{Name} "; + $li .= "@{$articles}[$ix]->[G_PLACE] "; + $li .= "- @{$articles}[$ix]->[G_SUBJECT] "; + $li .= "- ".articleWho(@{$articles}[$ix])." " ; + if ($jsedit ne "") { + $li .= (grep { /@{$articles}[$ix]->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; + } + $li .= "
        • "; + $dayhtml .= $li; + } + if ($dayhtml ne "") { # found things to display for this day + push(@html, "

        ".l2u($d->strftime("$__{gzt_fmt_date}"))."

        "."
          $dayhtml
        "); + } + + } + return @html; + } + + # ---- Show by category ------------------------------------------------ + + if ($KWARGS{view} =~ /categorylist/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'category,startdate,starttime'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + my $currentCat = ""; + for my $art (@{$articles}) { # for each article (ordered by category) + if ($art->[G_CATEGORY] ne $currentCat) { + push(@html,"") if ($currentCat ne ""); + $currentCat = $art->[G_CATEGORY]; + push(@html, "

        $GAZETTECAT{$currentCat}{Name}

          "); + } + my $htmlDate = ""; + if ($art->[G_STARTDATE] eq $art->[G_ENDDATE]) { + if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= $art->[G_STARTDATE]; } + elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME])" } + elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] (⇒ $art->[G_ENDTIME])"} + else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME] ⇒ $art->[G_ENDTIME])" } + } else { + if ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE]" } + elsif ($art->[G_STARTTIME] ne "" && $art->[G_ENDTIME] eq "") { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) " } + elsif ($art->[G_STARTTIME] eq "" && $art->[G_ENDTIME] ne "") { $htmlDate .= "$art->[G_STARTDATE] - $art->[G_ENDDATE] ($art->[G_ENDTIME])"} + else { $htmlDate .= "$art->[G_STARTDATE] ($art->[G_STARTTIME]) - $art->[G_ENDDATE] ($art->[G_ENDTIME])" } + } + + #articleWho() returns : [user1, user2] + others + my $allNames = articleWho($art); + my ($htmlNames,$htmlOthers) = split(/ \+ /,$allNames); + + my $htmlLi = ""; + if ($GAZETTECAT{$currentCat}{Format} eq "ndol") { + $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "ndlo") { + $htmlLi .= "$htmlNames - [$htmlDate] - $art->[G_PLACE] - $art->[G_SUBJECT]"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "ldon") { + $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "dlon") { + $htmlLi .= "$htmlDate - $art->[G_PLACE] - $art->[G_SUBJECT] - $htmlNames"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "andol") { + $htmlLi .= "$htmlOthers".($htmlNames ne "" ? ($htmlOthers ne "" ? ", ":"")."$htmlNames":"")." - [$htmlDate] - $art->[G_SUBJECT] - $art->[G_PLACE]"; + } + elsif ($GAZETTECAT{$currentCat}{Format} eq "adon") { + $htmlLi .= "$htmlOthers - [$htmlDate] - $art->[G_SUBJECT] - [$htmlNames]"; + } else { + $htmlLi .= "$art->[G_PLACE] - [$htmlDate] - $art->[G_SUBJECT] - $htmlNames"; + } + my $editicon = ""; + if ($jsedit ne "") { + $editicon = (grep { /$art->[G_CATEGORY]/ } @editableCat) ? "[G_ID]);\"" : "" ; + } + push(@html, "
        • $htmlLi $editicon
          • \n"); + } + push(@html, "
        ") if (@html); + return @html; + } + +# ---- Show raw selection for admins only------------------------------------------------ + + if ($KWARGS{view} =~ /dump/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { + my $articles; + if ($KWARGS{categories} =~ /^$|all/i) { # for dump, 'all' really means 'any' (known or unknown) categories + $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), order=> 'startdate,starttime,category'); + } else { + $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + } + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + push(@html,""); + for my $art (@{$articles}) { # each article + push(@html, "\n"); + } + push(@html, "
        IDSTARTDATESTARTTIMEENDDATEENDTIMECATEGORYUIDOTHERSPLACESUBJECTUpdatedUpdID
        ".join('', map { "$art->[$_]" } (0..11))."
        "); + return @html; + } + +# ---- Show statistics for admins only------------------------------------------------ + + if ($KWARGS{view} =~ /stats/i && WebObs::Users::clientHasAdm(type=>"authmisc",name=>"GAZETTE")) { + my ($dbh, $sql, $sth, $art); + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + push(@html,"

        Figures below apply to full Gazette (ie. selection criteria do NOT apply)

        "); + + $sql = "select count(*) from $dbtable"; + $sth = $dbh->prepare($sql); + $sth->execute(); + my $rsCountRows = $sth->fetchall_arrayref(); + push(@html,""); + for $art (@{$rsCountRows}) { + push(@html, "\n"); + } + push(@html, "
        Total number of articles
        $art->[0]
        "); + push(@html, "
        "); + + $sql = "select category, count(*) from $dbtable where category in (select distinct(category)) group by category order by category"; + $sth = $dbh->prepare($sql); + $sth->execute(); + my $rsCountCategories = $sth->fetchall_arrayref(); + push(@html,""); + for $art (@{$rsCountCategories}) { + my $catdef = "undefined"; + $catdef = "defined" if (exists($GAZETTECAT{$art->[0]})); + push(@html, "\n"); + } + push(@html, "
        Categoryin CATEGORIES_FILENumber of articles
        $art->[0]$catdef$art->[1]
        "); + + $dbh->disconnect; + return @html; + } + +# ---- Show as iCal --------------------------------------------------------------------- + + if ($KWARGS{view} =~ /ical/i) { + my $articles = getRaw(from=>$dtfrom->strftime('%Y-%m-%d'), to=>$dtto->strftime('%Y-%m-%d'), categories=>$incat, order=> 'startdate,starttime,category'); + if ($filter ne "") { @$articles = grep { (@$_[7..9] =~ /$filter/i) } @$articles } + + push(@html,"BEGIN:VCALENDAR\n"); + push(@html,"PRODID:-//webobs.ipgp.fr/gazette//EN\n"); + push(@html,"VERSION:2.0\n"); + for my $art (@{$articles}) { # each article + + # if "startdate starttime" can't parse : ignore article + # if "enddate endtime" can't parse : behave like no enddate specified + my $ds = eval { Time::Piece->strptime($art->[G_STARTDATE]." ".$art->[G_STARTTIME],'%Y-%m-%d %H:%M') } or next; + my $de = eval { Time::Piece->strptime($art->[G_ENDDATE]." ".$art->[G_ENDTIME],'%Y-%m-%d %H:%M') } or $art->[G_ENDDATE] = ""; + push(@html, "BEGIN:VEVENT\n"); + push(@html, "SUMMARY:$art->[G_SUBJECT]\n"); + push(@html, "DTSTART:".$ds->datetime."\n"); + if ($art->[G_ENDDATE] eq '') { + push(@html, "RRULE:FREQ=DAILY\n"); + } else { + push(@html, "DTEND:".$de->datetime."\n"); + } + push(@html, "LOCATION:$art->[G_PLACE]\n"); + push(@html, "CATEGORIES:$art->[G_CATEGORY]\n"); + my $id = $art->[G_UID]; $id =~ s/\+.*//; # take first id only + push(@html, "UID:$USERS{$USERIDS{$id}}{EMAIL}\n"); + push(@html, "END:VEVENT\n"); + } + push(@html, "END:VCALENDAR"); + + my $icsfn = "Gazette_".$WebObs::Users::CLIENT."_".$dtfrom->strftime('%Y-%m-%d')."_".$dtto->strftime('%Y-%m-%d').".ics"; + my $icsrc = ""; + if (open(WRT,">$WEBOBS{PATH_TMP_APACHE}/$icsfn")) { + print WRT @html; + close(WRT); + $icsrc = "$__{'saved as'} $icsfn"; + } else { $icsrc = "$__{'not saved'}" } + + #unshift(@html, "

        $icsrc

        "); + unshift(@html, "Download
        \n"); + + s/\n/
        / for @html; + return @html; + } } # ------------------------------------------------------------------------------------------- @@ -547,24 +565,24 @@ Example: =cut sub getRaw { - my %KWARGS = @_; - return 0 if ( !exists($KWARGS{from}) || !exists($KWARGS{to}) ); - my ($rs, $dbh, $sql, $sth); - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT,LASTUPD,LASTUPDUID "; - $sql .= "FROM $dbtable " ; - $sql .= "WHERE STARTDATE <= '".$KWARGS{to}."' AND (ENDDATE = '' OR ENDDATE >= '".$KWARGS{from}."') "; - $sql .= "AND CATEGORY IN (".$KWARGS{categories}.")" if (exists($KWARGS{categories}) && $KWARGS{categories} ne ''); - $sql .= " ORDER BY $KWARGS{order}" if exists($KWARGS{order}); - $sth = $dbh->prepare($sql); - $sth->execute(); - $rs = $sth->fetchall_arrayref(); - $dbh->disconnect; - return $rs; + my %KWARGS = @_; + return 0 if ( !exists($KWARGS{from}) || !exists($KWARGS{to}) ); + my ($rs, $dbh, $sql, $sth); + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT,LASTUPD,LASTUPDUID "; + $sql .= "FROM $dbtable " ; + $sql .= "WHERE STARTDATE <= '".$KWARGS{to}."' AND (ENDDATE = '' OR ENDDATE >= '".$KWARGS{from}."') "; + $sql .= "AND CATEGORY IN (".$KWARGS{categories}.")" if (exists($KWARGS{categories}) && $KWARGS{categories} ne ''); + $sql .= " ORDER BY $KWARGS{order}" if exists($KWARGS{order}); + $sth = $dbh->prepare($sql); + $sth->execute(); + $rs = $sth->fetchall_arrayref(); + $dbh->disconnect; + return $rs; } # ------------------------------------------------------------------------------------------- @@ -579,18 +597,18 @@ as a string suitable for an SQL insert 'values' clause. =cut sub setArticle { - return 0 if (@_ != 1); - my ($dbh, $sql, $rv); - - my $values = "$_[0],datetime('now'),'$USERS{$CLIENT}{UID}'"; - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; - $sql = "INSERT OR REPLACE INTO $dbtable VALUES( $values )"; - $rv = $dbh->do($sql); - $rv = 0 if ($rv == 0E0); - $rv = sprintf("%d row%s %s",$rv,($rv<=1)?"":"s",$DBI::errstr); - - $dbh->disconnect; - return $rv; + return 0 if (@_ != 1); + my ($dbh, $sql, $rv); + + my $values = "$_[0],datetime('now'),'$USERS{$CLIENT}{UID}'"; + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; + $sql = "INSERT OR REPLACE INTO $dbtable VALUES( $values )"; + $rv = $dbh->do($sql); + $rv = 0 if ($rv == 0E0); + $rv = sprintf("%d row%s %s",$rv,($rv<=1)?"":"s",$DBI::errstr); + + $dbh->disconnect; + return $rv; } # ------------------------------------------------------------------------------------------- @@ -612,28 +630,28 @@ Also refer to vedit.pl for Event management considerations. =cut sub setEventArticle { - return 0 if (@_ != 5); - my ($object, $evname, $titre, $oper,$eve) = @_; - (my $evp = $evname) =~ s/\.txt//; - my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); - my ($ed2,$et2) = split(/_/,$eve); - $et = ($et eq "NA") ? "" : $et; - $et =~ s/-/:/; - $titre = "(v$ev) $titre" if (defined($ev)); - $titre =~ s/'/''/g; - my $values = sprintf("%s,'%s','%s','%s','%s','%s','%s','%s','%s','%s'", - "null", - $ed, - $et, - $ed2, - $et2, - "Event", - $oper, - '', - $object, - $titre); - my $row = setArticle($values); - return $row; + return 0 if (@_ != 5); + my ($object, $evname, $titre, $oper,$eve) = @_; + (my $evp = $evname) =~ s/\.txt//; + my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); + my ($ed2,$et2) = split(/_/,$eve); + $et = ($et eq "NA") ? "" : $et; + $et =~ s/-/:/; + $titre = "(v$ev) $titre" if (defined($ev)); + $titre =~ s/'/''/g; + my $values = sprintf("%s,'%s','%s','%s','%s','%s','%s','%s','%s','%s'", + "null", + $ed, + $et, + $ed2, + $et2, + "Event", + $oper, + '', + $object, + $titre); + my $row = setArticle($values); + return $row; } # ------------------------------------------------------------------------------------------- @@ -647,17 +665,17 @@ Delete an article in DB. Required argument is article's ID =cut sub delArticle { - return 0 if (@_ != 1); - my ($dbh, $sql, $rv); + return 0 if (@_ != 1); + my ($dbh, $sql, $rv); - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; - $sql = "DELETE FROM $dbtable WHERE ID= $_[0]"; - $rv = $dbh->do($sql); - $rv = 0 if ($rv == 0E0); - $rv = sprintf("(%d row%s) %s",$rv,($rv<=1)?"":"s",$DBI::errstr); + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") or die "DB connect to ".$dbname." failed: ".DBI->errstr; + $sql = "DELETE FROM $dbtable WHERE ID= $_[0]"; + $rv = $dbh->do($sql); + $rv = 0 if ($rv == 0E0); + $rv = sprintf("(%d row%s) %s",$rv,($rv<=1)?"":"s",$DBI::errstr); - $dbh->disconnect; - return $rv; + $dbh->disconnect; + return $rv; } # ------------------------------------------------------------------------------------------- @@ -680,32 +698,32 @@ Returns 0 or number of rows deleted. =cut sub delEventArticle { - return 0 if (@_ != 2); - my ($object,$evname) = @_; - (my $evp = $evname) =~ s/\.txt//; - my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); - $et = "" if ($et eq "NA"); - $et =~ s/-/:/; - - my $where .= "STARTDATE = '$ed' "; - $where .= "AND STARTTIME = '$et' "; - $where .= "AND CATEGORY = 'Event' "; - $where .= "AND PLACE = '$object' "; - $where .= "AND SUBJECT LIKE '(v$ev)%'" if (defined($ev)); - - my ($rs, $dbh, $sql, $sth); - my $rv = 0; - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - $sql = "DELETE FROM $dbtable WHERE $where" ; - $rv = $dbh->do($sql); - $rv = 0 if ($rv == 0E0); - - $dbh->disconnect; - return $rv; + return 0 if (@_ != 2); + my ($object,$evname) = @_; + (my $evp = $evname) =~ s/\.txt//; + my ($en,$ed,$et,$ev) = split(/_/,basename($evp)); + $et = "" if ($et eq "NA"); + $et =~ s/-/:/; + + my $where .= "STARTDATE = '$ed' "; + $where .= "AND STARTTIME = '$et' "; + $where .= "AND CATEGORY = 'Event' "; + $where .= "AND PLACE = '$object' "; + $where .= "AND SUBJECT LIKE '(v$ev)%'" if (defined($ev)); + + my ($rs, $dbh, $sql, $sth); + my $rv = 0; + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + $sql = "DELETE FROM $dbtable WHERE $where" ; + $rv = $dbh->do($sql); + $rv = 0 if ($rv == 0E0); + + $dbh->disconnect; + return $rv; } # ------------------------------------------------------------------------------------------- @@ -719,28 +737,28 @@ get one article as a JSON object. Required argument is article's ID. =cut sub getArticle { - return 0 if (@_ != 1); - my $id = $_[0]; - my ($rs, $dbh, $sql, $sth); - my $row = ""; - - $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") - or die "DB error connecting to ".$dbname.": ".DBI->errstr; - $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; - - $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT "; - $sql .= "FROM $dbtable WHERE ID=$_[0]" ; - $sth = $dbh->prepare($sql); - $sth->execute(); - while ($rs = $sth->fetchrow_hashref()) { - while ((my $key, my $value) = each(%$rs)){ - $value =~ s/\Q"\E/"/g; - $row .= "\"$key\": \"$value\","; - } - } - $row =~ s/,$//; - $dbh->disconnect; - return "{ $row }"; + return 0 if (@_ != 1); + my $id = $_[0]; + my ($rs, $dbh, $sql, $sth); + my $row = ""; + + $dbh = DBI->connect( "dbi:SQLite:".$dbname,"","") + or die "DB error connecting to ".$dbname.": ".DBI->errstr; + $dbh->{PrintError} = 1; $dbh->{RaiseError} = 1; + + $sql = "SELECT ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT "; + $sql .= "FROM $dbtable WHERE ID=$_[0]" ; + $sth = $dbh->prepare($sql); + $sth->execute(); + while ($rs = $sth->fetchrow_hashref()) { + while ((my $key, my $value) = each(%$rs)){ + $value =~ s/\Q"\E/"/g; + $row .= "\"$key\": \"$value\","; + } + } + $row =~ s/,$//; + $dbh->disconnect; + return "{ $row }"; } # ------------------------------------------------------------------------------------------- @@ -756,22 +774,22 @@ intended to only report times on start and end day of a range (suitable for week =cut sub articleTimes { - return undef if (@_ != 2) ; - my $ptr = $_[0]; my $ymd = $_[1]; - my $ret = ""; - if ($ptr->[G_STARTDATE] eq $ptr->[G_ENDDATE]) { - if (($ptr->[G_STARTTIME] ne "") || ($ptr->[G_STARTTIME] ne "")) { - $ret = "$ptr->[G_STARTTIME]⇒$ptr->[G_ENDTIME] "; - } - } else { - if ($ymd eq $ptr->[G_STARTDATE] && $ptr->[G_STARTTIME] ne "") { - $ret = "$ptr->[G_STARTTIME]⇒ "; - } - if ($ymd eq $ptr->[G_ENDDATE] && $ptr->[G_ENDTIME] ne "") { - $ret = "⇒$ptr->[G_ENDTIME] "; - } - } - return $ret; + return undef if (@_ != 2) ; + my $ptr = $_[0]; my $ymd = $_[1]; + my $ret = ""; + if ($ptr->[G_STARTDATE] eq $ptr->[G_ENDDATE]) { + if (($ptr->[G_STARTTIME] ne "") || ($ptr->[G_STARTTIME] ne "")) { + $ret = "$ptr->[G_STARTTIME]⇒$ptr->[G_ENDTIME] "; + } + } else { + if ($ymd eq $ptr->[G_STARTDATE] && $ptr->[G_STARTTIME] ne "") { + $ret = "$ptr->[G_STARTTIME]⇒ "; + } + if ($ymd eq $ptr->[G_ENDDATE] && $ptr->[G_ENDTIME] ne "") { + $ret = "⇒$ptr->[G_ENDTIME] "; + } + } + return $ret; } # ------------------------------------------------------------------------------------------- @@ -787,17 +805,18 @@ eg. [user1, user2] + others =cut sub articleWho { - return undef if (@_ != 1); - my $art = $_[0]; my $listFullNames = ""; - if ($art->[G_UID] ne "") { - $listFullNames = "[".join(', ', map { WebObs::Users::userName($_)} split(/\+/,$art->[G_UID]))."]"; - } - if ($art->[G_OTHERS] ne "") { - #$listFullNames .= " + $art->[G_OTHERS]"; - (my $o = $art->[G_OTHERS]) =~ s/ \+ / , /g; # "+" to commas, because "+" used to split later - $listFullNames .= " + ".($o); - } - return $listFullNames; + return undef if (@_ != 1); + my $art = $_[0]; my $listFullNames = ""; + if ($art->[G_UID] ne "") { + $listFullNames = "[".join(', ', map { WebObs::Users::userName($_)} split(/\+/,$art->[G_UID]))."]"; + } + if ($art->[G_OTHERS] ne "") { + + #$listFullNames .= " + $art->[G_OTHERS]"; + (my $o = $art->[G_OTHERS]) =~ s/ \+ / , /g; # "+" to commas, because "+" used to split later + $listFullNames .= " + ".($o); + } + return $listFullNames; } # ------------------------------------------------------------------------------------------- @@ -812,27 +831,27 @@ for article 'art' in week 'w' =cut sub calendarTD { - return undef if (@_ != 4) ; my ($w, $art, $artstart, $artend) = @_; - my $tdtext = my $t1 = my $r1 = ""; - if ($artstart == $artend) { - $tdtext .= ("$art->[G_STARTTIME]$art->[G_ENDTIME]" ne "") ? "$art->[G_STARTTIME]⇒$art->[G_ENDTIME] " : ""; - } else { - $tdtext .= ($artstart >= $w && $artstart <= $w+6*86400 && "$art->[G_STARTTIME]" ne "") ? "
        $art->[G_STARTTIME]⇒
        " : ""; - } - $t1 = substr($art->[G_SUBJECT],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; - if (length($art->[G_SUBJECT])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } - $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; - $t1 = substr($art->[G_UID],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; - if (length($art->[G_UID])>$tdtrunc) { $r1 = rindex($t1,"+"); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } - $t1 =~ s/\Q'\E/'/g; $tdtext .= (length($t1)>0) ? "[$t1] " : " "; - $t1 = substr($art->[G_OTHERS],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; - if (length($art->[G_OTHERS])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } - $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; - - if ($artstart != $artend) { - $tdtext .= ($artend >= $w && $artend <= $w+6*86400 && "$art->[G_ENDTIME]" ne "") ? "
        ⇒ $art->[G_ENDTIME]
        " : ""; - } - return $tdtext; + return undef if (@_ != 4) ; my ($w, $art, $artstart, $artend) = @_; + my $tdtext = my $t1 = my $r1 = ""; + if ($artstart == $artend) { + $tdtext .= ("$art->[G_STARTTIME]$art->[G_ENDTIME]" ne "") ? "$art->[G_STARTTIME]⇒$art->[G_ENDTIME] " : ""; + } else { + $tdtext .= ($artstart >= $w && $artstart <= $w+6*86400 && "$art->[G_STARTTIME]" ne "") ? "
        $art->[G_STARTTIME]⇒
        " : ""; + } + $t1 = substr($art->[G_SUBJECT],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; + if (length($art->[G_SUBJECT])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } + $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; + $t1 = substr($art->[G_UID],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; + if (length($art->[G_UID])>$tdtrunc) { $r1 = rindex($t1,"+"); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } + $t1 =~ s/\Q'\E/'/g; $tdtext .= (length($t1)>0) ? "[$t1] " : " "; + $t1 = substr($art->[G_OTHERS],0,$tdtrunc); $t1 =~ s/\Q"\E/"/g; + if (length($art->[G_OTHERS])>$tdtrunc) { $r1 = rindex($t1," "); $t1 = sprintf("%s…",($r1>0)?substr($t1,0,$r1):$t1) } + $t1 =~ s/\Q'\E/'/g; $tdtext .= "$t1 "; + + if ($artstart != $artend) { + $tdtext .= ($artend >= $w && $artend <= $w+6*86400 && "$art->[G_ENDTIME]" ne "") ? "
        ⇒ $art->[G_ENDTIME]
        " : ""; + } + return $tdtext; } # ------------------------------------------------------------------------------------------- @@ -846,16 +865,16 @@ articleTip(article) internal helper to return the tip (popup) contents for artic =cut sub articleTip { - return undef if (@_ != 1); - my $art = $_[0]; my $text = ""; my $qq = ""; - $text .= "$__{'Who'}: $art->[G_UID]
        "; - ($qq = $art->[G_SUBJECT]) =~ s/\Q"\E/″/g; $text .= "$__{'Subject'}: $qq
        "; - $text .= "$__{'Date'}: $art->[G_STARTDATE] $art->[G_STARTTIME] ⇒ $art->[G_ENDDATE] $art->[G_ENDTIME]
        "; - ($qq = $art->[G_PLACE]) =~ s/\Q"\E/″/g; $text .= "$__{'Place'}: $qq
        "; - $text =~ s/\Q'\E/'/g; - return $text; + return undef if (@_ != 1); + my $art = $_[0]; my $text = ""; my $qq = ""; + $text .= "$__{'Who'}: $art->[G_UID]
        "; + ($qq = $art->[G_SUBJECT]) =~ s/\Q"\E/″/g; $text .= "$__{'Subject'}: $qq
        "; + $text .= "$__{'Date'}: $art->[G_STARTDATE] $art->[G_STARTTIME] ⇒ $art->[G_ENDDATE] $art->[G_ENDTIME]
        "; + ($qq = $art->[G_PLACE]) =~ s/\Q"\E/″/g; $text .= "$__{'Place'}: $qq
        "; + $text =~ s/\Q'\E/'/g; + return $text; } - + # ------------------------------------------------------------------------------------------- =pod @@ -877,11 +896,11 @@ The list of 'applicable' indexes of 'rs' is returned as an array. =cut sub ixApplicable { - return undef if (@_ < 2) ; - my ($rs, $dtfrom) = @_ ; - my $dtto = (@_ == 3) ? $_[2] : $dtfrom; - my $f = $dtfrom->strftime('%Y-%m-%d'); my $t = $dtto->strftime('%Y-%m-%d'); - return grep { @{$rs}[$_]->[G_STARTDATE] le $t && (@{$rs}[$_]->[G_ENDDATE] ge $f || @{$rs}[$_]->[G_ENDDATE] eq '') } (0..@{$rs}-1); + return undef if (@_ < 2) ; + my ($rs, $dtfrom) = @_ ; + my $dtto = (@_ == 3) ? $_[2] : $dtfrom; + my $f = $dtfrom->strftime('%Y-%m-%d'); my $t = $dtto->strftime('%Y-%m-%d'); + return grep { @{$rs}[$_]->[G_STARTDATE] le $t && (@{$rs}[$_]->[G_ENDDATE] ge $f || @{$rs}[$_]->[G_ENDDATE] eq '') } (0..@{$rs}-1); } 1; diff --git a/CODE/perl/lib/Grids.pm b/CODE/perl/lib/Grids.pm index fd0a2ffc..6027ca2f 100644 --- a/CODE/perl/lib/Grids.pm +++ b/CODE/perl/lib/Grids.pm @@ -42,29 +42,29 @@ $VERSION = "1.00"; %DOMAINS = readDomain(); if (-e $WEBOBS{FILE_OWNERS}) { - %OWNRS = readCfg($WEBOBS{FILE_OWNERS}); + %OWNRS = readCfg($WEBOBS{FILE_OWNERS}); } #FB-was: if (-e $WEBOBS{FILE_DISCIPLINES}) { %DISCP = readCfg($WEBOBS{FILE_DISCIPLINES}); } if (-e $WEBOBS{CONF_NODES}) { - %NODES = readCfg($WEBOBS{CONF_NODES}); + %NODES = readCfg($WEBOBS{CONF_NODES}); } if (-e $WEBOBS{CONF_GRIDS}) { - %GRIDS = readCfg($WEBOBS{CONF_GRIDS}); + %GRIDS = readCfg($WEBOBS{CONF_GRIDS}); } # %node2node: hash key = 'parentnode|feature', hash value = 'childnode' or 'childnode1|childnode2|...' if (-e $NODES{FILE_NODES2NODES}) { - my @file_node2node = readCfgFile("$NODES{FILE_NODES2NODES}"); - for (@file_node2node) { - if ($_ =~ /.+\|.+\|.+/) { - my ($parent_node,$feature,$children_node) = split(/\|/,$_); - my $key_link = $parent_node."|".$feature; - $node2node{$key_link} .= (exists($node2node{$key_link}) ? "|":"").$children_node; - } - } + my @file_node2node = readCfgFile("$NODES{FILE_NODES2NODES}"); + for (@file_node2node) { + if ($_ =~ /.+\|.+\|.+/) { + my ($parent_node,$feature,$children_node) = split(/\|/,$_); + my $key_link = $parent_node."|".$feature; + $node2node{$key_link} .= (exists($node2node{$key_link}) ? "|":"").$children_node; + } + } } =pod @@ -82,15 +82,15 @@ Reads all 'domains' configurations into a HoH. =cut sub readDomain { - my %ret; - my @dom = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select CODE,OOA,NAME from $WEBOBS{SQL_TABLE_DOMAINS} order by OOA"); - chomp(@dom); - for (@dom) { - my @tmp = split(/\|/,$_); - $ret{$tmp[0]}{OOA} = $tmp[1]; - $ret{$tmp[0]}{NAME} = $tmp[2]; - } - return %ret; + my %ret; + my @dom = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select CODE,OOA,NAME from $WEBOBS{SQL_TABLE_DOMAINS} order by OOA"); + chomp(@dom); + for (@dom) { + my @tmp = split(/\|/,$_); + $ret{$tmp[0]}{OOA} = $tmp[1]; + $ret{$tmp[0]}{NAME} = $tmp[2]; + } + return %ret; } =pod @@ -113,29 +113,32 @@ Internally uses WebObs::listProcNames. =cut sub readProc { - my %ret; - for my $f (listProcNames($_[0])) { - my %tmp = readCfg("$WEBOBS{PATH_PROCS}/$f/$f.conf",@_[1..$#_]); - # --- get list of associated NODES - opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); - my @lSn = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); - foreach (@lSn) {s/^PROC\.($f)\.//g}; - @lSn = sort {$a cmp $b} @lSn ; - $tmp{'NODESLIST'} = \@lSn; - closedir(DIR); - # --- get list of associated FORMS - opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); - my @lSf = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2FORMS}."/".$_} readdir(DIR); - foreach (@lSf) {s/^PROC\.($f)\.//g}; - $tmp{'FORM'} = $lSf[0]; #NOTE: keeps only the first FORM - closedir(DIR); - # --- get DOMAIN - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'PROC' and NAME = '$f'"); - chomp(@qx); - $tmp{'DOMAIN'} = join('|',@qx); - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listProcNames($_[0])) { + my %tmp = readCfg("$WEBOBS{PATH_PROCS}/$f/$f.conf",@_[1..$#_]); + + # --- get list of associated NODES + opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); + my @lSn = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); + foreach (@lSn) {s/^PROC\.($f)\.//g}; + @lSn = sort {$a cmp $b} @lSn ; + $tmp{'NODESLIST'} = \@lSn; + closedir(DIR); + + # --- get list of associated FORMS + opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); + my @lSf = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2FORMS}."/".$_} readdir(DIR); + foreach (@lSf) {s/^PROC\.($f)\.//g}; + $tmp{'FORM'} = $lSf[0]; #NOTE: keeps only the first FORM + closedir(DIR); + + # --- get DOMAIN + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'PROC' and NAME = '$f'"); + chomp(@qx); + $tmp{'DOMAIN'} = join('|',@qx); + $ret{$f}=\%tmp; + } + return %ret; } =head2 readSefran @@ -153,25 +156,27 @@ Internally uses WebObs::listSefranNames. =cut sub readSefran { - my %ret; - for my $f (listSefranNames($_[0])) { - my %tmp = readCfg("$WEBOBS{PATH_SEFRANS}/$f/$f.conf"); - $tmp{NAME} ||= $tmp{TITRE}; - # --- get channels list - my @ch = readCfgFile(exists($tmp{CHANNEL_CONF}) ? "$tmp{CHANNEL_CONF}":"$WEBOBS{PATH_SEFRANS}/$f/channels.conf"); - my @st; - for (@ch) { - my ($ali,$cod) = split(/\s+/,$_); - push(@st,$ali); - } - $tmp{'CHANNELLIST'} = join('|',@st); - # --- get DOMAIN - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'SEFRAN' and NAME = '$f'"); - chomp(@qx); - $tmp{'DOMAIN'} = join('|',@qx); - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listSefranNames($_[0])) { + my %tmp = readCfg("$WEBOBS{PATH_SEFRANS}/$f/$f.conf"); + $tmp{NAME} ||= $tmp{TITRE}; + + # --- get channels list + my @ch = readCfgFile(exists($tmp{CHANNEL_CONF}) ? "$tmp{CHANNEL_CONF}":"$WEBOBS{PATH_SEFRANS}/$f/channels.conf"); + my @st; + for (@ch) { + my ($ali,$cod) = split(/\s+/,$_); + push(@st,$ali); + } + $tmp{'CHANNELLIST'} = join('|',@st); + + # --- get DOMAIN + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'SEFRAN' and NAME = '$f'"); + chomp(@qx); + $tmp{'DOMAIN'} = join('|',@qx); + $ret{$f}=\%tmp; + } + return %ret; } =pod @@ -189,21 +194,21 @@ Internally uses WebObs::listViewNames. =cut sub readView { - my %ret; - for my $f (listViewNames($_[0])) { - my %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$f/$f.conf"); - opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); - my @l = grep {/^VIEW\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); - foreach (@l) {s/^VIEW\.($f)\.//g}; - @l = sort {$a cmp $b} @l ; - $tmp{'NODESLIST'} = \@l; - closedir(DIR); - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'VIEW' and NAME = '$f'"); - chomp(@qx); - $tmp{'DOMAIN'} = $qx[0]; - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listViewNames($_[0])) { + my %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$f/$f.conf"); + opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); + my @l = grep {/^VIEW\.($f)\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); + foreach (@l) {s/^VIEW\.($f)\.//g}; + @l = sort {$a cmp $b} @l ; + $tmp{'NODESLIST'} = \@l; + closedir(DIR); + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = 'VIEW' and NAME = '$f'"); + chomp(@qx); + $tmp{'DOMAIN'} = $qx[0]; + $ret{$f}=\%tmp; + } + return %ret; } =pod @@ -217,23 +222,23 @@ Adds DOMAIN code from grids2domains db =cut sub readGrid { - my %ret; - my %tmp; - my $f = $_[0]; - my ($gt,$gn) = split(/\./,$f); - my $z = "PATH_${gt}S"; - %tmp = readCfg("$WEBOBS{$z}/$gn/$gn.conf"); - opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); - my @l = grep {/^$f\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); - foreach (@l) {s/^$f\.//g}; - @l = sort {$a cmp $b} @l ; - $tmp{'NODESLIST'} = \@l; - closedir(DIR); - my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = '$gt' and NAME = '$gn'"); - chomp(@qx); - $tmp{'DOMAIN'} = $qx[0]; - $ret{$f}=\%tmp; - return %ret; + my %ret; + my %tmp; + my $f = $_[0]; + my ($gt,$gn) = split(/\./,$f); + my $z = "PATH_${gt}S"; + %tmp = readCfg("$WEBOBS{$z}/$gn/$gn.conf"); + opendir(DIR, "$WEBOBS{PATH_GRIDS2NODES}"); + my @l = grep {/^$f\./ && -l $WEBOBS{PATH_GRIDS2NODES}."/".$_} readdir(DIR); + foreach (@l) {s/^$f\.//g}; + @l = sort {$a cmp $b} @l ; + $tmp{'NODESLIST'} = \@l; + closedir(DIR); + my @qx = qx(sqlite3 $WEBOBS{SQL_DOMAINS} "select DCODE from $WEBOBS{SQL_TABLE_GRIDS} where TYPE = '$gt' and NAME = '$gn'"); + chomp(@qx); + $tmp{'DOMAIN'} = $qx[0]; + $ret{$f}=\%tmp; + return %ret; } @@ -249,29 +254,33 @@ Internally uses WebObs::listNodeNames. =cut sub readNode { - my %ret; - for my $f (listNodeNames($_[0])) { - my %tmp = readCfg("$NODES{PATH_NODES}/$f/$f.cnf","escape",@_[1..$#_]); - #FB-legacy: if TYPE not defined and old type.txt exists, loads it - if (!$tmp{TYPE}) { - my $typ = "$NODES{PATH_NODES}/$f/type.txt"; - if ((-e $typ) && (-s $typ != 0)) { - $tmp{TYPE} = trim(join("",readFile($typ))); - } - } - $tmp{PROJECT} = 1 if (-s "$NODES{PATH_NODES}/$f/$NODES{SPATH_INTERVENTIONS}/${f}_Projet.txt"); - #substitutes possible decimal comma to point for numerics - $tmp{LAT_WGS84} =~ s/,/./g; - $tmp{LON_WGS84} =~ s/,/./g; - #FB-legacy: removes escape characters in feature's list - $tmp{FILES_FEATURES} =~ s/\\,/,/g; - $tmp{FILES_FEATURES} =~ s/\\\|/,/g; - # removes trailing blanks in each features - $tmp{FILES_FEATURES} = join(",",map {trim($_)} split(/[,\|]/,$tmp{FILES_FEATURES})); - - $ret{$f}=\%tmp; - } - return %ret; + my %ret; + for my $f (listNodeNames($_[0])) { + my %tmp = readCfg("$NODES{PATH_NODES}/$f/$f.cnf","escape",@_[1..$#_]); + + #FB-legacy: if TYPE not defined and old type.txt exists, loads it + if (!$tmp{TYPE}) { + my $typ = "$NODES{PATH_NODES}/$f/type.txt"; + if ((-e $typ) && (-s $typ != 0)) { + $tmp{TYPE} = trim(join("",readFile($typ))); + } + } + $tmp{PROJECT} = 1 if (-s "$NODES{PATH_NODES}/$f/$NODES{SPATH_INTERVENTIONS}/${f}_Projet.txt"); + + #substitutes possible decimal comma to point for numerics + $tmp{LAT_WGS84} =~ s/,/./g; + $tmp{LON_WGS84} =~ s/,/./g; + + #FB-legacy: removes escape characters in feature's list + $tmp{FILES_FEATURES} =~ s/\\,/,/g; + $tmp{FILES_FEATURES} =~ s/\\\|/,/g; + + # removes trailing blanks in each features + $tmp{FILES_FEATURES} = join(",",map {trim($_)} split(/[,\|]/,$tmp{FILES_FEATURES})); + + $ret{$f}=\%tmp; + } + return %ret; } =pod @@ -288,16 +297,17 @@ it will be used as a regexp to select view names. =cut sub listViewNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $WEBOBS{PATH_VIEWS}) or die "can't opendir $WEBOBS{PATH_VIEWS}: $!"; - my @list = grep {/($filter)/ && -d $WEBOBS{PATH_VIEWS}."/".$_} readdir(DIR); - closedir(DIR); - my @finallist; - for (@list) { - push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authviews')); - } - return @finallist; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $WEBOBS{PATH_VIEWS}) or die "can't opendir $WEBOBS{PATH_VIEWS}: $!"; + my @list = grep {/($filter)/ && -d $WEBOBS{PATH_VIEWS}."/".$_} readdir(DIR); + closedir(DIR); + my @finallist; + for (@list) { + push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authviews')); + } + return @finallist; } =pod @@ -314,16 +324,17 @@ it will be used as a regexp to select proc names. =cut sub listProcNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $WEBOBS{PATH_PROCS}) or die "can't opendir $WEBOBS{PATH_PROCS}: $!"; - my @list = grep {/($filter)/ && -d $WEBOBS{PATH_PROCS}."/".$_} readdir(DIR); - closedir(DIR); - my @finallist; - for (@list) { - push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authprocs')); - } - return @finallist; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $WEBOBS{PATH_PROCS}) or die "can't opendir $WEBOBS{PATH_PROCS}: $!"; + my @list = grep {/($filter)/ && -d $WEBOBS{PATH_PROCS}."/".$_} readdir(DIR); + closedir(DIR); + my @finallist; + for (@list) { + push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$_,type=>'authprocs')); + } + return @finallist; } =pod @@ -340,19 +351,20 @@ it will be used as a regexp to select proc names. =cut sub listSefranNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $WEBOBS{PATH_SEFRANS}) or die "can't opendir $WEBOBS{PATH_SEFRANS}: $!"; - my @list = grep {/($filter)/ && -d $WEBOBS{PATH_SEFRANS}."/".$_} readdir(DIR); - closedir(DIR); - my @finallist; - for (@list) { - my $mc = qx(grep -E "^MC3_NAME\\|" $WEBOBS{PATH_SEFRANS}/$_/$_.conf); - chomp($mc); - $mc =~ s/^MC3_NAME\|//g; - push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$mc,type=>'authprocs')); - } - return @finallist; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $WEBOBS{PATH_SEFRANS}) or die "can't opendir $WEBOBS{PATH_SEFRANS}: $!"; + my @list = grep {/($filter)/ && -d $WEBOBS{PATH_SEFRANS}."/".$_} readdir(DIR); + closedir(DIR); + my @finallist; + for (@list) { + my $mc = qx(grep -E "^MC3_NAME\\|" $WEBOBS{PATH_SEFRANS}/$_/$_.conf); + chomp($mc); + $mc =~ s/^MC3_NAME\|//g; + push(@finallist, $_) if (WebObs::Users::clientHasRead(name=>$mc,type=>'authprocs')); + } + return @finallist; } =pod @@ -369,12 +381,13 @@ it will be used as a regexp to select node names. =cut sub listNodeNames { - #$_[0] will be used as a regexp - my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; - opendir(DIR, $NODES{PATH_NODES}) or die "can't opendir $NODES{PATH_NODES}: $!"; - my @list = grep {/($filter)/ && -d $NODES{PATH_NODES}."/".$_} readdir(DIR); - closedir(DIR); - return @list; + + #$_[0] will be used as a regexp + my $filter = defined($_[0]) ? $_[0] : "^[^\.]"; + opendir(DIR, $NODES{PATH_NODES}) or die "can't opendir $NODES{PATH_NODES}: $!"; + my @list = grep {/($filter)/ && -d $NODES{PATH_NODES}."/".$_} readdir(DIR); + closedir(DIR); + return @list; } =pod @@ -400,19 +413,20 @@ type, if not specified, will default to ALL grid types (ie. VIEW and PROC). =cut sub listNodeGrids { - my %KWARGS = @_; - my $filterT = $KWARGS{type} && $KWARGS{type} =~ /^VIEW$|^PROC$/ ? $KWARGS{type} : ''; - #my $filterS = $KWARGS{node} ? $KWARGS{node} : ''; - my $filterS = $KWARGS{node} ? $KWARGS{node} : undef; - - my @s = listNodeNames($filterS); - my $g = "$WEBOBS{PATH_GRIDS2NODES}/"; - my %rs; - foreach (@s) { - my @l = grep(s{$g/}{}g, <$g/$filterT*$_>); - $rs{$_}=[grep(s{\.[^.]*$}{}, @l)]; - } - return %rs; + my %KWARGS = @_; + my $filterT = $KWARGS{type} && $KWARGS{type} =~ /^VIEW$|^PROC$/ ? $KWARGS{type} : ''; + + #my $filterS = $KWARGS{node} ? $KWARGS{node} : ''; + my $filterS = $KWARGS{node} ? $KWARGS{node} : undef; + + my @s = listNodeNames($filterS); + my $g = "$WEBOBS{PATH_GRIDS2NODES}/"; + my %rs; + foreach (@s) { + my @l = grep(s{$g/}{}g, <$g/$filterT*$_>); + $rs{$_}=[grep(s{\.[^.]*$}{}, @l)]; + } + return %rs; } =pod @@ -429,22 +443,22 @@ returns a hash of grid names: =cut sub listNameGrids { - my %rs; - my $n; - my %tmp; - my @V = listViewNames; - foreach (@V) { - $n = "VIEW.$_"; - %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$_/$_.conf"); - $rs{$n} = $tmp{'NAME'}; - } - my @P = listProcNames; - foreach (@P) { - $n = "PROC.$_"; - %tmp = readCfg("$WEBOBS{PATH_PROCS}/$_/$_.conf"); - $rs{$n} = $tmp{'NAME'}; - } - return %rs; + my %rs; + my $n; + my %tmp; + my @V = listViewNames; + foreach (@V) { + $n = "VIEW.$_"; + %tmp = readCfg("$WEBOBS{PATH_VIEWS}/$_/$_.conf"); + $rs{$n} = $tmp{'NAME'}; + } + my @P = listProcNames; + foreach (@P) { + $n = "PROC.$_"; + %tmp = readCfg("$WEBOBS{PATH_PROCS}/$_/$_.conf"); + $rs{$n} = $tmp{'NAME'}; + } + return %rs; } =pod @@ -488,46 +502,48 @@ is then considered 'active' if one of isodateStart and isodateEnd (or both) fall =cut sub listGridNodes { - use Time::Piece; - my %KWARGS = @_; - my $grid = $KWARGS{grid} ? $KWARGS{grid} : undef; - my $valid = $KWARGS{valid} ? $KWARGS{valid} : undef; - my $acton = $KWARGS{active} ? $KWARGS{active} : undef; - my $today = my $deb = my $fin = ''; - if (defined($acton)) { - $today = strftime( '%Y-%m-%d', localtime ); - ($deb,$fin) = split(/:/,$acton); - if (!$fin) {$fin = $deb} - $deb =~ s/today/$today/; - $fin =~ s/today/$today/; - eval { $deb = Time::Piece->strptime($deb,"%Y-%m-%d") }; if ($@) { $deb = Time::Piece->strptime("","%Y-%m-%d") } - # FIX: 2038 for Perl 32-bits dates; WAS: eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("9999","%Y-%m-%d") } - eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("2038","%Y-%m-%d") } - } - my %vlist; - if (defined($grid)) { - $grid = ($grid =~ /\./) ? $grid : "*.$grid"; - my @list = qx (ls -L $WEBOBS{PATH_GRIDS2NODES}/$grid.*/*.cnf 2>/dev/null); - chomp(@list); - for my $n (@list) { - my $tINS = my $tEND = ''; - my %tmp = readCfg("$n"); - next if ( defined($valid) && $valid ne $tmp{VALID} ) ; - if ( defined($acton) ) { - # Time::Piece->strptime(, "%Y-%m-%d") accepts either %Y, %Y-%m or %Y-%m-%d (fills with '01' as necessary) - eval { $tINS = Time::Piece->strptime($tmp{INSTALL_DATE}, "%Y-%m-%d") } ; if ($@) { $tINS = Time::Piece->strptime("","%Y-%m-%d") } - # FIX: 2038 for Perl 32-bits dates; WAS: eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("9999","%Y-%m-%d") } - eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("2038","%Y-%m-%d") } - next if ( ($deb < $tINS) && ($fin < $tINS) ); - next if ( ($deb > $tEND) && ($fin > $tEND) ); - } - $vlist{ basename($n,'.cnf') } = { ALIAS => $tmp{ALIAS} , NAME => $tmp{NAME}, FID => $tmp{FID} }; - } - } - return %vlist; + use Time::Piece; + my %KWARGS = @_; + my $grid = $KWARGS{grid} ? $KWARGS{grid} : undef; + my $valid = $KWARGS{valid} ? $KWARGS{valid} : undef; + my $acton = $KWARGS{active} ? $KWARGS{active} : undef; + my $today = my $deb = my $fin = ''; + if (defined($acton)) { + $today = strftime( '%Y-%m-%d', localtime ); + ($deb,$fin) = split(/:/,$acton); + if (!$fin) {$fin = $deb} + $deb =~ s/today/$today/; + $fin =~ s/today/$today/; + eval { $deb = Time::Piece->strptime($deb,"%Y-%m-%d") }; if ($@) { $deb = Time::Piece->strptime("","%Y-%m-%d") } + +# FIX: 2038 for Perl 32-bits dates; WAS: eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("9999","%Y-%m-%d") } + eval { $fin = Time::Piece->strptime($fin,"%Y-%m-%d") }; if ($@) { $fin = Time::Piece->strptime("2038","%Y-%m-%d") } + } + my %vlist; + if (defined($grid)) { + $grid = ($grid =~ /\./) ? $grid : "*.$grid"; + my @list = qx (ls -L $WEBOBS{PATH_GRIDS2NODES}/$grid.*/*.cnf 2>/dev/null); + chomp(@list); + for my $n (@list) { + my $tINS = my $tEND = ''; + my %tmp = readCfg("$n"); + next if ( defined($valid) && $valid ne $tmp{VALID} ) ; + if ( defined($acton) ) { + +# Time::Piece->strptime(, "%Y-%m-%d") accepts either %Y, %Y-%m or %Y-%m-%d (fills with '01' as necessary) + eval { $tINS = Time::Piece->strptime($tmp{INSTALL_DATE}, "%Y-%m-%d") } ; if ($@) { $tINS = Time::Piece->strptime("","%Y-%m-%d") } + +# FIX: 2038 for Perl 32-bits dates; WAS: eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("9999","%Y-%m-%d") } + eval { $tEND = Time::Piece->strptime($tmp{END_DATE}, "%Y-%m-%d") } ; if ($@) { $tEND = Time::Piece->strptime("2038","%Y-%m-%d") } + next if ( ($deb < $tINS) && ($fin < $tINS) ); + next if ( ($deb > $tEND) && ($fin > $tEND) ); + } + $vlist{ basename($n,'.cnf') } = { ALIAS => $tmp{ALIAS} , NAME => $tmp{NAME}, FID => $tmp{FID} }; + } + } + return %vlist; } - =pod =head2 normNode @@ -550,16 +566,16 @@ normNode may be used as a nodename validity (ie. well-formed AND existing) check =cut sub normNode { - my %KWARGS = @_; - my $node = $KWARGS{node} ? $KWARGS{node} : ''; - my $ret = ""; - if ($node) { - $node =~ s/\./*./g; - my @l = qx(ls -dr $WEBOBS{PATH_GRIDS2NODES}/$node 2>/dev/null); - chomp(@l); - if (scalar(@l) > 0) {$ret = basename($l[0])} - } - return $ret; + my %KWARGS = @_; + my $node = $KWARGS{node} ? $KWARGS{node} : ''; + my $ret = ""; + if ($node) { + $node =~ s/\./*./g; + my @l = qx(ls -dr $WEBOBS{PATH_GRIDS2NODES}/$node 2>/dev/null); + chomp(@l); + if (scalar(@l) > 0) {$ret = basename($l[0])} + } + return $ret; } =pod @@ -589,49 +605,49 @@ and type.txt file-reads ... sub getNodeString { - my %KWARGS = @_; - my $node = $KWARGS{node} ? $KWARGS{node} : ''; - my $style = $KWARGS{style} && $KWARGS{style} =~ /^alias|^short|^html/ ? $KWARGS{style} : 'html'; - my $link = $KWARGS{link} && $KWARGS{link} =~ /^node|^features/ ? $KWARGS{link} : ''; - - my $text = ""; - my $sub = ""; - if ($node ne "" && -f "$NODES{PATH_NODES}/$node/$node.cnf") { - my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); - if (isok($N{VALID})) { - my $nnode = normNode(node=>"..$node"); - no warnings "uninitialized"; - if ($style eq 'alias') { $text = $N{ALIAS} } - if ($style eq 'short') { $text = "$N{ALIAS}: $N{NAME}" } - if ($style eq 'html') { $text = "$N{ALIAS}: $N{NAME}".($N{TYPE} ne "" && $N{TYPE} ne "-" ? " ($N{TYPE})":"") } - if ($link eq 'node') { $text = "$text"; } - if ($link eq 'features') { - $text = "$text "; - if ($N{FILES_FEATURES} ne "") { - $text = " ".$text."\n" - ."
        "; - for my $feature (split(/,/,$N{FILES_FEATURES})) { - my $f = "$NODES{PATH_NODES}/$node/$NODES{SPATH_FEATURES}/$feature.txt"; - my $htm; - if (exists $node2node{"$node|$feature"}) { - for (split(/\|/,$node2node{"$node|$feature"})) { - $htm .= getNodeString(node=>$_, link=>'node')."
        " if ($_ ne ""); - } - } - if (-f $f) { - my @feat = readFile($f); - $htm .= WebObs::Wiki::wiki2html(join("",@feat)); - $htm =~ s/

        /
        /ig; - } - $sub .= "" if ($htm ne ""); - } - $text .= $sub."
        $feature".$htm."
        "; - } - } - use warnings; - } - } - return $text; + my %KWARGS = @_; + my $node = $KWARGS{node} ? $KWARGS{node} : ''; + my $style = $KWARGS{style} && $KWARGS{style} =~ /^alias|^short|^html/ ? $KWARGS{style} : 'html'; + my $link = $KWARGS{link} && $KWARGS{link} =~ /^node|^features/ ? $KWARGS{link} : ''; + + my $text = ""; + my $sub = ""; + if ($node ne "" && -f "$NODES{PATH_NODES}/$node/$node.cnf") { + my %N = readCfg("$NODES{PATH_NODES}/$node/$node.cnf"); + if (isok($N{VALID})) { + my $nnode = normNode(node=>"..$node"); + no warnings "uninitialized"; + if ($style eq 'alias') { $text = $N{ALIAS} } + if ($style eq 'short') { $text = "$N{ALIAS}: $N{NAME}" } + if ($style eq 'html') { $text = "$N{ALIAS}: $N{NAME}".($N{TYPE} ne "" && $N{TYPE} ne "-" ? " ($N{TYPE})":"") } + if ($link eq 'node') { $text = "$text"; } + if ($link eq 'features') { + $text = "$text "; + if ($N{FILES_FEATURES} ne "") { + $text = " ".$text."\n" + ."
        "; + for my $feature (split(/,/,$N{FILES_FEATURES})) { + my $f = "$NODES{PATH_NODES}/$node/$NODES{SPATH_FEATURES}/$feature.txt"; + my $htm; + if (exists $node2node{"$node|$feature"}) { + for (split(/\|/,$node2node{"$node|$feature"})) { + $htm .= getNodeString(node=>$_, link=>'node')."
        " if ($_ ne ""); + } + } + if (-f $f) { + my @feat = readFile($f); + $htm .= WebObs::Wiki::wiki2html(join("",@feat)); + $htm =~ s/

        /
        /ig; + } + $sub .= "" if ($htm ne ""); + } + $text .= $sub."
        $feature".$htm."
        "; + } + } + use warnings; + } + } + return $text; } =pod @@ -648,32 +664,32 @@ to which $eventFileName belongs. Returns "" if no such list. sub parentEvents ($) { - my $eventFile = shift; - my $parent = ""; - my @subParent = split(/\//,$eventFile); - if ($#subParent > 0) { - $parent = join("/",@subParent[0..($#subParent-1)]); - } else { - return ""; - } - - my $station = substr($eventFile,0,7); - my $txt = ""; - my @x = split(/\//,$parent); - for (my $i=$#x;$i>=0;$i--) { - my $f = "$NODES{PATH_NODES}/$station/$NODES{SPATH_INTERVENTIONS}/".join("/",@x[0..$i]).".txt"; - my ($s,$d,$h) = split(/_/,$x[$i]); - $h =~ s/-/:/; - my $t = "???"; - if (-e $f) { - my @xx = readFile($f); - chomp(@xx); - my $o; - ($o,$t) = split(/\|/,$xx[0]); - } - $txt .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; - } - return $txt; + my $eventFile = shift; + my $parent = ""; + my @subParent = split(/\//,$eventFile); + if ($#subParent > 0) { + $parent = join("/",@subParent[0..($#subParent-1)]); + } else { + return ""; + } + + my $station = substr($eventFile,0,7); + my $txt = ""; + my @x = split(/\//,$parent); + for (my $i=$#x;$i>=0;$i--) { + my $f = "$NODES{PATH_NODES}/$station/$NODES{SPATH_INTERVENTIONS}/".join("/",@x[0..$i]).".txt"; + my ($s,$d,$h) = split(/_/,$x[$i]); + $h =~ s/-/:/; + my $t = "???"; + if (-e $f) { + my @xx = readFile($f); + chomp(@xx); + my $o; + ($o,$t) = split(/\|/,$xx[0]); + } + $txt .= " \@ $t ($d".($h ne "NA" ? " $h":"").")"; + } + return $txt; } =pod @@ -696,35 +712,35 @@ It appends and possibly overwrites codes from local configuration file CONF/netw =cut sub codesFDSN { - my %codes; - my @FDSN = readFile("$WEBOBS{ROOT_CODE}/etc/fdsncodes.csv",'^[^#].*'); - chomp(@FDSN); - - # process CSV file, result from IRIS web-service - # Example: - # AA,'Anchorage Strong Motion Network', - for (@FDSN) { - my ($cle,$val) = split(/,/,$_); - $val =~ s/^'//; - $val =~ s/'$//; - $codes{trim($cle)} = $val; - } - - # overwrites with optional local configuration file - my @NET = readFile("$NODES{FILE_NETWORKS}",'^[^#].*'); - chomp(@NET); - for (@NET) { - my ($cle,$val) = split(/,/,$_); - $val =~ s/^'//; - $val =~ s/'$//; - if (defined $codes{trim($cle)}) { - $codes{trim($cle)} = "$val !! overwritten FDSN \"$codes{trim($cle)}\" !!"; - } else { - $codes{trim($cle)} = $val; - } - } - - return %codes; + my %codes; + my @FDSN = readFile("$WEBOBS{ROOT_CODE}/etc/fdsncodes.csv",'^[^#].*'); + chomp(@FDSN); + + # process CSV file, result from IRIS web-service + # Example: + # AA,'Anchorage Strong Motion Network', + for (@FDSN) { + my ($cle,$val) = split(/,/,$_); + $val =~ s/^'//; + $val =~ s/'$//; + $codes{trim($cle)} = $val; + } + + # overwrites with optional local configuration file + my @NET = readFile("$NODES{FILE_NETWORKS}",'^[^#].*'); + chomp(@NET); + for (@NET) { + my ($cle,$val) = split(/,/,$_); + $val =~ s/^'//; + $val =~ s/'$//; + if (defined $codes{trim($cle)}) { + $codes{trim($cle)} = "$val !! overwritten FDSN \"$codes{trim($cle)}\" !!"; + } else { + $codes{trim($cle)} = $val; + } + } + + return %codes; } =pod @@ -733,19 +749,19 @@ Reads calibration file of a node (fullid) and return an array =cut sub readCLB { - my $node = shift; - my %data; - my ($GRIDType, $GRIDName, $NODEName) = split(/\./, $node); - - my $file = "$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"; # standard CLB file name - my $legclb = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; - $file = $legclb if ( ! -e $file && -e $legclb); # for backwards compatibility - (my $autoclb = $file) =~ s/\.clb/_auto.clb/; # auto-generated CLB - $file = $autoclb if ( -e $autoclb && ! -s $file ); - if ( -s $file ) { - %data = readCfg($file); - } - return %data; + my $node = shift; + my %data; + my ($GRIDType, $GRIDName, $NODEName) = split(/\./, $node); + + my $file = "$NODES{PATH_NODES}/$NODEName/$GRIDType.$GRIDName.$NODEName.clb"; # standard CLB file name + my $legclb = "$NODES{PATH_NODES}/$NODEName/$NODEName.clb"; + $file = $legclb if ( ! -e $file && -e $legclb); # for backwards compatibility + (my $autoclb = $file) =~ s/\.clb/_auto.clb/; # auto-generated CLB + $file = $autoclb if ( -e $autoclb && ! -s $file ); + if ( -s $file ) { + %data = readCfg($file); + } + return %data; } 1; diff --git a/CODE/perl/lib/Mapping.pm b/CODE/perl/lib/Mapping.pm index e76e3400..2c33063d 100644 --- a/CODE/perl/lib/Mapping.pm +++ b/CODE/perl/lib/Mapping.pm @@ -76,18 +76,18 @@ Returns %UTM address if loaded successfully, 0 otherwise. =cut sub setUTMLOCAL { - if ($_[0] && -e "$_[0]") { - %UTM = (); - %UTM = readCfg($_[0]); - } - else { - if ((exists $WEBOBS{UTM_LOCAL}) && -e $WEBOBS{UTM_LOCAL}) { - %UTM = (); - %UTM = readCfg($WEBOBS{UTM_LOCAL}) ; - } - } - if (scalar(keys(%UTM))) { return \%UTM } - else { return 0 } + if ($_[0] && -e "$_[0]") { + %UTM = (); + %UTM = readCfg($_[0]); + } + else { + if ((exists $WEBOBS{UTM_LOCAL}) && -e $WEBOBS{UTM_LOCAL}) { + %UTM = (); + %UTM = readCfg($WEBOBS{UTM_LOCAL}) ; + } + } + if (scalar(keys(%UTM))) { return \%UTM } + else { return 0 } } =pod @@ -105,13 +105,13 @@ Calcul de la latitude isométrique sub ign0001 { - my $p = shift; - my $e = shift; + my $p = shift; + my $e = shift; - # Jeux d'essai - #$e = 0.08199188998; $p = 0.872664626; - my $l = log(tan(pi/4 + $p/2)*(((1.0 - $e*sin($p))/(1.0 + $e*sin($p)))**($e/2))); - return $l; + # Jeux d'essai + #$e = 0.08199188998; $p = 0.872664626; + my $l = log(tan(pi/4 + $p/2)*(((1.0 - $e*sin($p))/(1.0 + $e*sin($p)))**($e/2))); + return $l; } =pod @@ -138,22 +138,21 @@ sub ign0001 { =cut sub ign0009 { - my $l = shift; - my $p = shift; - my $he = shift; - my $a = shift; - my $e = shift; + my $l = shift; + my $p = shift; + my $he = shift; + my $a = shift; + my $e = shift; - my $N = ign0021($p,$a,$e); + my $N = ign0021($p,$a,$e); - my $x = ($N + $he)*cos($p)*cos($l); - my $y = ($N + $he)*cos($p)*sin($l); - my $z = ($N*(1 - $e*$e) + $he)*sin($p); + my $x = ($N + $he)*cos($p)*cos($l); + my $y = ($N + $he)*cos($p)*sin($l); + my $z = ($N*(1 - $e*$e) + $he)*sin($p); - return ($x,$y,$z); + return ($x,$y,$z); } - =pod =head2 ign0012 @@ -175,46 +174,44 @@ sub ign0009 { =cut sub ign0012 { - my $x = shift; - my $y = shift; - my $z = shift; - my $a = shift; - my $e = shift; - - - # Jeu d'essai - #$a = 6378249.2; $e = 0.08248325679; $x = 6376064.695; $y = 111294.623; $z = 128984.725; - - my $EPS = 1e-11; # EPS = tolérance de convergence, en rad - my $IMAX = 10; # Imax = nombre maximum d'itérations - - my $R = sqrt($x*$x + $y*$y); - my $l = 2*atan($y/($x + $R)); - my $p; - my $h; - my $p0 = atan($z/sqrt($x*$x + $y*$y*(1 - ($a*$e*$e)/sqrt($x*$x + $y*$y + $z*$z)))); - my $p1; - my $i = 0; - my $fin = 0; - while ($i < $IMAX && !$fin) { - $i++; - $p1 = atan(($z/$R)/(1 - ($a*$e*$e*cos($p0))/($R*sqrt(1 - $e*$e*sin($p0)**2)))); - my $res = abs($p1-$p0); - if ($res < $EPS) { - $fin = 1; - } - $p0 = $p1; - } - if ($fin) { - $p = $p1; - $h = $R/cos($p) - $a/sqrt(1 - $e*$e*sin($p)**2); - } - - return ($l,$p,$h); + my $x = shift; + my $y = shift; + my $z = shift; + my $a = shift; + my $e = shift; + +# Jeu d'essai +#$a = 6378249.2; $e = 0.08248325679; $x = 6376064.695; $y = 111294.623; $z = 128984.725; + + my $EPS = 1e-11; # EPS = tolérance de convergence, en rad + my $IMAX = 10; # Imax = nombre maximum d'itérations + + my $R = sqrt($x*$x + $y*$y); + my $l = 2*atan($y/($x + $R)); + my $p; + my $h; + my $p0 = atan($z/sqrt($x*$x + $y*$y*(1 - ($a*$e*$e)/sqrt($x*$x + $y*$y + $z*$z)))); + my $p1; + my $i = 0; + my $fin = 0; + while ($i < $IMAX && !$fin) { + $i++; + $p1 = atan(($z/$R)/(1 - ($a*$e*$e*cos($p0))/($R*sqrt(1 - $e*$e*sin($p0)**2)))); + my $res = abs($p1-$p0); + if ($res < $EPS) { + $fin = 1; + } + $p0 = $p1; + } + if ($fin) { + $p = $p1; + $h = $R/cos($p) - $a/sqrt(1 - $e*$e*sin($p)**2); + } + + return ($l,$p,$h); } - =pod =head2 ign0013b @@ -240,27 +237,27 @@ sub ign0012 { =cut sub ign0013b { - my $tx = shift; - my $ty = shift; - my $tz = shift; - my $d = shift; - my $rx = shift; - my $ry = shift; - my $rz = shift; - my $ux = shift; - my $uy = shift; - my $uz = shift; - - my @v; - - # jeux d'essai - #$u = [4154005.81,-80587.328,4823289.532]; $tx = -69.4; $ty = 18; $tz = 452.2; $d = -3.21e-6; $rx = 0; $ry = 0; $rz = 0.00000499358; - - $v[0] = ($tx - $ux)*($d - 1) + ($tz - $uz)*$ry - ($ty - $uy)*$rz; - $v[1] = ($ty - $uy)*($d - 1) + ($tx - $ux)*$rz - ($tz - $uz)*$rx; - $v[2] = ($tz - $uz)*($d - 1) + ($ty - $uy)*$rx - ($tx - $ux)*$ry; - - return @v; + my $tx = shift; + my $ty = shift; + my $tz = shift; + my $d = shift; + my $rx = shift; + my $ry = shift; + my $rz = shift; + my $ux = shift; + my $uy = shift; + my $uz = shift; + + my @v; + +# jeux d'essai +#$u = [4154005.81,-80587.328,4823289.532]; $tx = -69.4; $ty = 18; $tz = 452.2; $d = -3.21e-6; $rx = 0; $ry = 0; $rz = 0.00000499358; + + $v[0] = ($tx - $ux)*($d - 1) + ($tz - $uz)*$ry - ($ty - $uy)*$rz; + $v[1] = ($ty - $uy)*($d - 1) + ($tx - $ux)*$rz - ($tz - $uz)*$rx; + $v[2] = ($tz - $uz)*($d - 1) + ($ty - $uy)*$rx - ($tx - $ux)*$ry; + + return @v; } =pod @@ -284,16 +281,15 @@ sub ign0013b { =cut sub ign0021 { - my $p = shift; - my $a = shift; - my $e = shift; + my $p = shift; + my $a = shift; + my $e = shift; - my $n = $a/sqrt(1 - $e*$e*sin($p)**2); + my $n = $a/sqrt(1 - $e*$e*sin($p)**2); - return $n; + return $n; } - =pod =head2 ign0025 @@ -311,20 +307,20 @@ sub ign0021 { =cut sub ign0025 { - my $e = shift; - # Jeux d'essai - #$e = 0.08199188998; - - my @c; - $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; - $c[1] = -105.0/4096*$e**8 - 45.0/1024*$e**6 - 3.0/32*$e**4 - 3.0/8*$e**2; - $c[2] = 525.0/16384*$e**8 + 45.0/1024*$e**6 + 15.0/256*$e**4; - $c[3] = -175.0/12288*$e**8 - 35.0/3072*$e**6; - $c[4] = 315.0/131072*$e**8; - - return @c; -} + my $e = shift; + + # Jeux d'essai + #$e = 0.08199188998; + my @c; + $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; + $c[1] = -105.0/4096*$e**8 - 45.0/1024*$e**6 - 3.0/32*$e**4 - 3.0/8*$e**2; + $c[2] = 525.0/16384*$e**8 + 45.0/1024*$e**6 + 15.0/256*$e**4; + $c[3] = -175.0/12288*$e**8 - 35.0/3072*$e**6; + $c[4] = 315.0/131072*$e**8; + + return @c; +} =pod @@ -344,15 +340,14 @@ sub ign0025 { =cut sub ign0026 { - my $p = shift; - my @c = shift; + my $p = shift; + my @c = shift; - my $b = $c[0]*$p + $c[1]*sin(2*$p) + $c[2]*sin(4*$p) + $c[3]*sin(6*$p) + $c[4]*sin(8*$p); + my $b = $c[0]*$p + $c[1]*sin(2*$p) + $c[2]*sin(4*$p) + $c[3]*sin(6*$p) + $c[4]*sin(8*$p); - return $b; + return $b; } - =pod =head2 ign0028 @@ -370,21 +365,21 @@ sub ign0026 { =cut sub ign0028 { - my $e = shift; - # Jeux d'essai - #$e = 0.08199188998; + my $e = shift; - my @c; - $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; - $c[1] = -901.0/184320*$e**8 - 9.0/1024*$e**6 - 1.0/96*$e**4 + 1.0/8*$e**2; - $c[2] = -311.0/737280*$e**8 + 17.0/5120*$e**6 + 13.0/768*$e**4; - $c[3] = 899.0/430080*$e**8 + 61.0/15360*$e**6; - $c[4] = 49561.0/41287680*$e**8; + # Jeux d'essai + #$e = 0.08199188998; - return @c; + my @c; + $c[0] = -175.0/16384*$e**8 - 5.0/256*$e**6 - 3.0/64*$e**4 - 1.0/4*$e**2 + 1; + $c[1] = -901.0/184320*$e**8 - 9.0/1024*$e**6 - 1.0/96*$e**4 + 1.0/8*$e**2; + $c[2] = -311.0/737280*$e**8 + 17.0/5120*$e**6 + 13.0/768*$e**4; + $c[3] = 899.0/430080*$e**8 + 61.0/15360*$e**6; + $c[4] = 49561.0/41287680*$e**8; -} + return @c; +} =pod @@ -411,34 +406,33 @@ sub ign0028 { =cut sub ign0030 { - my $lc = shift; - my $n = shift; - my $xs = shift; - my $ys = shift; - my $e = shift; - my $l = shift; - my $p = shift; + my $lc = shift; + my $n = shift; + my $xs = shift; + my $ys = shift; + my $e = shift; + my $l = shift; + my $p = shift; - # Jeux d'essai - #$lc = -0.05235987756; $n = 6375697.8456; $xs = 500000; $ys = 0; $e = 0.08248340004; $l = -0.0959931089; $p = 0.6065019151; +# Jeux d'essai +#$lc = -0.05235987756; $n = 6375697.8456; $xs = 500000; $ys = 0; $e = 0.08248340004; $l = -0.0959931089; $p = 0.6065019151; - my @c = ign0028($e); - my $L = ign0001($p,$e); - my $P = asin(sin($l - $lc)/cosh($L)); - my $LS = ign0001($P,0); - $L = atan(sinh($L)/cos($l - $lc)); + my @c = ign0028($e); + my $L = ign0001($p,$e); + my $P = asin(sin($l - $lc)/cosh($L)); + my $LS = ign0001($P,0); + $L = atan(sinh($L)/cos($l - $lc)); - my $z = Math::Complex->new($L,$LS); - my $Z = $n*$c[0]*$z + $n*($c[1]*sin(2*$z) + $c[2]*sin(4*$z) + $c[3]*sin(6*$z) + $c[4]*sin(8*$z)); + my $z = Math::Complex->new($L,$LS); + my $Z = $n*$c[0]*$z + $n*($c[1]*sin(2*$z) + $c[2]*sin(4*$z) + $c[3]*sin(6*$z) + $c[4]*sin(8*$z)); - my $x = $Z->Im() + $xs; - my $y = $Z->Re() + $ys; + my $x = $Z->Im() + $xs; + my $y = $Z->Re() + $ys; - return ($x,$y); + return ($x,$y); } - =pod =head2 ign0052 @@ -465,28 +459,27 @@ sub ign0030 { =cut sub ign0052 { - my $a = shift; - my $e = shift; - my $k0 = shift; - my $l0 = shift; - my $p0 = shift; - my $x0 = shift; - my $y0 = shift; - - # Jeux d'essai - #$a = 6377563.3963; $e = 0.08167337382; $k0 = 0.9996012; $l0 = -0.03490658504; $p0 = 0.85521133347; $x0 = 400000; $y0 = -100000; - - my $lc = $l0; - my $n = $k0*$a; - my $xs = $x0; - my @C = ign0025($e); - my $B = ign0026($p0,@C); - my $ys = $y0 - $n*$B; - - return ($lc,$n,$xs,$ys); + my $a = shift; + my $e = shift; + my $k0 = shift; + my $l0 = shift; + my $p0 = shift; + my $x0 = shift; + my $y0 = shift; + +# Jeux d'essai +#$a = 6377563.3963; $e = 0.08167337382; $k0 = 0.9996012; $l0 = -0.03490658504; $p0 = 0.85521133347; $x0 = 400000; $y0 = -100000; + + my $lc = $l0; + my $n = $k0*$a; + my $xs = $x0; + my @C = ign0025($e); + my $B = ign0026($p0,@C); + my $ys = $y0 - $n*$B; + + return ($lc,$n,$xs,$ys); } - =pod =head2 geo2utm @@ -508,32 +501,30 @@ sub ign0052 { =cut sub geo2utm { - my $p1 = shift; - my $l1 = shift; - my $D0 = 180/pi; - my ($F0,$K0,$P0,$L0,$X0,$Y0) = utmwgs($p1,$l1); - - # Définition des constantes - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + my $p1 = shift; + my $l1 = shift; + my $D0 = 180/pi; + my ($F0,$K0,$P0,$L0,$X0,$Y0) = utmwgs($p1,$l1); - # Conversion des données - $P0 /= $D0; - my $B1 = $A1*(1 - $F1); - my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); + # Définition des constantes + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement - $p1 = $p1/$D0; # Phi = Latitude (rad) - $l1 = $l1/$D0; # Lambda = Longitude (rad) + # Conversion des données + $P0 /= $D0; + my $B1 = $A1*(1 - $F1); + my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); - # Transformation Géographiques => UTM20 (WGS84) - my ($LC,$N,$XS,$YS) = ign0052($A1,$E1,$K0,$L0,$P0,$X0,$Y0); - my ($e,$n) = ign0030($LC,$N,$XS,$YS,$E1,$l1,$p1); + $p1 = $p1/$D0; # Phi = Latitude (rad) + $l1 = $l1/$D0; # Lambda = Longitude (rad) + # Transformation Géographiques => UTM20 (WGS84) + my ($LC,$N,$XS,$YS) = ign0052($A1,$E1,$K0,$L0,$P0,$X0,$Y0); + my ($e,$n) = ign0030($LC,$N,$XS,$YS,$E1,$l1,$p1); - return ($e,$n,$F0); + return ($e,$n,$F0); } - =pod =head2 geo2utml @@ -555,49 +546,49 @@ sub geo2utm { =cut sub geo2utml { - my $p1 = shift; - my $l1 = shift; - my $h1 = shift; - - # Définition des constantes - my $D0 = 180/pi; - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement - my $A2 = $UTM{ELLIPSOID_LOCAL_SEMIMAJOR_AXIS}; # HAYFORD 1909 demi grand axe - my $F2 = 1/$UTM{ELLIPSOID_LOCAL_INVERSE_FLATTENING}; # HAYFORD 1909 aplatissement - my ($F0,$K0,$P0,$L0,$X0,$Y0) = utm($p1,$l1); - - my $TX = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_X}; # HAYFORD 1909 => WGS84 : Translation X (m) - my $TY = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Y}; # HAYFORD 1909 => WGS84 : Translation Y (m) - my $TZ = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Z}; # HAYFORD 1909 => WGS84 : Translation Z (m) - my $D = $UTM{GEODETIC_LOCAL2WGS84_SCALE_FACTOR}; # HAYFORD 1909 => WGS84 : Facteur d'échelle (ppm) - my $RX = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_X}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation X (") - my $RY = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Y}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Y (") - my $RZ = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Z}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Z (") - - # Conversion des données - my $B1 = $A1*(1 - $F1); - my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); - my $B2 = $A2*(1 - $F2); - my $E2 = sqrt(($A2*$A2 - $B2*$B2)/($A2*$A2)); - - $p1 = $p1/$D0; # Phi = Latitude (rad) - $l1 = $l1/$D0; # Lambda = Longitude (rad) - - # Transformation Géographiques => Cartésiennes WGS84 - my ($x1,$y1,$z1) = ign0009($l1,$p1,$h1,$A1,$E1); - - # Transformation par similitude 3D à 7 paramètres WGS84 => HAYFORD 1909 - my ($x2,$y2,$z2) = ign0013b($TX,$TY,$TZ,$D,$RX,$RY,$RZ,$x1,$y1,$z1); - - # Transformation Cartésiennes => Géographiques (HAYFORD 1909) - my ($l2,$p2,$h2) = ign0012($x2,$y2,$z2,$A2,$E2); - - # Transformation Géographiques => UTM20 (HAYFORD 1909) - my ($LC,$N,$XS,$YS) = ign0052($A2,$E2,$K0,$L0,$P0,$X0,$Y0); - my ($e2,$n2) = ign0030($LC,$N,$XS,$YS,$E2,$l2,$p2); - - return ($e2,$n2,$F0); + my $p1 = shift; + my $l1 = shift; + my $h1 = shift; + + # Définition des constantes + my $D0 = 180/pi; + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + my $A2 = $UTM{ELLIPSOID_LOCAL_SEMIMAJOR_AXIS}; # HAYFORD 1909 demi grand axe + my $F2 = 1/$UTM{ELLIPSOID_LOCAL_INVERSE_FLATTENING}; # HAYFORD 1909 aplatissement + my ($F0,$K0,$P0,$L0,$X0,$Y0) = utm($p1,$l1); + + my $TX = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_X}; # HAYFORD 1909 => WGS84 : Translation X (m) + my $TY = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Y}; # HAYFORD 1909 => WGS84 : Translation Y (m) + my $TZ = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_Z}; # HAYFORD 1909 => WGS84 : Translation Z (m) + my $D = $UTM{GEODETIC_LOCAL2WGS84_SCALE_FACTOR}; # HAYFORD 1909 => WGS84 : Facteur d'échelle (ppm) + my $RX = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_X}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation X (") + my $RY = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Y}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Y (") + my $RZ = $UTM{GEODETIC_LOCAL2WGS84_ROTATION_Z}*pi/(180*3600); # HAYFORD 1909 => WGS84 : Rotation Z (") + + # Conversion des données + my $B1 = $A1*(1 - $F1); + my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); + my $B2 = $A2*(1 - $F2); + my $E2 = sqrt(($A2*$A2 - $B2*$B2)/($A2*$A2)); + + $p1 = $p1/$D0; # Phi = Latitude (rad) + $l1 = $l1/$D0; # Lambda = Longitude (rad) + + # Transformation Géographiques => Cartésiennes WGS84 + my ($x1,$y1,$z1) = ign0009($l1,$p1,$h1,$A1,$E1); + + # Transformation par similitude 3D à 7 paramètres WGS84 => HAYFORD 1909 + my ($x2,$y2,$z2) = ign0013b($TX,$TY,$TZ,$D,$RX,$RY,$RZ,$x1,$y1,$z1); + + # Transformation Cartésiennes => Géographiques (HAYFORD 1909) + my ($l2,$p2,$h2) = ign0012($x2,$y2,$z2,$A2,$E2); + + # Transformation Géographiques => UTM20 (HAYFORD 1909) + my ($LC,$N,$XS,$YS) = ign0052($A2,$E2,$K0,$L0,$P0,$X0,$Y0); + my ($e2,$n2) = ign0030($LC,$N,$XS,$YS,$E2,$l2,$p2); + + return ($e2,$n2,$F0); } =pod @@ -609,25 +600,26 @@ Returns UTM WGS84 parameters (zone, false easting and northing) from latitude an =cut sub utmwgs { - my $p1 = shift; - my $l1 = shift; - - my $D0 = 180/pi; - my $F0 = $UTM{UTM_ZONE}; # utm zone - my $K0 = $UTM{UTM_SCALE_FACTOR}; # scale factor (0.9996) - if ($F0 le 0) { - #$F0 = int(($l1 + 183)/6); - $F0 = int(($l1 + 183)/6 + .5); - } - my $L0 = (6*$F0 - 183)/$D0; # longitude origin (rad) - my $P0 = 0; # latitude origin (rad) / UTM20 = 0 - my $X0 = 500000; # false easting - my $Y0 = 0; # false northing - if ($p1 lt 0) { - $Y0 = 10000000; - } - - return ($F0,$K0,$P0,$L0,$X0,$Y0); + my $p1 = shift; + my $l1 = shift; + + my $D0 = 180/pi; + my $F0 = $UTM{UTM_ZONE}; # utm zone + my $K0 = $UTM{UTM_SCALE_FACTOR}; # scale factor (0.9996) + if ($F0 le 0) { + + #$F0 = int(($l1 + 183)/6); + $F0 = int(($l1 + 183)/6 + .5); + } + my $L0 = (6*$F0 - 183)/$D0; # longitude origin (rad) + my $P0 = 0; # latitude origin (rad) / UTM20 = 0 + my $X0 = 500000; # false easting + my $Y0 = 0; # false northing + if ($p1 lt 0) { + $Y0 = 10000000; + } + + return ($F0,$K0,$P0,$L0,$X0,$Y0); } =pod @@ -639,25 +631,25 @@ returns UTM parameters (zone, false easting and northing) from latitude and long =cut sub utm { - my $p1 = shift; - my $l1 = shift; - - my $D0 = 180/pi; - #my $F0 = int(($l1 + 183)/6); # UTM zone - my $F0 = int(($l1 + 183)/6 + .5); # UTM zone - my $K0 = $UTM{UTM_LOCAL_SCALE_FACTOR}; # scale factor - my $L0 = $UTM{UTM_LOCAL_MERIDIAN_ORIGIN}/$D0; # longitude origin (rad) - my $P0 = 0; # latitude origin (rad) / UTM20 = 0 - my $X0 = $UTM{UTM_LOCAL_FALSE_EASTING}; # false easting - my $Y0 = 0; # false northing - if ($p1 lt 0) { - $Y0 = 10000000; - } - - return ($F0,$K0,$P0,$L0,$X0,$Y0); + my $p1 = shift; + my $l1 = shift; + + my $D0 = 180/pi; + + #my $F0 = int(($l1 + 183)/6); # UTM zone + my $F0 = int(($l1 + 183)/6 + .5); # UTM zone + my $K0 = $UTM{UTM_LOCAL_SCALE_FACTOR}; # scale factor + my $L0 = $UTM{UTM_LOCAL_MERIDIAN_ORIGIN}/$D0; # longitude origin (rad) + my $P0 = 0; # latitude origin (rad) / UTM20 = 0 + my $X0 = $UTM{UTM_LOCAL_FALSE_EASTING}; # false easting + my $Y0 = 0; # false northing + if ($p1 lt 0) { + $Y0 = 10000000; + } + + return ($F0,$K0,$P0,$L0,$X0,$Y0); } - =pod =head2 geo2cart @@ -668,27 +660,25 @@ sub utm { =cut sub geo2cart { - my $p1 = shift; - my $l1 = shift; - my $h1 = shift; - my $D0 = 180/pi; + my $p1 = shift; + my $l1 = shift; + my $h1 = shift; + my $D0 = 180/pi; - # Définition des constantes - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + # Définition des constantes + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement - # Conversion des données - my $B1 = $A1*(1 - $F1); - my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); + # Conversion des données + my $B1 = $A1*(1 - $F1); + my $E1 = sqrt(($A1*$A1 - $B1*$B1)/($A1*$A1)); - # Transformation Géographiques (WGS84) => géocentriques - my ($x,$y,$z) = ign0009($l1/$D0,$p1/$D0,$h1,$A1,$E1); + # Transformation Géographiques (WGS84) => géocentriques + my ($x,$y,$z) = ign0009($l1/$D0,$p1/$D0,$h1,$A1,$E1); - - return ($x,$y,$z); + return ($x,$y,$z); } - =pod =head2 greatcircle @@ -702,22 +692,22 @@ sub geo2cart { =cut sub greatcircle { - my $k = pi/180; + my $k = pi/180; - my $lat1 = shift; - my $lon1 = shift; - my $lat2 = shift; - my $lon2 = shift; + my $lat1 = shift; + my $lon1 = shift; + my $lat2 = shift; + my $lon2 = shift; - my $dlat = ($lat2 - $lat1)*$k; - my $dlon = ($lon2 - $lon1)*$k; + my $dlat = ($lat2 - $lat1)*$k; + my $dlon = ($lon2 - $lon1)*$k; - my $rearth = 6371; # volumetric Earth radius (in km) + my $rearth = 6371; # volumetric Earth radius (in km) - my $dist = $rearth*2*asin(sqrt(sin($dlat/2)**2 + cos($lat1*$k)*cos($lat2*$k)*sin($dlon/2)**2)); - my $bear = atan2(sin($dlon)*cos($lat2*$k),cos($lat1*$k)*sin($lat2*$k) - sin($lat1*$k)*cos($lat2*$k)*cos($dlon))/$k; + my $dist = $rearth*2*asin(sqrt(sin($dlat/2)**2 + cos($lat1*$k)*cos($lat2*$k)*sin($dlon/2)**2)); + my $bear = atan2(sin($dlon)*cos($lat2*$k),cos($lat1*$k)*sin($lat2*$k) - sin($lat1*$k)*cos($lat2*$k)*cos($dlon))/$k; - return $dist, $bear; + return $dist, $bear; } =pod @@ -728,15 +718,15 @@ sub greatcircle { # degrees from North, clockwise =cut + sub compass { - my @nesw = ('N','NNE','NE','ENE','E','ESE','SE','SSE','S','SSW','SW','WSW','W','WNW','NW','NNW'); - my $az = shift; - $az = ($az*16/360)%16; - return $nesw[$az]; + my @nesw = ('N','NNE','NE','ENE','E','ESE','SE','SSE','S','SSW','SW','WSW','W','WNW','NW','NNW'); + my $az = shift; + $az = ($az*16/360)%16; + return $nesw[$az]; } - =pod =head2 KMLfeed @@ -748,18 +738,18 @@ sub compass { sub KMLfeed { - my $url = shift; - my ($lat, $lon, $alt, $date); + my $url = shift; + my ($lat, $lon, $alt, $date); - if ($url =~ /^http/) { - my @kml = qx(curl -s "$url" | $WEBOBS{XML2_PRGM}); - my $root = '/q:quakeml/eventParameters/event'; - my $pos = findvalue("$root/Point/coordinates=",\@kml); - ($lon,$lat,$alt) = split(/,/,$pos); - $date = findvalue("$root/TimeStamp/when=",\@kml); - } + if ($url =~ /^http/) { + my @kml = qx(curl -s "$url" | $WEBOBS{XML2_PRGM}); + my $root = '/q:quakeml/eventParameters/event'; + my $pos = findvalue("$root/Point/coordinates=",\@kml); + ($lon,$lat,$alt) = split(/,/,$pos); + $date = findvalue("$root/TimeStamp/when=",\@kml); + } - return $lat, $lon, $alt, $date; + return $lat, $lon, $alt, $date; } 1; diff --git a/CODE/perl/lib/QML.pm b/CODE/perl/lib/QML.pm index a27055a1..824de999 100644 --- a/CODE/perl/lib/QML.pm +++ b/CODE/perl/lib/QML.pm @@ -15,82 +15,83 @@ use WebObs::XML2; #-------------------------------------------------------------------------------------------------------------------------------------- # qmlvalues: returns origin and magmitude preferred values from XML2 arrayd sub qmlorigin { - my $file = $_[0]; - my %qml; + my $file = $_[0]; + my %qml; - if (-e $file) { - my @xml2 = qx($WEBOBS{XML2_PRGM} < $file); + if (-e $file) { + my @xml2 = qx($WEBOBS{XML2_PRGM} < $file); - my $root = '/seiscomp/EventParameters'; - my $evt_origID = findvalue("$root/event/preferredOriginID=",\@xml2); - my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); - my $evt_magID = findvalue("$root/event/preferredMagnitudeID=",\@xml2); - my @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@origin); - $qml{time} = findvalue('/time/value=',\@origin); - $qml{rms} = findvalue('/quality/standardError=',\@origin); - $qml{latitude} = findvalue('/latitude/value=',\@origin); - $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); - $qml{longitude} = findvalue('/longitude/value=',\@origin); - $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); - $qml{depth} = findvalue('/depth/value=',\@origin); - $qml{depthError} = findvalue('/depth/uncertainty=',\@origin); - $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); - $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); - $qml{mode} = findvalue('/evaluationMode=',\@origin); - $qml{status} = findvalue('/evaluationStatus=',\@origin); - $qml{method} = findvalue('/methodID=',\@origin); - $qml{model} = findvalue('/earthModelID=',\@origin); - $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); - $qml{magnitude} = findvalue('/magnitude/value=',\@magnitude); - $qml{magtype} = findvalue('/type=',\@magnitude); - $qml{type} = findvalue("$root/event/type=",\@xml2); - } + my $root = '/seiscomp/EventParameters'; + my $evt_origID = findvalue("$root/event/preferredOriginID=",\@xml2); + my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); + my $evt_magID = findvalue("$root/event/preferredMagnitudeID=",\@xml2); + my @magnitude = findnode('/magnitude',"/\@publicID=$evt_magID",\@origin); + $qml{time} = findvalue('/time/value=',\@origin); + $qml{rms} = findvalue('/quality/standardError=',\@origin); + $qml{latitude} = findvalue('/latitude/value=',\@origin); + $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); + $qml{longitude} = findvalue('/longitude/value=',\@origin); + $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); + $qml{depth} = findvalue('/depth/value=',\@origin); + $qml{depthError} = findvalue('/depth/uncertainty=',\@origin); + $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); + $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); + $qml{mode} = findvalue('/evaluationMode=',\@origin); + $qml{status} = findvalue('/evaluationStatus=',\@origin); + $qml{method} = findvalue('/methodID=',\@origin); + $qml{model} = findvalue('/earthModelID=',\@origin); + $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); + $qml{magnitude} = findvalue('/magnitude/value=',\@magnitude); + $qml{magtype} = findvalue('/type=',\@magnitude); + $qml{type} = findvalue("$root/event/type=",\@xml2); + } - return %qml; + return %qml; } #-------------------------------------------------------------------------------------------------------------------------------------- # qmlvalues: returns origin and magnitude preferred values from XML2 arrayd sub qmlfdsn { - my $url = $_[0]; - my %qml; - my @x; + my $url = $_[0]; + my %qml; + my @x; - my @xml2 = qx(curl -s -S --globoff "$url" | $WEBOBS{XML2_PRGM}); + my @xml2 = qx(curl -s -S --globoff "$url" | $WEBOBS{XML2_PRGM}); - my $root = '/q:quakeml/eventParameters/event'; - my $evt_origID = findvalue("$root/preferredOriginID=",\@xml2); - my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); - my $evt_magID = findvalue("$root/preferredMagnitudeID=",\@xml2); - my @magnitude = findnode("$root/magnitude","/\@publicID=$evt_magID",\@xml2); - $qml{time} = findvalue('/time/value=',\@origin); - $qml{rms} = findvalue('/quality/standardError=',\@origin); - $qml{latitude} = findvalue('/latitude/value=',\@origin); - $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); - $qml{longitude} = findvalue('/longitude/value=',\@origin); - $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); - $qml{depth} = findvalue('/depth/value=',\@origin)/1000; - $qml{depthError} = findvalue('/depth/uncertainty=',\@origin)/1000; - $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); - $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); - $qml{mode} = findvalue('/evaluationMode=',\@origin); - $qml{status} = findvalue('/evaluationStatus=',\@origin); + my $root = '/q:quakeml/eventParameters/event'; + my $evt_origID = findvalue("$root/preferredOriginID=",\@xml2); + my @origin = findnode("$root/origin","/\@publicID=$evt_origID",\@xml2); + my $evt_magID = findvalue("$root/preferredMagnitudeID=",\@xml2); + my @magnitude = findnode("$root/magnitude","/\@publicID=$evt_magID",\@xml2); + $qml{time} = findvalue('/time/value=',\@origin); + $qml{rms} = findvalue('/quality/standardError=',\@origin); + $qml{latitude} = findvalue('/latitude/value=',\@origin); + $qml{latitudeError} = findvalue('/latitude/uncertainty=',\@origin); + $qml{longitude} = findvalue('/longitude/value=',\@origin); + $qml{longitudeError} = findvalue('/longitude/uncertainty=',\@origin); + $qml{depth} = findvalue('/depth/value=',\@origin)/1000; + $qml{depthError} = findvalue('/depth/uncertainty=',\@origin)/1000; + $qml{gap} = findvalue('/quality/azimuthalGap=',\@origin); + $qml{phases} = findvalue('/quality/usedPhaseCount=',\@origin); + $qml{mode} = findvalue('/evaluationMode=',\@origin); + $qml{status} = findvalue('/evaluationStatus=',\@origin); - # for methodID and earthModelID takes only the last string to remove prefix - #$qml{method} = findvalue('/methodID=',\@origin); - @x = split(/\//,findvalue('/methodID=',\@origin)); - $qml{method} = $x[-1]; - #$qml{model} = findvalue('/earthModelID=',\@origin); - @x = split(/\//,findvalue('/earthModelID=',\@origin)); - $qml{model} = $x[-1]; + # for methodID and earthModelID takes only the last string to remove prefix + #$qml{method} = findvalue('/methodID=',\@origin); + @x = split(/\//,findvalue('/methodID=',\@origin)); + $qml{method} = $x[-1]; - $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); - $qml{magnitude} = findvalue('/mag/value=',\@magnitude); - $qml{magtype} = findvalue('/type=',\@magnitude); - $qml{type} = findvalue("$root/type=",\@xml2); - $qml{comment} = findvalue("$root/description/text=",\@xml2); + #$qml{model} = findvalue('/earthModelID=',\@origin); + @x = split(/\//,findvalue('/earthModelID=',\@origin)); + $qml{model} = $x[-1]; - return %qml; + $qml{agency} = findvalue('/creationInfo/agencyID=',\@origin); + $qml{magnitude} = findvalue('/mag/value=',\@magnitude); + $qml{magtype} = findvalue('/type=',\@magnitude); + $qml{type} = findvalue("$root/type=",\@xml2); + $qml{comment} = findvalue("$root/description/text=",\@xml2); + + return %qml; } 1; diff --git a/CODE/perl/lib/Scheduler.pm b/CODE/perl/lib/Scheduler.pm index 5d1cae63..e324a9c1 100644 --- a/CODE/perl/lib/Scheduler.pm +++ b/CODE/perl/lib/Scheduler.pm @@ -44,71 +44,72 @@ $VERSION = "1.00"; # Read the scheduler configuration my %SCHEDULER_CONF = readCfg($WEBOBS{'CONF_SCHEDULER'}); - sub scheduler_client { - # Submit a command to the scheduler process listening on UDP. - # - # @parameters: - # $opts (hash reference) - # A reference to a hash defining the following options (missing options - # use sensible defaults): - # 'host' : hostname where the scheduler is listening - # (default: 'localhost') - # 'port' : UDP port used by the scheduler (default: $SCHEDULER_CONF{'PORT'}) - # 'max_length' : maximum number of characters read while reading the - # scheduler response (default: $SCHEDULER_CONF{'SOCKET_MAXLEN'}) - # 'timeout' : timeout to use while contacting the scheduler - # (default: 5) - # $cmd (string) - # The command to be submitted to the scheduler. - # - my $cmd = shift; - my $opts = shift || {}; - my ($response, $error); - local $| = 1; # autoflush - - if (not $cmd) { - return ("", "empty command: nothing to send\n"); - } - - my %opts = ( - # Default values first - 'host' => $SCHEDULER_CONF{'LISTEN_ADDR'} || 'localhost', - 'port' => $SCHEDULER_CONF{'PORT'}, - 'max_length' => $SCHEDULER_CONF{'SOCKET_MAXLEN'}, - 'timeout' => 5, - # Override with values from argument - %$opts, - ); - - my $socket = IO::Socket::INET->new( - 'PeerAddr' => $opts{'host'}, - 'PeerPort' => $opts{'port'}, - 'Proto' => 'udp', - ); - if (not $socket) { - return ("", "unable to create socket: $!"); - } - - eval { - local $SIG{'ALRM'} = sub { die 'Timed Out'; }; - alarm $opts{'timeout'}; - if ($socket->send($cmd)) { - if (not $socket->recv($response, $opts{'max_length'})) { - $error = "failed to read answer: $!"; - } - } else { - $error = "failed to send request: $!"; - } - }; - alarm 0; - if ($@ && $@ =~ /Timed Out/ ) { - $error = "connection timeout after $opts{'timeout'}s"; - } - $socket->close(); - return ($response, $error); -} +# Submit a command to the scheduler process listening on UDP. +# +# @parameters: +# $opts (hash reference) +# A reference to a hash defining the following options (missing options +# use sensible defaults): +# 'host' : hostname where the scheduler is listening +# (default: 'localhost') +# 'port' : UDP port used by the scheduler (default: $SCHEDULER_CONF{'PORT'}) +# 'max_length' : maximum number of characters read while reading the +# scheduler response (default: $SCHEDULER_CONF{'SOCKET_MAXLEN'}) +# 'timeout' : timeout to use while contacting the scheduler +# (default: 5) +# $cmd (string) +# The command to be submitted to the scheduler. +# + my $cmd = shift; + my $opts = shift || {}; + my ($response, $error); + local $| = 1; # autoflush + + if (not $cmd) { + return ("", "empty command: nothing to send\n"); + } + + my %opts = ( + + # Default values first + 'host' => $SCHEDULER_CONF{'LISTEN_ADDR'} || 'localhost', + 'port' => $SCHEDULER_CONF{'PORT'}, + 'max_length' => $SCHEDULER_CONF{'SOCKET_MAXLEN'}, + 'timeout' => 5, + + # Override with values from argument + %$opts, + ); + + my $socket = IO::Socket::INET->new( + 'PeerAddr' => $opts{'host'}, + 'PeerPort' => $opts{'port'}, + 'Proto' => 'udp', + ); + if (not $socket) { + return ("", "unable to create socket: $!"); + } + + eval { + local $SIG{'ALRM'} = sub { die 'Timed Out'; }; + alarm $opts{'timeout'}; + if ($socket->send($cmd)) { + if (not $socket->recv($response, $opts{'max_length'})) { + $error = "failed to read answer: $!"; + } + } else { + $error = "failed to send request: $!"; + } + }; + alarm 0; + if ($@ && $@ =~ /Timed Out/ ) { + $error = "connection timeout after $opts{'timeout'}s"; + } + $socket->close(); + return ($response, $error); +} 1; diff --git a/CODE/perl/lib/Search.pm b/CODE/perl/lib/Search.pm index cd3d36bb..d592c2f6 100644 --- a/CODE/perl/lib/Search.pm +++ b/CODE/perl/lib/Search.pm @@ -22,131 +22,136 @@ use CGI::Carp qw(fatalsToBrowser set_message); set_message(\&webobs_cgi_msg); sub searchform { - my $searchW = my $entireW = my $majmin = my $extend = my $year1 = my $month1 = my $day1 = my $year2 = my $month2 = my $day2 = ""; - my $netinfo = my $stainfo = my $evtinfo = my $clbinfo = "OK"; - my $anneeActuelle = qx(date +\%Y); chomp($anneeActuelle); - my @listeAnnees = reverse($WEBOBS{BIG_BANG}..$anneeActuelle); - my $SF = ""; - $SF = "
        \n"; - $SF .= ""; - $SF .= ""; - $SF .= ""; - $SF .= "\n"; - $SF .= ""; - - $SF .= "
        "; - $SF .= "$__{'Search in selected grids below'}\n"; - $SF .= "\n"; - $SF .= "$__{'Word/Expression'}: \n"; - $SF .= ""; - $SF .= ""; - $SF .= ""; - - $SF .= "
        "; - $SF .= "$__{'Node info'}\n"; - $SF .= "CLB\n"; - $SF .= "$__{'Node events'}\n"; - $SF .= "
        "; - $SF .= ""; - $SF .= "\n\n\n
        "; - $SF .= ""; - $SF .= "\n\n        		"; - $SF .= "$__{'Entire word'}\n"; - $SF .= "$__{'Upper/lower case'}\n"; - $SF .= "$__{'Display Entire text'}
        \n"; - $SF .= "
        "; - return $SF; + my $searchW = my $entireW = my $majmin = my $extend = my $year1 = my $month1 = my $day1 = my $year2 = my $month2 = my $day2 = ""; + my $netinfo = my $stainfo = my $evtinfo = my $clbinfo = "OK"; + my $anneeActuelle = qx(date +\%Y); chomp($anneeActuelle); + my @listeAnnees = reverse($WEBOBS{BIG_BANG}..$anneeActuelle); + my $SF = ""; + $SF = "
        \n"; + $SF .= ""; + $SF .= ""; + $SF .= ""; + $SF .= "\n"; + $SF .= ""; + + $SF .= "
        "; + $SF .= "$__{'Search in selected grids below'}\n"; + $SF .= "\n"; + $SF .= "$__{'Word/Expression'}: \n"; + $SF .= ""; + $SF .= ""; + $SF .= ""; + + $SF .= "
        "; + $SF .= "$__{'Node info'}\n"; + $SF .= "CLB\n"; + $SF .= "$__{'Node events'}\n"; + $SF .= "
        "; + $SF .= ""; + $SF .= "\n\n\n
        "; + $SF .= ""; + $SF .= "\n\n        		"; + $SF .= "$__{'Entire word'}\n"; + $SF .= "$__{'Upper/lower case'}\n"; + $SF .= "$__{'Display Entire text'}
        \n"; + $SF .= "
        "; + return $SF; } sub searchpopup { - my ($tody,$todm,$todd) = split(/-/,qx(date +'%F')); chomp($todd); - my @validYears = reverse($WEBOBS{BIG_BANG}..$tody); - my $SP = ""; - $SP .= "
        "; - $SP .= "
        "; - my $sfstyle = "style=\"border: none; background: transparent; float: none; font: inherit; margin: 0; width: auto\""; - $SP .= "

        Search {".""."} for:

        "; - $SP .= ""; - $SP .= " \n"; - $SP .= "

        "; - - $SP .= "
        "; - $SP .= ""; - $SP .= "\n\n"; - $SP .= "

        "; - - $SP .= ""; - $SP .= "\n\n"; - $SP .= "

        "; - - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= "

        "; - - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= ""; - $SP .= "

        "; - $SP .= "
        "; - - $SP .= "

        "; - $SP .= ""; - $SP .= ""; - $SP .= "

        "; - $SP .= "
        "; - return $SP; + my ($tody,$todm,$todd) = split(/-/,qx(date +'%F')); chomp($todd); + my @validYears = reverse($WEBOBS{BIG_BANG}..$tody); + my $SP = ""; + $SP .= "
        "; + $SP .= "
        "; + my $sfstyle = "style=\"border: none; background: transparent; float: none; font: inherit; margin: 0; width: auto\""; + $SP .= "

        Search {".""."} for:

        "; + $SP .= ""; + $SP .= " \n"; + $SP .= "

        "; + + $SP .= "
        "; + $SP .= ""; + $SP .= "\n\n"; + $SP .= "

        "; + + $SP .= ""; + $SP .= "\n\n"; + $SP .= "

        "; + + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= "

        "; + + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= ""; + $SP .= "

        "; + $SP .= "
        "; + + $SP .= "

        "; + $SP .= ""; + $SP .= ""; + $SP .= "

        "; + $SP .= "
        "; + return $SP; } - 1; __END__ diff --git a/CODE/perl/lib/Suds.pm b/CODE/perl/lib/Suds.pm index 0ad7d5bc..a973fdd3 100644 --- a/CODE/perl/lib/Suds.pm +++ b/CODE/perl/lib/Suds.pm @@ -25,11 +25,11 @@ require WebObs::Config; sub demain { - my $annee = shift; - my $mois = shift; - my $jour = shift; - ($annee,$mois,$jour) = split(/-/,qx(date -d "$annee-$mois-$jour 1 day" +\%Y-\%m-\%d|tr -d '\n')); - return ($annee,$mois,$jour); + my $annee = shift; + my $mois = shift; + my $jour = shift; + ($annee,$mois,$jour) = split(/-/,qx(date -d "$annee-$mois-$jour 1 day" +\%Y-\%m-\%d|tr -d '\n')); + return ($annee,$mois,$jour); } =pod @@ -40,14 +40,14 @@ sub demain sub minute_suivante { - my $annee = shift; - my $mois = shift; - my $jour = shift; - my $heure = shift; - my $minute = shift; - my $seconde = shift; - ($annee,$mois,$jour,$heure,$minute,$seconde) = split(/-/,qx(date -d "$annee-$mois-$jour $heure:$minute:$seconde 1 minute" +\%Y-\%m-\%d-\%H-\%M-\%S|tr -d '\n')); - return ($annee,$mois,$jour,$heure,$minute,$seconde); + my $annee = shift; + my $mois = shift; + my $jour = shift; + my $heure = shift; + my $minute = shift; + my $seconde = shift; + ($annee,$mois,$jour,$heure,$minute,$seconde) = split(/-/,qx(date -d "$annee-$mois-$jour $heure:$minute:$seconde 1 minute" +\%Y-\%m-\%d-\%H-\%M-\%S|tr -d '\n')); + return ($annee,$mois,$jour,$heure,$minute,$seconde); } =pod @@ -58,14 +58,17 @@ sub minute_suivante sub dateFichierSuds { - my $suds = shift; - if (length(basename($suds)) == 12) { - #IASPEI - } elsif (length(basename($suds)) == 19) { - #SUDS2 - } elsif (length(basename($suds)) == 21) { - #SUDS2 avec suffixe - } + my $suds = shift; + if (length(basename($suds)) == 12) { + + #IASPEI + } elsif (length(basename($suds)) == 19) { + + #SUDS2 + } elsif (length(basename($suds)) == 21) { + + #SUDS2 avec suffixe + } } =pod @@ -76,31 +79,33 @@ sub dateFichierSuds sub fichiersSudsSuivants { - my $suds = shift; - my $nb_suds = shift; - my @liste_suds; - if (length(basename($suds)) == 12) { - # IASPEI - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; - my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x3 a2 a2 a2 a2 x a3",$suds); - my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); - my $chemin_date="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4$mois$jour/"; - my $chemin_lendemain="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4lendemain$moislendemain$jourlendemain"; - ( -d $chemin_lendemain ) or $chemin_lendemain=""; - $nb_suds--; - push(@liste_suds,split(/\n/, qx(find $chemin_date $chemin_lendemain -type f -print|sort|fgrep -A$nb_suds $suds))); - } elsif (length(basename($suds)) == 19) { - # SUDS2 - my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; - push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); - for(my $i = 1; $i < $nb_suds; $i++) { - my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds); - ($annee4, $mois, $jour, $heure, $minute, $seconde) = minute_suivante($annee4, $mois, $jour, $heure, $minute, $seconde); - $suds = "/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois${jour}_$heure$minute$seconde.$extension"; - push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); - } - } - return @liste_suds; + my $suds = shift; + my $nb_suds = shift; + my @liste_suds; + if (length(basename($suds)) == 12) { + + # IASPEI + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; + my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x3 a2 a2 a2 a2 x a3",$suds); + my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); + my $chemin_date="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4$mois$jour/"; + my $chemin_lendemain="$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA}/$annee4lendemain$moislendemain$jourlendemain"; + ( -d $chemin_lendemain ) or $chemin_lendemain=""; + $nb_suds--; + push(@liste_suds,split(/\n/, qx(find $chemin_date $chemin_lendemain -type f -print|sort|fgrep -A$nb_suds $suds))); + } elsif (length(basename($suds)) == 19) { + + # SUDS2 + my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; + push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); + for(my $i = 1; $i < $nb_suds; $i++) { + my ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds); + ($annee4, $mois, $jour, $heure, $minute, $seconde) = minute_suivante($annee4, $mois, $jour, $heure, $minute, $seconde); + $suds = "/$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois${jour}_$heure$minute$seconde.$extension"; + push(@liste_suds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}.$suds); + } + } + return @liste_suds; } =pod @@ -111,14 +116,14 @@ sub fichiersSudsSuivants sub fusion_suds { - my $suds = shift; - my $nb_suds = shift; - my @liste_suds = fichiersSudsSuivants($suds,$nb_suds); - my $dest_dir = qx(mktemp -d -p /tmp fusion_suds.XXXXXXXXXX); - chomp($dest_dir); - my $dest = $dest_dir."/".basename($suds); - print qx($WebObs::WEBOBS{RACINE_TOOLS_SHELLS}/sudsjoin_multiple $dest @liste_suds); - return ($dest_dir,$dest); + my $suds = shift; + my $nb_suds = shift; + my @liste_suds = fichiersSudsSuivants($suds,$nb_suds); + my $dest_dir = qx(mktemp -d -p /tmp fusion_suds.XXXXXXXXXX); + chomp($dest_dir); + my $dest = $dest_dir."/".basename($suds); + print qx($WebObs::WEBOBS{RACINE_TOOLS_SHELLS}/sudsjoin_multiple $dest @liste_suds); + return ($dest_dir,$dest); } =pod @@ -152,131 +157,131 @@ renvoi le nom du fichier SUDS a partir du nom de l'image Sefran2 sub imagesSudsMC { - my $suds_debut = shift; - my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES} - 2; - - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; - ($annee4, $mois, $jour, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut); - - my $annee2 = substr($annee4,2,2); - my $racineImage = $annee2.$mois.$jour.$heure.$minute.$seconde; - my $image = $racineImage.".png"; - my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); - my $repDate = $annee4.$mois.$jour; - my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; - - my $pathSrcImg="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; - my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; - ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; - - my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN_RACINE}/"); - my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; - return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); + my $suds_debut = shift; + my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES} - 2; + + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; + ($annee4, $mois, $jour, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut); + + my $annee2 = substr($annee4,2,2); + my $racineImage = $annee2.$mois.$jour.$heure.$minute.$seconde; + my $image = $racineImage.".png"; + my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); + my $repDate = $annee4.$mois.$jour; + my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; + + my $pathSrcImg="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; + my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN_IMAGES_SUDS}"; + ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; + + my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN_RACINE}/"); + my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; + return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); } sub fichierSudsImage { - my $imageSuds = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; - my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; - my $var = "PATH_SOURCE_SISMO_".$reseau; - return "$WebObs::WEBOBS{$var}/$annee4$mois$jour/$jour$heure$minute$seconde.$reseau"; + my $imageSuds = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; + my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; + my $var = "PATH_SOURCE_SISMO_".$reseau; + return "$WebObs::WEBOBS{$var}/$annee4$mois$jour/$jour$heure$minute$seconde.$reseau"; } sub fichiersSuds { - my @imagesSuds = @_; - my @fichiersSuds; - for (@imagesSuds) { - push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSudsImage($_)); - } - return @fichiersSuds; + my @imagesSuds = @_; + my @fichiersSuds; + for (@imagesSuds) { + push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSudsImage($_)); + } + return @fichiersSuds; } sub infosSuds { - my $imageSuds = shift; - my $id_fichier = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; - my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; - return "Date (début) : $annee4/$mois/$jour
        Heure (début) : $heure:$minute:$seconde
        Réseau : $reseau
        Fichier n° : $id_fichier"; + my $imageSuds = shift; + my $id_fichier = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+2; + my $annee4; my $mois; my $jour; my $annee2; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$annee2,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x a4 a2 a2 x$longueur_nom_suds a2 a2 a2 a2 a2 a2 a3 x a3",$_; + return "Date (début) : $annee4/$mois/$jour
        Heure (début) : $heure:$minute:$seconde
        Réseau : $reseau
        Fichier n° : $id_fichier"; } sub imageVoiesSefran { - my $suds_debut = shift; - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; - my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; - ($annee4GU, $moisGU, $jourGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut; - my $repDate = $annee4GU.$moisGU.$jourGU; - return "$repDate/$WebObs::WEBOBS{SEFRAN_VOIES_IMAGE}"; + my $suds_debut = shift; + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GUA})+2; + my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; + ($annee4GU, $moisGU, $jourGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 a2 x a3",$suds_debut; + my $repDate = $annee4GU.$moisGU.$jourGU; + return "$repDate/$WebObs::WEBOBS{SEFRAN_VOIES_IMAGE}"; } sub imagesSuds2MC { - my $suds_debut = shift; - my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES_SEFRAN2} - 2; - my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; - - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; - ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds_debut); - - my $annee2 = substr($annee4,2,2); - my $racineImage = $annee4.$mois.$jour.$heure.$minute.$seconde; - my $image = $racineImage.".png"; - my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); - my $repDate = $annee4.$mois.$jour; - my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; - - my $pathSrcImg="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; - my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; - ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; - - my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN2_RACINE}/"); - my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; - return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); + my $suds_debut = shift; + my $nb_suds = $WebObs::WEBOBS{MC_NOMBRE_FICHIERS_IMAGES_SEFRAN2} - 2; + my $longueur_nom_gwa = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA})+11; + + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $extension; + ($annee4, $mois, $jour, $heure, $minute, $seconde, $extension) = unpack("x$longueur_nom_gwa a4 a2 a2 x a2 a2 a2 x a3",$suds_debut); + + my $annee2 = substr($annee4,2,2); + my $racineImage = $annee4.$mois.$jour.$heure.$minute.$seconde; + my $image = $racineImage.".png"; + my ($annee4lendemain,$moislendemain,$jourlendemain) = demain($annee4,$mois,$jour); + my $repDate = $annee4.$mois.$jour; + my $repDateLendemain = $annee4lendemain.$moislendemain.$jourlendemain; + + my $pathSrcImg="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDate/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; + my $pathSrcImgLendemain="$WebObs::WEBOBS{SEFRAN2_RACINE}/$repDateLendemain/$WebObs::WEBOBS{SEFRAN2_IMAGES_SUDS}"; + ( -d $pathSrcImgLendemain ) or $pathSrcImgLendemain=""; + + my $car_debut_fichier = length("$WebObs::WEBOBS{SEFRAN2_RACINE}/"); + my $imageMC = "$annee4/$mois/$annee2$mois$jour$heure$minute$seconde.png"; + return $imageMC,split(/\n/, qx(find $pathSrcImg $pathSrcImgLendemain -type f -print|sort|grep -A$nb_suds $racineImage|cut -c$car_debut_fichier-)); } sub fichierSuds2Image { - my $imageSuds = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; - return "$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois$jour\_$heure$minute$seconde.$reseau"; + my $imageSuds = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; + return "$WebObs::WEBOBS{PATH_SOURCE_SISMO_GWA}/$annee4$mois$jour/$annee4$mois$jour\_$heure$minute$seconde.$reseau"; } sub fichiersSuds2 { - my @imagesSuds = @_; - my @fichiersSuds; - for (@imagesSuds) { - push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSuds2Image($_)); - } - return @fichiersSuds; + my @imagesSuds = @_; + my @fichiersSuds; + for (@imagesSuds) { + push(@fichiersSuds,$WebObs::WEBOBS{RACINE_SIGNAUX_SISMO}."/".fichierSuds2Image($_)); + } + return @fichiersSuds; } sub infosSuds2 { - my $imageSuds = shift; - my $id_fichier = shift; - my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; - my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; - ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; - return "Date (début) : $annee4-$mois-$jour
        Heure (début) : $heure:$minute:$seconde
        Réseau : $reseau
        Fichier n° : $id_fichier"; + my $imageSuds = shift; + my $id_fichier = shift; + my $longueur_nom_suds = length($WebObs::WEBOBS{SEFRAN_IMAGES_SUDS})+11; + my $annee4; my $mois; my $jour; my $heure; my $minute; my $seconde; my $reseau; my $ext; + ($annee4,$mois,$jour,$heure,$minute,$seconde,$reseau,$ext) = unpack "x$longueur_nom_suds a4 a2 a2 a2 a2 a2 a3 x a3",$_; + return "Date (début) : $annee4-$mois-$jour
        Heure (début) : $heure:$minute:$seconde
        Réseau : $reseau
        Fichier n° : $id_fichier"; } sub imageVoiesSefran2 { - my $suds_debut = shift; - my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_MIX})+11; - my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; - ($annee4GU, $moisGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 x a3",$suds_debut; - my $repDate = $annee4GU.$moisGU.$jourGU; - return "$repDate/$WebObs::WEBOBS{SEFRAN2_VOIES_IMAGE}"; + my $suds_debut = shift; + my $longueur_nom_iaspei = length($WebObs::WEBOBS{PATH_SOURCE_SISMO_MIX})+11; + my $annee4GU; my $moisGU; my $jourGU; my $heureGU; my $minuteGU; my $secondeGU; my $extensionGU; + ($annee4GU, $moisGU, $jourGU, $heureGU, $minuteGU, $secondeGU, $extensionGU) = unpack "x$longueur_nom_iaspei a4 a2 a2 x a2 a2 a2 x a3",$suds_debut; + my $repDate = $annee4GU.$moisGU.$jourGU; + return "$repDate/$WebObs::WEBOBS{SEFRAN2_VOIES_IMAGE}"; } 1; diff --git a/CODE/perl/lib/Users.pm b/CODE/perl/lib/Users.pm index d9bd0b46..282f3e38 100644 --- a/CODE/perl/lib/Users.pm +++ b/CODE/perl/lib/Users.pm @@ -95,9 +95,9 @@ $VERSION = "1.00"; refreshUsers(); if ((!defined($ENV{"REMOTE_USER"})) or ($ENV{"REMOTE_USER"} eq "") or (!defined($USERS{$ENV{"REMOTE_USER"}}))) { - $CLIENT = "guest"; + $CLIENT = "guest"; } else { - $CLIENT = $ENV{"REMOTE_USER"}; + $CLIENT = $ENV{"REMOTE_USER"}; } our @validtbls = ($WEBOBS{SQL_TABLE_AUTHVIEWS}, $WEBOBS{SQL_TABLE_AUTHPROCS}, $WEBOBS{SQL_TABLE_AUTHFORMS}, $WEBOBS{SQL_TABLE_AUTHMISC}, $WEBOBS{SQL_TABLE_AUTHWIKIS}); @@ -113,9 +113,9 @@ Reloads %USERS and %USERIDS. Needed by WebObs daemons (such as PostBoard) to han =cut sub refreshUsers { - undef %USERS if (%USERS); undef %USERIDS if (%USERIDS); - %USERS = %{allUsers()}; - $USERIDS{$USERS{$_}{UID}}=$_ foreach (keys(%USERS)) ; + undef %USERS if (%USERS); undef %USERIDS if (%USERIDS); + %USERS = %{allUsers()}; + $USERIDS{$USERS{$_}{UID}}=$_ foreach (keys(%USERS)) ; } =head2 allUsers @@ -133,25 +133,25 @@ Attributes names dynamically match the corresponding SQL table column names. =cut sub allUsers { - my ($rs, $dbh, $sql, $sth); + my ($rs, $dbh, $sql, $sth); - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tablename = $WEBOBS{SQL_TABLE_USERS}; - $USERS_LFN = "DB $dbname (".(stat($dbname))[9].") TABLE $tablename"; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tablename = $WEBOBS{SQL_TABLE_USERS}; + $USERS_LFN = "DB $dbname (".(stat($dbname))[9].") TABLE $tablename"; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; - $sql = "SELECT * FROM $tablename" ; - $sth = $dbh->prepare($sql); - $sth->execute(); - $rs = $sth->fetchall_hashref('LOGIN'); + $sql = "SELECT * FROM $tablename" ; + $sth = $dbh->prepare($sql); + $sth->execute(); + $rs = $sth->fetchall_hashref('LOGIN'); - $dbh->disconnect; - return $rs; + $dbh->disconnect; + return $rs; } =pod @@ -167,29 +167,29 @@ Returns a reference to the list (or 0). =cut sub listRNames { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type})); - my (@rs, $dbh, $sql, $sth, $tmp); - - #if ($KWARGS{type} ~~ @validtbls) { - if (grep /^$KWARGS{type}$/i , @validtbls) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT distinct(resource) FROM $KWARGS{type}" ; - $sth = $dbh->prepare($sql); - $sth->execute(); - $tmp = $sth->fetchall_arrayref(); - foreach (@$tmp) {push @rs, @$_} - - $dbh->disconnect; - return \@rs; - } else { return 0 } + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type})); + my (@rs, $dbh, $sql, $sth, $tmp); + + #if ($KWARGS{type} ~~ @validtbls) { + if (grep /^$KWARGS{type}$/i , @validtbls) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT distinct(resource) FROM $KWARGS{type}" ; + $sth = $dbh->prepare($sql); + $sth->execute(); + $tmp = $sth->fetchall_arrayref(); + foreach (@$tmp) {push @rs, @$_} + + $dbh->disconnect; + return \@rs; + } else { return 0 } } =pod @@ -201,18 +201,17 @@ Given user(s) UID(s) (ie. initials) returns user(s) full-name(s) =cut sub userName { - my @name; - for (@_) { - if ( defined($USERIDS{$_}) ) { - push(@name,$USERS{$USERIDS{$_}}{FULLNAME}); - } else { - push(@name,$_); - } - } - return @name; + my @name; + for (@_) { + if ( defined($USERIDS{$_}) ) { + push(@name,$USERS{$USERIDS{$_}}{FULLNAME}); + } else { + push(@name,$_); + } + } + return @name; } - =pod =head2 userListGroup @@ -225,29 +224,29 @@ all known user's groups: =cut sub userListGroup { - my (@groups, $dbh, $sql, $sth); - - if (defined($_[0])) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT GID"; - $sql .= " FROM $tblgroups"; - $sql .= " WHERE UID = '$USERS{$_[0]}{UID}'" ; - - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - foreach (@$tmp) {push @groups, @$_} - $dbh->disconnect; - } - return @groups; + my (@groups, $dbh, $sql, $sth); + + if (defined($_[0])) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT GID"; + $sql .= " FROM $tblgroups"; + $sql .= " WHERE UID = '$USERS{$_[0]}{UID}'" ; + + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + foreach (@$tmp) {push @groups, @$_} + $dbh->disconnect; + } + return @groups; } =pod @@ -263,32 +262,32 @@ all known user's authorizations: =cut sub userListAuth { - my (%rs, $dbh, $sql, $sth); - - if (defined($_[0])) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - for my $tblauth (@validtbls) { - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT $tblauth.RESOURCE, $tblauth.AUTH"; - $sql .= " FROM $tblusers,$tblauth"; - $sql .= " WHERE $tblusers.UID = '$USERS{$_[0]}{UID}' AND $tblusers.UID = $tblauth.UID" ; - $sql .= " ORDER BY 1,2"; - - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - $rs{$tblauth} = $tmp; - } - $dbh->disconnect; - } - return %rs; + my (%rs, $dbh, $sql, $sth); + + if (defined($_[0])) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + for my $tblauth (@validtbls) { + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT $tblauth.RESOURCE, $tblauth.AUTH"; + $sql .= " FROM $tblusers,$tblauth"; + $sql .= " WHERE $tblusers.UID = '$USERS{$_[0]}{UID}' AND $tblusers.UID = $tblauth.UID" ; + $sql .= " ORDER BY 1,2"; + + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + $rs{$tblauth} = $tmp; + } + $dbh->disconnect; + } + return %rs; } =pod @@ -308,42 +307,42 @@ to resource-'type' named 'name'. =cut sub userHasAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user}) || !exists($KWARGS{auth}) ); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user}) || !exists($KWARGS{auth}) ); - my ($rs, $dbh, $sql, $sth, $count); - my $rc = 0; + my ($rs, $dbh, $sql, $sth, $count); + my $rc = 0; - #if ($KWARGS{type} ~~ @validtbls) { - if (grep /^$KWARGS{type}$/i , @validtbls) { - $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + #if ($KWARGS{type} ~~ @validtbls) { + if (grep /^$KWARGS{type}$/i , @validtbls) { + $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; my $today = strftime("%Y-%m-%d",localtime(int(time()))); - my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); - if ($validuser eq 'Y') { - my @inl="'*'"; - while ($KWARGS{name} !~ m|^.?/$|) { push(@inl,"\'$KWARGS{name}\'"); $KWARGS{name}=dirname($KWARGS{name})."/"; }; - my $sql = "SELECT COUNT(*) FROM $KWARGS{type}"; - $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; - $sql .= " AND $KWARGS{type}.RESOURCE in (".join(", ",@inl).") AND $KWARGS{type}.AUTH >= $KWARGS{auth}"; - - $count = $dbh->selectrow_array($sql); - if ($count > 0) { $rc = 1 } - } - - $dbh->disconnect; - - } - return $rc; + my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); + if ($validuser eq 'Y') { + my @inl="'*'"; + while ($KWARGS{name} !~ m|^.?/$|) { push(@inl,"\'$KWARGS{name}\'"); $KWARGS{name}=dirname($KWARGS{name})."/"; }; + my $sql = "SELECT COUNT(*) FROM $KWARGS{type}"; + $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; + $sql .= " AND $KWARGS{type}.RESOURCE in (".join(", ",@inl).") AND $KWARGS{type}.AUTH >= $KWARGS{auth}"; + + $count = $dbh->selectrow_array($sql); + if ($count > 0) { $rc = 1 } + } + + $dbh->disconnect; + + } + return $rc; } =pod @@ -357,39 +356,39 @@ returns maximum authorization granted to user on resource type / resource name i =cut sub userMaxAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user})); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name}) || !exists($KWARGS{user})); - my ($rs, $dbh, $sql, $sth); - my $rc = 0; + my ($rs, $dbh, $sql, $sth); + my $rc = 0; - #if ($KWARGS{type} ~~ @validtbls) { - if (grep /^$KWARGS{type}$/i , @validtbls) { - $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + #if ($KWARGS{type} ~~ @validtbls) { + if (grep /^$KWARGS{type}$/i , @validtbls) { + $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; my $today = strftime("%Y-%m-%d",localtime(int(time()))); - my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); - if ($validuser eq 'Y') { - my $sql = "SELECT MAX(AUTH) FROM $KWARGS{type}"; - $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; - $sql .= " AND ($KWARGS{type}.RESOURCE IN $KWARGS{name} OR $KWARGS{type}.RESOURCE ='*')"; + my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); + if ($validuser eq 'Y') { + my $sql = "SELECT MAX(AUTH) FROM $KWARGS{type}"; + $sql .= " WHERE ( $KWARGS{type}.UID in (SELECT GID from $tblgroups WHERE UID='$KWARGS{user}') OR $KWARGS{type}.UID = '$KWARGS{user}') "; + $sql .= " AND ($KWARGS{type}.RESOURCE IN $KWARGS{name} OR $KWARGS{type}.RESOURCE ='*')"; - $rc = $dbh->selectrow_array($sql); - } + $rc = $dbh->selectrow_array($sql); + } - $dbh->disconnect; + $dbh->disconnect; - } - return $rc; + } + return $rc; } =pod @@ -403,29 +402,29 @@ returns true (1) if given 'user' login has a validity status 'Y' =cut sub userIsValid { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{user})); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{user})); - my $dbh; - my $rc = 0; + my $dbh; + my $rc = 0; - $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblusers = $WEBOBS{SQL_TABLE_USERS}; + $KWARGS{user} = $USERS{$KWARGS{user}}{UID}; + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblusers = $WEBOBS{SQL_TABLE_USERS}; - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; my $today = strftime("%Y-%m-%d",localtime(int(time()))); - my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); - if ($validuser eq 'Y') { $rc = 1 } + my $validuser = $dbh->selectrow_array("SELECT VALIDITY FROM $tblusers WHERE UID='$KWARGS{user}' AND (ENDDATE='' OR ENDDATE>='$today')"); + if ($validuser eq 'Y') { $rc = 1 } - $dbh->disconnect; + $dbh->disconnect; - return $rc; + return $rc; } =pod @@ -437,36 +436,36 @@ wrappers for userHasAuth with user=$CLIENT. =cut sub clientHasRead { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>READAUTH); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>READAUTH); } sub clientHasEdit { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>EDITAUTH); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>EDITAUTH); } sub clientHasAdm { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>ADMAUTH); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userHasAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}, auth=>ADMAUTH); } sub clientMaxAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - return userMaxAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}); + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + return userMaxAuth(type=>$KWARGS{type}, user=>$CLIENT, name=>$KWARGS{name}); } sub clientIsValid { - return userIsValid(user=>$CLIENT); + return userIsValid(user=>$CLIENT); } sub clientIsWO { - return 0 if ($USERS{$CLIENT}{UID} ne '!'); - return 1; + return 0 if ($USERS{$CLIENT}{UID} ne '!'); + return 1; } =pod @@ -480,30 +479,31 @@ Given a group ID 'GID' (starts with a '+'), returns an array of all associated u =cut sub groupListUser { - my (@users, $dbh, $sql, $sth); - - if (defined($_[0])) { - my $dbname = $WEBOBS{SQL_DB_USERS}; - my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - $sql = "SELECT UID"; - $sql .= " FROM $tblgroups"; - $sql .= " WHERE GID = '$_[0]'" ; - - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - foreach (@$tmp) {push @users, @$_} - $dbh->disconnect; - } - return @users; + my (@users, $dbh, $sql, $sth); + + if (defined($_[0])) { + my $dbname = $WEBOBS{SQL_DB_USERS}; + my $tblgroups = $WEBOBS{SQL_TABLE_GROUPS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + $sql = "SELECT UID"; + $sql .= " FROM $tblgroups"; + $sql .= " WHERE GID = '$_[0]'" ; + + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + foreach (@$tmp) {push @users, @$_} + $dbh->disconnect; + } + return @users; } + =pod =head2 resListAuth @@ -518,31 +518,31 @@ returns an Hash of arrays of all UID or GID's for each authorization levels =cut sub resListAuth { - my %KWARGS = @_; - return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); - - my (%rs, $dbh, $sql, $sth); - - my $dbname = $WEBOBS{SQL_DB_USERS}; - - $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) or die "DB error connecting to $dbname: ".DBI->errstr; - - foreach my $authlevel (READAUTH,EDITAUTH,ADMAUTH) { - $sql = "SELECT UID FROM $KWARGS{type} WHERE AUTH = $authlevel AND (RESOURCE = '$KWARGS{name}' OR RESOURCE = '*')"; - $sth = $dbh->prepare($sql); - $sth->execute(); - my $tmp = $sth->fetchall_arrayref(); - my @users; - foreach (@$tmp) { push(@users, @$_) } - $rs{$authlevel} = \@users; - } - $dbh->disconnect; - - return %rs; + my %KWARGS = @_; + return 0 if (!exists($KWARGS{type}) || !exists($KWARGS{name})); + + my (%rs, $dbh, $sql, $sth); + + my $dbname = $WEBOBS{SQL_DB_USERS}; + + $dbh = DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) or die "DB error connecting to $dbname: ".DBI->errstr; + + foreach my $authlevel (READAUTH,EDITAUTH,ADMAUTH) { + $sql = "SELECT UID FROM $KWARGS{type} WHERE AUTH = $authlevel AND (RESOURCE = '$KWARGS{name}' OR RESOURCE = '*')"; + $sth = $dbh->prepare($sql); + $sth->execute(); + my $tmp = $sth->fetchall_arrayref(); + my @users; + foreach (@$tmp) { push(@users, @$_) } + $rs{$authlevel} = \@users; + } + $dbh->disconnect; + + return %rs; } =pod @@ -557,34 +557,34 @@ error code otherwise). =cut sub htpasswd { - # Calls the htpasswd command with the provided command line - # options, login, and password. - # Arguments: (options, arg1, arg2, ..., password, output_ref) - # Returns the htpasswd exit code: 0 for success, > 0 otherwise. - my $htpw_opts = "-i".shift; # force -i to read the password from stdin - my $output_ref = pop; # reference where to store the output - my $pass = pop; # the password to pass via stdin (the last argument) - my @htpw_args = @_; # other arguments - - # Note: use a list for command arguments to avoid using a shell - my @cmd = ($WEBOBS{PRGM_HTPASSWD}, $htpw_opts, @htpw_args); - carp "info: executing command '".join(" ", @cmd)."'\n"; - - # Important: use IPC:Open3 to pass the password to stdin to the - # htpasswd command to avoid it being visible by other users. - my ($child_in, $child_out, $child_err); - my $pid = open3($child_in, $child_out, $child_err, @cmd); - print $child_in $pass; - close $child_in; # end the subprocess - - # Read all the output to $$output_ref - $$output_ref = do { local $/; <$child_out>; }; - - # Wait for the child to avoid zombies - waitpid($pid, 0); - return $? >> 8; -} + # Calls the htpasswd command with the provided command line + # options, login, and password. + # Arguments: (options, arg1, arg2, ..., password, output_ref) + # Returns the htpasswd exit code: 0 for success, > 0 otherwise. + my $htpw_opts = "-i".shift; # force -i to read the password from stdin + my $output_ref = pop; # reference where to store the output + my $pass = pop; # the password to pass via stdin (the last argument) + my @htpw_args = @_; # other arguments + + # Note: use a list for command arguments to avoid using a shell + my @cmd = ($WEBOBS{PRGM_HTPASSWD}, $htpw_opts, @htpw_args); + carp "info: executing command '".join(" ", @cmd)."'\n"; + + # Important: use IPC:Open3 to pass the password to stdin to the + # htpasswd command to avoid it being visible by other users. + my ($child_in, $child_out, $child_err); + my $pid = open3($child_in, $child_out, $child_err, @cmd); + print $child_in $pass; + close $child_in; # end the subprocess + + # Read all the output to $$output_ref + $$output_ref = do { local $/; <$child_out>; }; + + # Wait for the child to avoid zombies + waitpid($pid, 0); + return $? >> 8; +} =head2 htpasswd_update @@ -595,26 +595,29 @@ error code otherwise. =cut sub _get_htpasswd_encryption_opt { - # Auxiliary function that returns the htpasswd option to use according to - # the encryption format chosen in the configuration. - if (lc($WEBOBS{'HTPASSWD_ENCRYPTION'}) eq "bcrypt") { - return "B"; - } - # $WEBOBS{'HTPASSWD_ENCRYPTION'} is "md5" or anything - return "m"; + + # Auxiliary function that returns the htpasswd option to use according to + # the encryption format chosen in the configuration. + if (lc($WEBOBS{'HTPASSWD_ENCRYPTION'}) eq "bcrypt") { + return "B"; + } + + # $WEBOBS{'HTPASSWD_ENCRYPTION'} is "md5" or anything + return "m"; } sub htpasswd_update { - # Adds or update a login/password in the htpasswd file. - # Returns 0 if success, non-zero otherwise. - my $login = shift; # the login to create - my $pass = shift; # the new password to set - my $htpw_opt = _get_htpasswd_encryption_opt(); # options for htpasswd - my $output; # a reference for the output - # Call htpasswd with the selected option - return htpasswd($htpw_opt, $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); -} + # Adds or update a login/password in the htpasswd file. + # Returns 0 if success, non-zero otherwise. + my $login = shift; # the login to create + my $pass = shift; # the new password to set + my $htpw_opt = _get_htpasswd_encryption_opt(); # options for htpasswd + my $output; # a reference for the output + + # Call htpasswd with the selected option + return htpasswd($htpw_opt, $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); +} =head2 htpasswd_verify @@ -623,16 +626,16 @@ Verifies the password of a user in the $WEBOBS{'HTTP_PASSWORD_FILE'} file. =cut sub htpasswd_verify { + # Calls the htpasswd command to verify the login/password. - # Returns 0 if success, non-zero otherwise. - my $login = shift; - my $pass = shift; + # Returns 0 if success, non-zero otherwise. + my $login = shift; + my $pass = shift; - my $output; # a reference for the output - return htpasswd("v", $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); + my $output; # a reference for the output + return htpasswd("v", $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); } - =head2 htpasswd_display Displays the line that should be added to the $WEBOBS{'HTTP_PASSWORD_FILE'} @@ -641,22 +644,23 @@ file. =cut sub htpasswd_display { - # Calls the htpasswd command to display the line that should be added to - # the htpasswd file. Returns the output of the command. - my $login = shift; - my $pass = shift; - - my $htpw_opts = "n"._get_htpasswd_encryption_opt(); - my $output; # a reference for the output - my $rc = htpasswd($htpw_opts, $login, $pass, \$output); - my @lines = split(/\n/, $output); - if ($rc != 0 or not @lines) { - return "[error while executing $WEBOBS{'HTTP_PASSWORD_FILE'}]"; - } - # Returns the fist line of the output - return $lines[0]; -} + # Calls the htpasswd command to display the line that should be added to + # the htpasswd file. Returns the output of the command. + my $login = shift; + my $pass = shift; + + my $htpw_opts = "n"._get_htpasswd_encryption_opt(); + my $output; # a reference for the output + my $rc = htpasswd($htpw_opts, $login, $pass, \$output); + my @lines = split(/\n/, $output); + if ($rc != 0 or not @lines) { + return "[error while executing $WEBOBS{'HTTP_PASSWORD_FILE'}]"; + } + + # Returns the fist line of the output + return $lines[0]; +} 1; diff --git a/CODE/perl/lib/Utils.pm b/CODE/perl/lib/Utils.pm index 832392e8..8d2453b5 100644 --- a/CODE/perl/lib/Utils.pm +++ b/CODE/perl/lib/Utils.pm @@ -22,11 +22,12 @@ our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(u2l l2u htmlspecialchars getImageInfo makeThumbnail trim ltrim - rtrim tri_date_avec_id datediffdays isok romanx pga2msk attenuation num2roman txt2htm tex2utf - roundsd htm2frac qrcode url2target checkParam); + rtrim tri_date_avec_id datediffdays isok romanx pga2msk attenuation num2roman txt2htm tex2utf + roundsd htm2frac qrcode url2target checkParam); $VERSION = "1.00"; #-------------------------------------------------------------------------------------------------------------------------------------- + =pod =head2 u2l, l2u @@ -44,19 +45,18 @@ my $l2u = Locale::Recode->new (from => 'ISO-8859-15', to => 'UTF-8'); die $u2l->getError if $u2l->getError; die $l2u->getError if $l2u->getError; - # ------------------------------------------------------------------------------------------------- sub u2l ($) { - my $texte = shift; - $u2l->recode($texte) or die $u2l->getError; - return $texte; + my $texte = shift; + $u2l->recode($texte) or die $u2l->getError; + return $texte; } # ------------------------------------------------------------------------------------------------- sub l2u ($) { - my $texte = shift; - $l2u->recode($texte) or die $l2u->getError; - return $texte; + my $texte = shift; + $l2u->recode($texte) or die $l2u->getError; + return $texte; } binmode STDOUT, ':raw'; # Needed to make it work in UTF-8 locales in Perl-5.8. @@ -75,18 +75,18 @@ converts $textin B<" \< \>> to resp. html entities B<" < >> : sub htmlspecialchars { - my $txt = $_[0]; - my $re = $_[1]; - - $txt =~ s/"/"/g; - $txt =~ s/'/'/g; - $txt =~ s//>/g; -# print "
        ".$txt."
        "; - $txt =~ s/($re)/$1<\/b>/g if ($re ne ""); - return $txt; -} + my $txt = $_[0]; + my $re = $_[1]; + $txt =~ s/"/"/g; + $txt =~ s/'/'/g; + $txt =~ s//>/g; + + # print "
        ".$txt."
        "; + $txt =~ s/($re)/$1<\/b>/g if ($re ne ""); + return $txt; +} # ------------------------------------------------------------------------------------------------- @@ -102,22 +102,21 @@ converts any TeX characters in $textin into UTF-8 character: sub tex2utf { - my $text = $_[0]; - - $text =~ s/\\pm/±/g; - $text =~ s/\\approx/≈/g; - $text =~ s/\\pi/π/g; - $text =~ s/\\mu/µ/g; - $text =~ s/\\Omega/Ω/g; - $text =~ s/\\Sigma/∑/g; - $text =~ s/\\copyright/©/g; - $text =~ s/\\partial/∂/g; - $text =~ s/\\lt//g; - return $text; + my $text = $_[0]; + + $text =~ s/\\pm/±/g; + $text =~ s/\\approx/≈/g; + $text =~ s/\\pi/π/g; + $text =~ s/\\mu/µ/g; + $text =~ s/\\Omega/Ω/g; + $text =~ s/\\Sigma/∑/g; + $text =~ s/\\copyright/©/g; + $text =~ s/\\partial/∂/g; + $text =~ s/\\lt//g; + return $text; } - # ------------------------------------------------------------------------------------------------- =pod @@ -145,109 +144,111 @@ Example: sub makeThumbnail { - my $ret = ""; - my @needsel = (".pdf",".PDF"); - if (scalar(@_) == 4 ) { - my ($img, $path) = fileparse($_[0]); - my ($ext) = $img =~ /(\.[^.]+)$/; - my $thumb = $_[2]."/".$img.".".$_[3]; - #DL-was:if ($ext ~~ @needsel) { $img .= '[0]' } - if (grep /\Q$ext/i , @needsel) { $img .= '[0]' } - if ( !-e $thumb ) { - qx(/usr/bin/convert "$path$img" -thumbnail $_[1] -background white -alpha remove "$thumb" 2>/dev/null); - if ( $? == 0 ) { - $ret = $thumb; - } - } else { $ret = $thumb } - } - return $ret; + my $ret = ""; + my @needsel = (".pdf",".PDF"); + if (scalar(@_) == 4 ) { + my ($img, $path) = fileparse($_[0]); + my ($ext) = $img =~ /(\.[^.]+)$/; + my $thumb = $_[2]."/".$img.".".$_[3]; + + #DL-was:if ($ext ~~ @needsel) { $img .= '[0]' } + if (grep /\Q$ext/i , @needsel) { $img .= '[0]' } + if ( !-e $thumb ) { + qx(/usr/bin/convert "$path$img" -thumbnail $_[1] -background white -alpha remove "$thumb" 2>/dev/null); + if ( $? == 0 ) { + $ret = $thumb; + } + } else { $ret = $thumb } + } + return $ret; } - #-------------------------------------------------------------------------------------------------------------------------------------- sub getImageInfo { - my $ret = "", - my $img = $_[0]; - if (-e $img) { - $ret = qx(/usr/bin/identify -format "%[EXIF:DateTimeOriginal]|%G" "$img"); - chomp($ret); - } - return $ret; + my $ret = "", + my $img = $_[0]; + if (-e $img) { + $ret = qx(/usr/bin/identify -format "%[EXIF:DateTimeOriginal]|%G" "$img"); + chomp($ret); + } + return $ret; } #-------------------------------------------------------------------------------------------------------------------------------------- # Perl trim function to remove whitespace from the start and end of the string sub trim($) { - my $string = shift; - $string =~ s/^\s+//; - $string =~ s/\s+$//; - return $string; + my $string = shift; + $string =~ s/^\s+//; + $string =~ s/\s+$//; + return $string; } #-------------------------------------------------------------------------------------------------------------------------------------- # Left trim function to remove leading whitespace sub ltrim($) { - my $string = shift; - $string =~ s/^\s+//; - return $string; + my $string = shift; + $string =~ s/^\s+//; + return $string; } #-------------------------------------------------------------------------------------------------------------------------------------- # Right trim function to remove trailing whitespace sub rtrim($) { - my $string = shift; - $string =~ s/\s+$//; - return $string; + my $string = shift; + $string =~ s/\s+$//; + return $string; } - #-------------------------------------------------------------------------------------------------------------------------------------- # sort array of strings in the form "ID|yyyy-mm-dd|HH:MM|..." on date and time (second and third column) # (for use with mc3.pl) sub tri_date_avec_id ($$) { - my ($c,$d) = @_; - # removes first column (ID) - $c =~ s/^[\-0-9]+\|//; - $d =~ s/^[\-0-9]+\|//; - # replaces empty time by '00:00' so events without time appear first - $c =~ s/\|\|/00:00/; - $d =~ s/\|\|/00:00/; - return $d cmp $c; + my ($c,$d) = @_; + + # removes first column (ID) + $c =~ s/^[\-0-9]+\|//; + $d =~ s/^[\-0-9]+\|//; + + # replaces empty time by '00:00' so events without time appear first + $c =~ s/\|\|/00:00/; + $d =~ s/\|\|/00:00/; + return $d cmp $c; } #-------------------------------------------------------------------------------------------------------------------------------------- # sub datediffdays { - use DateTime::Duration; - - my ($y1,$m1,$d1,$h1,$n1,$s1) = split(/[- :]/,$_[0]); - my ($y2,$m2,$d2,$h2,$n2,$s2) = split(/[- :]/,$_[1]); - my $dt1 = DateTime->new( - year => $y1, + use DateTime::Duration; + + my ($y1,$m1,$d1,$h1,$n1,$s1) = split(/[- :]/,$_[0]); + my ($y2,$m2,$d2,$h2,$n2,$s2) = split(/[- :]/,$_[1]); + my $dt1 = DateTime->new( + year => $y1, month => $m1, day => $d1, hour => $h1, minute => $n1, second => $s1, time_zone => 'local', - ); - my $dt2 = DateTime->new( - year => $y2, + ); + my $dt2 = DateTime->new( + year => $y2, month => $m2, day => $d2, hour => $h2, minute => $n2, second => $s2, time_zone => 'local', - ) + DateTime::Duration->new(seconds => "1"); # add 1 second - - my $dur = $dt2->subtract_datetime_absolute($dt1); - #return "$dt1,$dt2"; - return sprintf("%1.0f", ($dur->in_units('seconds'))/86400); + ) + DateTime::Duration->new(seconds => "1"); # add 1 second + + my $dur = $dt2->subtract_datetime_absolute($dt1); + + #return "$dt1,$dt2"; + return sprintf("%1.0f", ($dur->in_units('seconds'))/86400); } #-------------------------------------------------------------------------------------------------------------------------------------- @@ -258,48 +259,49 @@ sub isok ($) return ($ok =~ /^(Y|YES|OK|ON|1|TRUE)/i ? 1:0); } - #-------------------------------------------------------------------------------------------------------------------------------------- sub romanx ($) -# Input: intensity MSK (numerical from 1 to 0 or 10) -# Output: intensity MSK (in roman numbers) -# Proc equivalent: matlab/romanx.m + + # Input: intensity MSK (numerical from 1 to 0 or 10) + # Output: intensity MSK (in roman numbers) + # Proc equivalent: matlab/romanx.m { - my @msk = ("X","I","II","III","IV","V","VI","VII","VIII","IX"); - my $string = shift; - return $msk[$string%10]; + my @msk = ("X","I","II","III","IV","V","VI","VII","VIII","IX"); + my $string = shift; + return $msk[$string%10]; } - #-------------------------------------------------------------------------------------------------------------------------------------- sub pga2msk ($) -# Input: ground acceleration (in mg) -# Output: intensity level MSK (in roman numbers) -# Proc equivalent matlab/pga2msk.m -# Author: F. Beauducel, IPGP, 2009-06-24 + + # Input: ground acceleration (in mg) + # Output: intensity level MSK (in roman numbers) + # Proc equivalent matlab/pga2msk.m + # Author: F. Beauducel, IPGP, 2009-06-24 { - my @msk = ('I','I-II','II','II-III','III','III-IV','IV','IV-V','V','V-VI','VI','VI-VII','VII','VII-VIII','VIII','VIII-IX','IX','IX-X','X','X-XI','XI','XI-XII','XII'); - my $pga = shift; - $pga = 2*(log($pga)*3/log(10) + 1.5) - 2; - if ($pga < 0) { $pga = 0; } - return $msk[$pga]; + my @msk = ('I','I-II','II','II-III','III','III-IV','IV','IV-V','V','V-VI','VI','VI-VII','VII','VII-VIII','VIII','VIII-IX','IX','IX-X','X','X-XI','XI','XI-XII','XII'); + my $pga = shift; + $pga = 2*(log($pga)*3/log(10) + 1.5) - 2; + if ($pga < 0) { $pga = 0; } + return $msk[$pga]; } - #-------------------------------------------------------------------------------------------------------------------------------------- sub attenuation ($$) -# Input: magnitude et distance hypocentrale (en km) -# Ouput: acceleration PGA (en g) -# Proc equivalent: matlab/attenuation.m -# Author: F. Beauducel, IPGP, 2009-06-24 + + # Input: magnitude et distance hypocentrale (en km) + # Ouput: acceleration PGA (en g) + # Proc equivalent: matlab/attenuation.m + # Author: F. Beauducel, IPGP, 2009-06-24 { - my ($mag,$hyp) = @_; - if ($hyp < 5) { $hyp = 5; } - my $pga = 1000*10**(0.620986*$mag - 0.00345256*$hyp - log($hyp)/log(10) - 3.374841); - return $pga; + my ($mag,$hyp) = @_; + if ($hyp < 5) { $hyp = 5; } + my $pga = 1000*10**(0.620986*$mag - 0.00345256*$hyp - log($hyp)/log(10) - 3.374841); + return $pga; } #-------------------------------------------------------------------------------------------------------------------------------------- + =pod =head2 num2roman $roman = num2roman($number); @@ -310,40 +312,40 @@ Proc equivalent: matlab/num2roman.m sub num2roman ($) { - my @r = (["I","X","C","M"],["V","L","D"," "," "]); - my $n = shift; - my $x; - - for my $i (reverse(0 .. floor(log10($n)))) { - my $ii = int($n/10**$i); - $x .= $r[0][$i] x $ii if ($ii < 4 || ($ii == 4 && $i == 3)); - $x .= $r[0][$i] if ($ii == 9 || ($ii == 4 && $i < 3)); - $x .= $r[1][$i].($r[0][$i] x ($ii - 5)) if ($ii >= 4 && $ii <= 8 && $i != 3); - $x .= $r[0][$i+1] if ($ii == 9); - $n -= $ii*10**$i; - } - return $x; + my @r = (["I","X","C","M"],["V","L","D"," "," "]); + my $n = shift; + my $x; + + for my $i (reverse(0 .. floor(log10($n)))) { + my $ii = int($n/10**$i); + $x .= $r[0][$i] x $ii if ($ii < 4 || ($ii == 4 && $i == 3)); + $x .= $r[0][$i] if ($ii == 9 || ($ii == 4 && $i < 3)); + $x .= $r[1][$i].($r[0][$i] x ($ii - 5)) if ($ii >= 4 && $ii <= 8 && $i != 3); + $x .= $r[0][$i+1] if ($ii == 9); + $n -= $ii*10**$i; + } + return $x; } #-------------------------------------------------------------------------------------------------------------------------------------- sub roundsd -# Round with significant digits -# Proc equivalent: matlab/roundsd.m -# Author: F. Beauducel, IPGP + + # Round with significant digits + # Proc equivalent: matlab/roundsd.m + # Author: F. Beauducel, IPGP { - my ($x, $n) = @_; - $n = 1 if ($n eq "" || $n < 1); - return 0 if ($x == 0); - my $e = floor(log(abs($x))/log(10) - $n + 1); - my $og = 10**abs($e); - if ($e > 0) { - return floor($x/$og + 0.5)*$og; - } else { - return floor($x*$og + 0.5)/$og; - } + my ($x, $n) = @_; + $n = 1 if ($n eq "" || $n < 1); + return 0 if ($x == 0); + my $e = floor(log(abs($x))/log(10) - $n + 1); + my $og = 10**abs($e); + if ($e > 0) { + return floor($x/$og + 0.5)*$og; + } else { + return floor($x*$og + 0.5)/$og; + } } - #-------------------------------------------------------------------------------------------------------------------------------------- sub qrcode ($) { @@ -351,23 +353,23 @@ sub qrcode ($) my $s = shift; return "" if ($s eq ""); my $url = "http://$ENV{HTTP_HOST}$ENV{REQUEST_URI}"; - my $qr = encode_base64(qx(qrencode -s $s -o - "$url")); + my $qr = encode_base64(qx(qrencode -s $s -o - "$url")); my $img = ($qr eq "" ? "":""); + ."'width=600,height=450,toolbar=no,menubar=no,status=no,location=no')\">"); return $img; } #-------------------------------------------------------------------------------------------------------------------------------------- sub url2target { - my $url = shift; - if ($url =~ /^\/(index*)?$/) { - return "_top"; - } elsif ($url =~ /^\//) { - return "bas"; - } else { - return "_blank"; - } + my $url = shift; + if ($url =~ /^\/(index*)?$/) { + return "_top"; + } elsif ($url =~ /^\//) { + return "bas"; + } else { + return "_blank"; + } } # ------------------------------------------------------------------------------------------------- @@ -375,16 +377,15 @@ sub url2target # Author: F. Beauducel, IPGP sub htm2frac { - my $s = shift; - if ($s =~ /[^< ]\//) { - my ($n, $d) = split(/[^< ]\//,$s); - return "
        $n
        $d
        "; - } else { - return $s; - } + my $s = shift; + if ($s =~ /[^< ]\//) { + my ($n, $d) = split(/[^< ]\//,$s); + return "
        $n
        $d
        "; + } else { + return $s; + } } - # ------------------------------------------------------------------------------------------------- =pod @@ -427,43 +428,43 @@ Use this instead: =cut sub checkParam ($$;$) { - # Parameters: - # - # $value (string or ARRAY ref, in a forced scalar context): - # The values to test. If an array ref, all elements of the array must - # match the pattern. Note: this cannot be a constant (e.g. 1, or "str") - # $pattern (regex pattern): - # The pattern to test the value against (should match the whole value - # from start to end of string). Should ALWAYS match the whole string - # (qr/^...$/), or it would completely defeat the security check. - # $param_name (string), optional: - # The error message to use with die of value does not match - # - # Exception: - # Dies with $error_msg if $value does not match pattern. - # Returns: - # $value - # - my $value = shift; - my $pattern = shift; - my $param_name = shift // ''; - my $error_msg; - my $want_array = ref($value) eq "ARRAY" ? 1 : 0; - my @values = $want_array ? @$value : ($value); - return unless defined $value; - - if ($param_name) { - $error_msg = "Error: bad value for parameter '$param_name', cannot continue."; - } else { - $error_msg = "Error: bad parameter value, cannot continue."; - } - - for my $v (@values) { - die $error_msg unless ($v =~ $pattern); - } - return $want_array ? @values : $value; -} + # Parameters: + # + # $value (string or ARRAY ref, in a forced scalar context): + # The values to test. If an array ref, all elements of the array must + # match the pattern. Note: this cannot be a constant (e.g. 1, or "str") + # $pattern (regex pattern): + # The pattern to test the value against (should match the whole value + # from start to end of string). Should ALWAYS match the whole string + # (qr/^...$/), or it would completely defeat the security check. + # $param_name (string), optional: + # The error message to use with die of value does not match + # + # Exception: + # Dies with $error_msg if $value does not match pattern. + # Returns: + # $value + # + my $value = shift; + my $pattern = shift; + my $param_name = shift // ''; + my $error_msg; + my $want_array = ref($value) eq "ARRAY" ? 1 : 0; + my @values = $want_array ? @$value : ($value); + return unless defined $value; + + if ($param_name) { + $error_msg = "Error: bad value for parameter '$param_name', cannot continue."; + } else { + $error_msg = "Error: bad parameter value, cannot continue."; + } + + for my $v (@values) { + die $error_msg unless ($v =~ $pattern); + } + return $want_array ? @values : $value; +} 1; diff --git a/CODE/perl/lib/VolcAuto.pm b/CODE/perl/lib/VolcAuto.pm index 6ac168b8..003f0810 100644 --- a/CODE/perl/lib/VolcAuto.pm +++ b/CODE/perl/lib/VolcAuto.pm @@ -25,14 +25,14 @@ use VolcAuto::MCEvent; use Exporter qw(import); our @EXPORT_OK = qw(debug_log err_log write_whole_file create_mc3_lock - remove_mc3_lock autovt2mc process_autovolc_csv); + remove_mc3_lock autovt2mc process_autovolc_csv); BEGIN { + # Suppress the default fatalsToBrowser from CGI::Carp $CGI::Carp::TO_BROWSER = 0; } - # ----------------------------------------------------------------------------- # Configuration and initialisation # @@ -46,7 +46,6 @@ my $AUTOVOLC_UID = 'VOLC'; # Event type to use in the MC for new automatic events my $AUTOVOLC_TYPE = 'VOLCAUTO'; - # Set DEBUG to 1 to see additional messages on stderr my $DEBUG = $ENV{'DEBUG'} // 1; @@ -59,7 +58,6 @@ $ENV{LANG} = $WEBOBS{LOCALE}; # Name of the script (for use in debug output) my $SCRIPT_NAME = basename($0); - # ----------------------------------------------------------------------------- # Subroutines # @@ -73,7 +71,6 @@ sub debug_log { say STDERR "[DEBUG] $msg" if ($DEBUG); } - # ----------------------------------------------------------------------------- # Log message to stderr if DEBUG is true # @@ -83,7 +80,6 @@ sub err_log { say STDERR "$SCRIPT_NAME: $msg"; } - # ----------------------------------------------------------------------------- # Read the whole content of a file # @@ -97,20 +93,19 @@ sub read_whole_file { my $file_name = shift; open(my $file, $file_name) - or die "Could not open '$file_name' for reading: $!"; + or die "Could not open '$file_name' for reading: $!"; my $file_content = do { local $/; # Enter slurp mode <$file>; # Read and return the whole file - }; + }; close($file) - or warn "Error while closing $file_name: $!"; + or warn "Error while closing $file_name: $!"; return $file_content; } - # ----------------------------------------------------------------------------- # Write/Overwrite the whole content of a file # @@ -126,15 +121,14 @@ sub write_whole_file { my $file_content = shift; open(my $file, ">", $file_name) - or die "Could not open '$file_name' for reading: $!"; + or die "Could not open '$file_name' for reading: $!"; print $file $file_content; close($file) - or warn "Error while closing $file_name: $!"; + or warn "Error while closing $file_name: $!"; } - # ----------------------------------------------------------------------------- # Create a non-blocking lock for the MC3 # (Using the WebObs™ way™, i.e. with race condition included.) @@ -153,6 +147,7 @@ sub create_mc3_lock { # Try to acquire the lock $try_count times before giving up. my $try_count = 3; + # Wait $wait seconds between tries my $wait = 2; @@ -162,8 +157,8 @@ sub create_mc3_lock { my $lock_owner = read_whole_file($lock_file); chomp $lock_owner; err_log(sprintf("MC is currently being locked by %s," - ." retrying in %d seconds...", - $lock_owner, (3 - $try_count) * $wait)); + ." retrying in %d seconds...", + $lock_owner, (3 - $try_count) * $wait)); sleep((3 - $try_count) * $wait); } @@ -175,7 +170,6 @@ sub create_mc3_lock { $lock_created = 1; } - # ----------------------------------------------------------------------------- # Remove the lock file for the MC3 # @@ -197,13 +191,12 @@ sub remove_mc3_lock { if (-e $lock_file) { unlink $lock_file - or warn "Error removing lock file '$lock_file': $!"; + or warn "Error removing lock file '$lock_file': $!"; } elsif ($warn_if_missing) { warn "Error removing lock file '$lock_file': file is missing!"; } } - # ----------------------------------------------------------------------------- # Return a VolcAuto::MCEvent object built from the data taken from a line of # the CVS file, using additional fixed values. @@ -224,7 +217,7 @@ sub autovt2mc { my $sefran_name = shift; my ($tmpl_id, $date, $time, $corr, $station, $mag) - = map { s/^\s+|\s+$//gr } split(/$INPUT_SEPARATOR/, $CSV_line); + = map { s/^\s+|\s+$//gr } split(/$INPUT_SEPARATOR/, $CSV_line); my $comment = sprintf('VT classe %d - %.2d%%', $tmpl_id, $corr * 100); if ($mag and $mag ne 'NaN') { @@ -232,22 +225,21 @@ sub autovt2mc { } return VolcAuto::MCEvent->new({ - 'mc3_name' => $mc3_name, - 'id' => $event_id, - 'date' => $date, - 'time' => $time, - 'type' => $AUTOVOLC_TYPE, - 'amplitude' => '', - 'duration' => 5, - 'unit' => 's', - 'sefran_name' => $sefran_name // undef, - 'station' => $station, - 'comment' => $comment, - 'operator' => $AUTOVOLC_UID, - }); + 'mc3_name' => $mc3_name, + 'id' => $event_id, + 'date' => $date, + 'time' => $time, + 'type' => $AUTOVOLC_TYPE, + 'amplitude' => '', + 'duration' => 5, + 'unit' => 's', + 'sefran_name' => $sefran_name // undef, + 'station' => $station, + 'comment' => $comment, + 'operator' => $AUTOVOLC_UID, + }); } - # ----------------------------------------------------------------------------- # Read CSV lines from STDIN and process them # @@ -266,6 +258,7 @@ sub process_autovolc_csv { my $mc_month; while (my $line = ) { + # Remove the trailing new line chomp $line; @@ -276,9 +269,11 @@ sub process_autovolc_csv { my $vt_event; $vt_event = autovt2mc($line, $mc3_name, 0, $sefran_name); try { + # Create the event with temporary id 0 $vt_event = autovt2mc($line, $mc3_name, 0, $sefran_name); } catch { + # The event is not well formed (some column is missing) debug_log("skipping malformed line '$line'"); $vt_event = undef; @@ -292,9 +287,9 @@ sub process_autovolc_csv { $mc->write_file() if ($mc); $mc = VolcAuto::MCFile->new($vt_event->{'datetime'}->year, - $vt_event->{'datetime'}->month, - $mc3_name, - $sefran_name); + $vt_event->{'datetime'}->month, + $mc3_name, + $sefran_name); } # Set proper id for the event diff --git a/CODE/perl/lib/Wiki.pm b/CODE/perl/lib/Wiki.pm index 5c737692..498e2247 100644 --- a/CODE/perl/lib/Wiki.pm +++ b/CODE/perl/lib/Wiki.pm @@ -81,7 +81,7 @@ use WebObs::Config qw(%WEBOBS readCfg); use WebObs::Grids; use WebObs::Users; if ($WEBOBS{WIKI_MMD} ne 'NO') { - require Text::MultiMarkdown; + require Text::MultiMarkdown; } our(@ISA, @EXPORT, @EXPORT_OK, $VERSION); @@ -91,25 +91,25 @@ require Exporter; $VERSION = "1.00"; sub wiki2html { - (my $string = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; - (my $clean, my $meta) = stripMDmetadata($string); - if (length($meta) == 0) { wiki($clean) } else { markdown($string) }; + (my $string = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; + (my $clean, my $meta) = stripMDmetadata($string); + if (length($meta) == 0) { wiki($clean) } else { markdown($string) }; } sub stripMDmetadata { - if (defined($_[0]) && $_[0] ne "") { - (my $txt = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; - return ($txt,"") if (defined($WEBOBS{WIKI_MMD}) && $WEBOBS{WIKI_MMD} eq 'NO'); - return ($txt, "") if ($txt !~ /\n\s*\n/); # no blank line means no chance for metadata - (my $head, my $tail) = split /\n\s*\n/ , $txt, 2; # head up to 1st blank line - my @head = split /\n(.+):/,"\n$head"; # hashes metadata key:value pairs - shift @head; # ... - my %hash = @head; # ... - return ($txt,"") if (!keys %hash || !$hash{WebObs}); # no keys or no WebObs key = no metadata - return ($tail, "$head\n\n"); - } else { - return ('', ''); - } + if (defined($_[0]) && $_[0] ne "") { + (my $txt = $_[0]) =~ s/^TITRE(_HTML)*\|.*\n//; + return ($txt,"") if (defined($WEBOBS{WIKI_MMD}) && $WEBOBS{WIKI_MMD} eq 'NO'); + return ($txt, "") if ($txt !~ /\n\s*\n/); # no blank line means no chance for metadata + (my $head, my $tail) = split /\n\s*\n/ , $txt, 2; # head up to 1st blank line + my @head = split /\n(.+):/,"\n$head"; # hashes metadata key:value pairs + shift @head; # ... + my %hash = @head; # ... + return ($txt,"") if (!keys %hash || !$hash{WebObs}); # no keys or no WebObs key = no metadata + return ($tail, "$head\n\n"); + } else { + return ('', ''); + } } =head2 WebObs Wiki language specifications: @@ -160,147 +160,148 @@ sub stripMDmetadata { sub wiki { - my $txt = $_[0]; - $txt.="\n"; + my $txt = $_[0]; + $txt.="\n"; - # --- include wiki files - $txt =~ s[\%\%(.*?)\%\%] { wfcheck($1); }egis; + # --- include wiki files + $txt =~ s[\%\%(.*?)\%\%] { wfcheck($1); }egis; - # --- remove ending ^M's - $txt =~ s/\cM\n/\n/g; + # --- remove ending ^M's + $txt =~ s/\cM\n/\n/g; - # --- \ ==>
        - $txt =~ s/\\\n/
        /g; + # --- \ ==>
        + $txt =~ s/\\\n/
        /g; - # --- ---- ==> horizontal line
        - $txt =~ s/----/
        /g; + # --- ---- ==> horizontal line
        + $txt =~ s/----/
        /g; - # --- || ==> - $txt =~ s/\|\|(.*)\|\|\n/<__row__> - - - - - - - - - - + + + + + + + + + + _EOD_ } @@ -404,14 +404,14 @@ =head1 QUERY-STRING PARAMETERS $dugrpsCount++; $dugrpsId="nudef".$dugrpsCount; $dugrps .= <<_EOD_ - - - - + + + + _EOD_ } @@ -433,18 +433,18 @@ =head1 QUERY-STRING PARAMETERS $Sdgrps .= <<_EOD_; - - - - + + + + _EOD_ } @@ -466,12 +466,12 @@ =head1 QUERY-STRING PARAMETERS $dunotfId="nudef".$dunotfCount; $dunotf .= <<_EOD_; - - + + _EOD_ } @@ -494,22 +494,22 @@ =head1 QUERY-STRING PARAMETERS $dnotfId="ndef".$dnotfCount; $dnotf .= <<_EOD_; - - - - - - - - + + + + + + + + _EOD_ } @@ -557,11 +557,11 @@ =head1 QUERY-STRING PARAMETERS } $TA{$an}{dauth} .= <<_EOD_; - - - - - + + + + + _EOD_ } @@ -589,101 +589,101 @@ =head1 QUERY-STRING PARAMETERS Identifications $go2top
        -
        • $userMsg

        - - - - - - -

        Edit user definition

        - -
        - -
        - -
        - -
        - -
        - - - -
        - -
        -

        - - -

        - - - - - - -

        Edit group/user definition

        - -
        - - -
        -

        - - -

        - - -
        Users -
        - $dusersCountValid/$dusersCount users valid/defined -
        -
        -
        -
        $1\n/g; # all lines ||...||\n are temporary rows - $txt =~ s/\|\|//g; # then all || are - $txt =~ s/<__row__>(.*?)\n(?!<__row__>)/$1<\/TABLE>\n/sg; # now enclose successive rows in table tags - $txt =~ s/<__row__>//g; # take care of leftover temporary rows + # --- || ==>
        + $txt =~ s/\|\|(.*)\|\|\n/<__row__>"; diff --git a/CODE/cgi-bin/formNOVAC.pl b/CODE/cgi-bin/formNOVAC.pl index 22306ed3..cc24be55 100755 --- a/CODE/cgi-bin/formNOVAC.pl +++ b/CODE/cgi-bin/formNOVAC.pl @@ -134,13 +134,13 @@ =head1 Query string parameter FIN @@ -282,7 +282,7 @@ =head1 Query string parameter print "\n"; +#djl-TBD $texte = $texte."\n"; push(@csv,"$date;$heure;$site;$aliasSite;$ope;$tAir;$tMeteo;$instr;$comp;$DM[0];$DS[0];$DM[1];$DS[1];$DM[2];$DS[2];\"".u2l($rem)."\"\n"); } @@ -527,16 +527,16 @@ =head1 Query string parameters } else { print @html; -#djl-TBD for ($nb=0;$nb<$#operateurs;$nb++) { -#djl-TBD $operNb[$nb] = sprintf("%5d x %s",$operStat{$operateurs[$nb][0]},$operateurs[$nb][1]); -#djl-TBD } -#djl-TBD @operNb = reverse(sort(grep(!/ 0 x/,@operNb))); -#djl-TBD print "

        ",@operNb)."',CAPTION,'Top opérateurs',ABOVE)\">?

        "; +#djl-TBD for ($nb=0;$nb<$#operateurs;$nb++) { +#djl-TBD $operNb[$nb] = sprintf("%5d x %s",$operStat{$operateurs[$nb][0]},$operateurs[$nb][1]); +#djl-TBD } +#djl-TBD @operNb = reverse(sort(grep(!/ 0 x/,@operNb))); +#djl-TBD print "

        ",@operNb)."',CAPTION,'Top opérateurs',ABOVE)\">?

        "; print "\n -
        \n\n\n"; + #attente { display: none; } + \n +
        \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showGAZ.pl b/CODE/cgi-bin/showGAZ.pl index f19a63ef..03f9b7e5 100755 --- a/CODE/cgi-bin/showGAZ.pl +++ b/CODE/cgi-bin/showGAZ.pl @@ -372,9 +372,9 @@ =head1 Query string parameters } else { print @html; print "\n -
        \n\n\n"; + #attente { display: none; } + \n +
        \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showGENFORM.pl b/CODE/cgi-bin/showGENFORM.pl index 3c6406d9..471ecd1f 100755 --- a/CODE/cgi-bin/showGENFORM.pl +++ b/CODE/cgi-bin/showGENFORM.pl @@ -173,14 +173,14 @@ =head1 Query string parameters "\n"; print <<"EOF"; - + EOF } else { push(@csv,"Content-Disposition: attachment; filename=\"$fileCSV\";\nContent-type: text/csv\n\n"); @@ -520,9 +520,9 @@ =head1 Query string parameters } else { print @html; print "\n -
        \n\n\n"; + #waiting { display: none; } + \n +
        \n\n\n"; } sub simplify_date { diff --git a/CODE/cgi-bin/showGRID.pl b/CODE/cgi-bin/showGRID.pl index 5ace91f1..aebc51f6 100755 --- a/CODE/cgi-bin/showGRID.pl +++ b/CODE/cgi-bin/showGRID.pl @@ -27,7 +27,7 @@ =head1 Query string parameters specify the coordonates. Default value is DEFAULT_COORDINATES variable in GRIDS.rc. Options are: latlon latitude and longitude utm Universal Transverse Mercator projection (WGS84) - xyz geocentric X, Y and Z + xyz geocentric X, Y and Z project= show/hide the project column. Default value is DEFAULT_PROJECT_FILTER variable in GRIDS.rc. Options are: @@ -219,11 +219,11 @@ =head1 Query string parameters $ilinks .= " | - "; + "; if ($WEBOBS{GOOGLE_EARTH_LINK} eq 1) { $ilinks .= " | \"KML\"\n"; + title=\"$WEBOBS{GOOGLE_EARTH_LINK_INFO}\">\"KML\"\n"; } $ilinks .= " | $__{Specifications}"; $ilinks .= " | $__{'Location'}"; diff --git a/CODE/cgi-bin/showNODE.pl b/CODE/cgi-bin/showNODE.pl index 83218628..d6e6e342 100755 --- a/CODE/cgi-bin/showNODE.pl +++ b/CODE/cgi-bin/showNODE.pl @@ -190,21 +190,21 @@ =head1 Query string parameters @@ -628,7 +628,7 @@ =head1 Query string parameters print "$txt"; } else { print "M3G GNSS Metadata"; - } #print "\n"; + } #print "\n"; print ""; } diff --git a/CODE/cgi-bin/showNODES.pl b/CODE/cgi-bin/showNODES.pl index ef065243..a5360118 100755 --- a/CODE/cgi-bin/showNODES.pl +++ b/CODE/cgi-bin/showNODES.pl @@ -58,14 +58,14 @@ =head1 DESCRIPTION diff --git a/CODE/cgi-bin/showNOVAC.pl b/CODE/cgi-bin/showNOVAC.pl index d0b76f8f..4053089e 100755 --- a/CODE/cgi-bin/showNOVAC.pl +++ b/CODE/cgi-bin/showNOVAC.pl @@ -224,7 +224,7 @@ =head1 Query string parameters } print "\n \n - "; for ("All|All sites",@NODESSelList) { my ($val,$cle) = split (/\|/,$_); if ("$val" eq "$QryParm->{'site'}") { @@ -238,7 +238,7 @@ =head1 Query string parameters } print "\n \n - "; + "; if ($editOK) { print "\n conf('CGI_FORM')."'\" value=\"new record\"/>"; diff --git a/CODE/cgi-bin/showOUTG.pl b/CODE/cgi-bin/showOUTG.pl index 8d8569e9..73c03f80 100755 --- a/CODE/cgi-bin/showOUTG.pl +++ b/CODE/cgi-bin/showOUTG.pl @@ -13,26 +13,26 @@ =head1 DESCRIPTION Displays contents of OUTG directory for the GRID gridname (ie. gridType.gridName). Optionaly specify the graph to display: -ts= can be any key defined in the GRID configuration TIMESCALELIST or 'map' or 'events' -g= any key defined in SUMMARYLIST, or one of the NODE ID - void (default) means an overview of all thumbnails for the first available timescale - for a PROC, and map for a VIEW - g=col shows all graphs in one column at full scale +ts= can be any key defined in the GRID configuration TIMESCALELIST or 'map' or 'events' +g= any key defined in SUMMARYLIST, or one of the NODE ID + void (default) means an overview of all thumbnails for the first available timescale + for a PROC, and map for a VIEW + g=col shows all graphs in one column at full scale - if ts=events, YYYY or YYYY/MM or YYYY/MM/DD to display available events - void (default) is last available year + if ts=events, YYYY or YYYY/MM or YYYY/MM/DD to display available events + void (default) is last available year refresh= - defines the number of seconds for automatic reloading of the page. This - overwrites default PROC's value AUTO_REFRESH_SECONDS + defines the number of seconds for automatic reloading of the page. This + overwrites default PROC's value AUTO_REFRESH_SECONDS header=no - hides the title, menu links and icons above the image + hides the title, menu links and icons above the image Directory paths of OUTG content is defined by the following variables: - - ROOT_OUTG (disk root path) in WEBOBS.rc (default is /opt/webobs/OUTG) - - URN_OUTG (web root path) in WEBOBS.rc (default is /OUTG) - - an alias in Apache configuration (must be URN_OUTG pointing to ROOT_OUTG!) + - ROOT_OUTG (disk root path) in WEBOBS.rc (default is /opt/webobs/OUTG) + - URN_OUTG (web root path) in WEBOBS.rc (default is /OUTG) + - an alias in Apache configuration (must be URN_OUTG pointing to ROOT_OUTG!) =cut use strict; @@ -59,7 +59,7 @@ =head1 DESCRIPTION #use Encode; #my ($strftime_encoding)= setlocale(LC_ALL); #sub strftime2 { # try to return an utf8 value from strftime -# $strftime_encoding ? Encode::decode($strftime_encoding, &strftime) : &strftime; +# $strftime_encoding ? Encode::decode($strftime_encoding, &strftime) : &strftime; #} # ---- see what we've been called for and what the client is allowed to do diff --git a/CODE/cgi-bin/showPLUVIO.pl b/CODE/cgi-bin/showPLUVIO.pl index 18307b9e..288f0ccf 100755 --- a/CODE/cgi-bin/showPLUVIO.pl +++ b/CODE/cgi-bin/showPLUVIO.pl @@ -325,9 +325,9 @@ =head1 Query string parameters } else { print @html; print "\n -
        \n\n\n"; + #attente { display: none; } + \n +
        \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showQRcode.pl b/CODE/cgi-bin/showQRcode.pl index c1f634c5..43b6aa19 100755 --- a/CODE/cgi-bin/showQRcode.pl +++ b/CODE/cgi-bin/showQRcode.pl @@ -16,7 +16,7 @@ =head1 Parameters no query string parameters needed, but logos will be displayed on the side of QR code, using the WEBOBS.rc variables: - QRCODE_LOGOS|URI_logo1,URI_logo2,... + QRCODE_LOGOS|URI_logo1,URI_logo2,... =cut @@ -51,7 +51,7 @@ =head1 Parameters $title\n -
        \n\n\n"; + #attente { display: none; } + \n +
        \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showREQ.pl b/CODE/cgi-bin/showREQ.pl index b5647281..1858c7b7 100755 --- a/CODE/cgi-bin/showREQ.pl +++ b/CODE/cgi-bin/showREQ.pl @@ -16,13 +16,13 @@ =head1 DESCRIPTION A submitted B will have all of its results (outputs) files grouped into the OUTR directory, under a subdirectory whose name uniquely identifies the Request: - OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID - REQUEST.rc - PROC.PROCa/ - {exports,graphs,maps,logs}/ - .... - PROC.PROCz/ - {exports,graphs,maps,logs}/ + OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID + REQUEST.rc + PROC.PROCa/ + {exports,graphs,maps,logs}/ + .... + PROC.PROCz/ + {exports,graphs,maps,logs}/ =cut @@ -90,7 +90,7 @@ =head1 DESCRIPTION ." ]

        "; $table = "
        $1\n/g; # all lines ||...||\n are temporary rows + $txt =~ s/\|\|//g; # then all || are + $txt =~ s/<__row__>(.*?)\n(?!<__row__>)/$1<\/TABLE>\n/sg; # now enclose successive rows in table tags + $txt =~ s/<__row__>//g; # take care of leftover temporary rows - # --- - ==>
          - $txt =~ s/^-/\n-/; # to find start of list - $txt =~ s/([^\n]$)/$1\n/; # to find end of list - $txt =~ s/\n-((?:.|\n)+?)\n([^-]|$)/\n
          • $1<\/UL>$2/g; - $txt =~ s/\n-/
          • /g; + # --- - ==>
              + $txt =~ s/^-/\n-/; # to find start of list + $txt =~ s/([^\n]$)/$1\n/; # to find end of list + $txt =~ s/\n-((?:.|\n)+?)\n([^-]|$)/\n\n"; $l2 = 0; } - if ($l1==1) { print "
              • \n"; } - $l1 = 1; - if (substr($titre,0,1) eq "!") { print "*" } - print "
            • ".substr($titre,1)."\n"; - next; - } - if ($l2==0) { print "
                \n"; $l2 = 1;} - if ( substr($titre,0,1) eq "*" ){ print "*" ; $titre = substr($titre,1) } - if ($l2==1) { print " ";} - print "
              • $titre
                • \n"; + next if(/^[ ]*#/ || /^$/); + my ($titre,$lien)=split(/\|/,$_); + + # $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; + # my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; + if (substr($titre,0,1) eq "+" || substr($titre,0,1) eq "!") { + if ($l2==1) { print "
              \n"; $l2 = 0; } + if ($l1==1) { print "
              • \n"; } + $l1 = 1; + if (substr($titre,0,1) eq "!") { print "*" } + print "
            • ".substr($titre,1)."\n"; + next; + } + if ($l2==0) { print "
                \n"; $l2 = 1;} + if ( substr($titre,0,1) eq "*" ){ print "*" ; $titre = substr($titre,1) } + if ($l2==1) { print " ";} + print "
              • $titre
                • \n"; } if ($l2==1) { print "
              \n"; } if ($l1==1) { print "
              • \n"; } diff --git a/CODE/perl/notify.pl b/CODE/perl/notify.pl index 340040d3..d719d1d3 100755 --- a/CODE/perl/notify.pl +++ b/CODE/perl/notify.pl @@ -21,17 +21,16 @@ =head1 DESCRIPTION use warnings; use WebObs::Config; - my $rc = WebObs::Config::notify($ARGV[0]); if ( $rc == 0) { - printf ("Sent.\n"); - exit(0); + printf ("Sent.\n"); + exit(0); } else { - if ($rc == 98) { printf ("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); } - if ($rc == 96) { printf ("Couldn't open $WEBOBS{POSTBOARD_NPIPE}: $? $!\n"); } - if ($rc == 97) { printf ("Missing argument, nothing to notify.\n"); } - if ($rc == 99) { printf ("Invalid argument format, not a notify request\n"); } - exit($rc); + if ($rc == 98) { printf ("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); } + if ($rc == 96) { printf ("Couldn't open $WEBOBS{POSTBOARD_NPIPE}: $? $!\n"); } + if ($rc == 97) { printf ("Missing argument, nothing to notify.\n"); } + if ($rc == 99) { printf ("Invalid argument format, not a notify request\n"); } + exit($rc); } __END__ diff --git a/CODE/perl/postboard.pl b/CODE/perl/postboard.pl index e3131c13..6b168663 100755 --- a/CODE/perl/postboard.pl +++ b/CODE/perl/postboard.pl @@ -153,8 +153,9 @@ =head1 NOTES use WebObs::Users; BEGIN { - # Suppress the default fatalsToBrowser from CGI::Carp - $CGI::Carp::TO_BROWSER = 0; + + # Suppress the default fatalsToBrowser from CGI::Carp + $CGI::Carp::TO_BROWSER = 0; } # ---- parse options @@ -171,15 +172,15 @@ BEGIN # ---- initialize : pid file and logging # ---------------------------------------------------------------------------- if (!$WEBOBS{ROOT_LOGS}) { - printf(STDERR "Cannot start: ROOT_LOGS not found in WebObs configuration\n"); - exit(98); + printf(STDERR "Cannot start: ROOT_LOGS not found in WebObs configuration\n"); + exit(98); } # Open log file my $LOGNAME = "$WEBOBS{ROOT_LOGS}/$ME.log" ; if (! open(LOG, ">>", $LOGNAME)) { - print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); - exit(98); + print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); + exit(98); } select((select(LOG), $|=1)[0]); # turn off buffering logit("------------------------------------------------------------------------"); @@ -187,9 +188,9 @@ BEGIN # ---- is fifo name defined ? # ---------------------------------------------------------------------------- if (!defined($WEBOBS{POSTBOARD_NPIPE})) { - logit("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration"); - printf("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); - exit(98); + logit("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration"); + printf("Can't start: no POSTBOARD_NPIPE definition in WebObs configuration\n"); + exit(98); } # ---- should we (re)-create fifo (when missing or -c(lean) requested) ? @@ -198,12 +199,12 @@ BEGIN my $FIFO = $WEBOBS{POSTBOARD_NPIPE}; unlink $FIFO if (-p $FIFO && $clean); if (! -p $FIFO) { - umask 0011; - if (! mkfifo($FIFO, 0777)) { - logit("Can't start: couldn't mkfifo $FIFO: $!"); - printf("Can't start: couldn't mkfifo $FIFO: $!\n"); - exit(98); - } + umask 0011; + if (! mkfifo($FIFO, 0777)) { + logit("Can't start: couldn't mkfifo $FIFO: $!"); + printf("Can't start: couldn't mkfifo $FIFO: $!\n"); + exit(98); + } } # ---- need to tell someone when I'm taken down ! @@ -220,288 +221,297 @@ BEGIN while (1) { - my $queued = ; # input looks like "timestamp | event-name | emitting-pid | message" - $queued =~ tr/\0/\n/; # x00 assumed instead of \n in pipe, translate back - chomp $queued; - #?? todo: check for queued enclosed in my defined-delimiters ==> my implementation of boundaries to - #?? validate non-interleaved msg from other writing-ends ??? - my @REQ = split(/\|/, $queued); - - # The message argument may be empty (in case of action without argument). - if (@REQ == 3) { - push(@REQ, ''); - } - - if (@REQ != 4) { - logit("ignoring invalid request [@REQ]"); - next; - } - - WebObs::Users::refreshUsers(); - - # shorten the message just for verbose mode display - my $shortreq3 = (length($REQ[3]) > 33) ? substr($REQ[3],0,15)."...".substr($REQ[3],-15) : $REQ[3]; - $shortreq3 =~ s/\n//g; - logit("got event [$REQ[1]] from $REQ[2] saying [$REQ[0] - $shortreq3]") if ($verbose); - my $sql = my $eventclause = ''; - my $validclause = " validity = 'Y' "; - - # ---- process emailing if we know how to do it and have mailid(s) for this event $REQ[1] - if (defined($WEBOBS{POSTBOARD_MAILER})) { - $WEBOBS{POSTBOARD_MAILER_OPTS} ||= ''; - $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT} ||= "notify"; - - my $allMails = fetch_emails($REQ[1]); - - if (not @$allMails) { - logit("no mailing for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); - } else { - - for my $row (@$allMails) { - - my @oneMAIL = @$row; - my @oneREQ = @REQ; # save original request (maybe overkill) - - # Parse the incoming request's message ($oneREQ[3]): look for special keywords - # Message syntax is: [any text][keyword=[value-allowing-embedded-blanks]...] - # no | allowed in message; no keyword in 'any text' of course - # $px will be set to 'any text' - # %sp will gather parsed keywords as $sp{'keyword='} = 'value' (trimmed) - my $re = join('|', ('rc', 'cmd', 'log', 'uid', 'org', 'file', 'subject', 'attach')); - my ($px, %sp) = map { s/^\s+|\s+$//gr } split(/((?:$re)=)\s*/, $oneREQ[3]); - - # Any event's message can override defaults found in table 'notifications' - # uid= - if ($sp{'uid='}) { - if ($USERIDS{$sp{'uid='}}) { - $oneMAIL[0] = $sp{'uid='}; - } else { - logit("warning: ignoring unknown recipient uid in $oneREQ[3]"); - } - } - # subject= - if (defined($sp{'subject='})) { - $oneMAIL[1] = $sp{'subject='}; - } - # attach= - if (defined($sp{'attach='})) { - $oneMAIL[2] = $sp{'attach='}; - } - - # Intercept the special 'submitrc.jid' event for special email formatting - if ($oneREQ[1] =~ s/^submitrc\.//) { - $oneREQ[3] = ""; # create a brand new $oneREQ[3] for normal mail processing below - if (defined($sp{'org='}) && $sp{'org='} =~ m/^R/) { - # it is an end-of-request (submit) : - $oneMAIL[1] = "request $oneREQ[1] has ended"; - $oneREQ[3] .= "request submitted by "; - $oneREQ[3] .= $sp{'uid='} ? "$sp{'uid='}\n" : "* unspecified uid *\n" ; - } else { - # it is an end-of-scheduled job : - $oneMAIL[1] = "scheduled job $oneREQ[1] has ended"; - # ignore this mail (ie. do NOT send) if an rc-condition is not met - next if (defined($sp{'rc='}) && !rccond($oneMAIL[4],$sp{'rc='})); - } - if (defined($sp{'cmd='})) { - $oneREQ[3] .= "Command = $sp{'cmd='}\n"; - } - if (defined($sp{'rc='})) { - $oneREQ[3] .= "Ended with rc=$sp{'rc='}\n"; - } - if (defined($sp{'log='})) { - $sp{'log='} =~ s/[\[\] ]//g; - $oneREQ[3] .= "Log = $WEBOBS{ROOT_URL}/cgi-bin/index.pl?page=/cgi-bin/schedulerLogs.pl?log=$sp{'log='}\n"; - } - if ($px ne '') { - $oneREQ[3] .= "\n$px\n"; - } - } else { - # event other than '^submitrc\.' - $oneREQ[3] = $px if ($px); - } - - # Continue with mail processing - my $allAddrs = fetch_email_addrs($oneMAIL[0]); - - if (not @$allAddrs) { - logit("error: recipient uid/gid '$oneMAIL[0]' " - ."not found in database, aborting mailing."); - } else { - my $addrlist = join(' ', map { $_->[0] } @$allAddrs); - if (not $addrlist) { - logit("warning: no email address defined for recipient" - ." uid/gid '$oneMAIL[0]', aborting mailing."); - } else { - my $options = $WEBOBS{POSTBOARD_MAILER_OPTS}; - if ($oneMAIL[1] and $oneMAIL[1] ne '-') { - $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $oneMAIL[1]\'"; - } else { - $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT}\'"; - } - if ($oneMAIL[2] and $oneMAIL[2] ne '-' and -e $oneMAIL[2]) { - $options .= " -a \'$oneMAIL[2]\'"; - } - if ($oneREQ[2] =~ m/^([^.@]+)(\.[^.@]+)*@(([^.@]+\.)+([^.@]+))$/) { - my $domain = $3; - my $fulln = ''; - for my $login (keys(%USERS)) { - if ($USERS{$login}{EMAIL} =~ m/^$oneREQ[2]/) { - $fulln = $USERS{$login}{FULLNAME}; - } - } - if ($fulln ne '') { - $options .= qq( -e 'set from="$fulln <$oneREQ[2]>"'); - } - } - my $tmp_email_body = sprintf ("$WEBOBS{PATH_TMP_APACHE}/WOPB.$$.%16.6f", time); - if (open(my $body_file, ">", $tmp_email_body)) { - print $body_file "$oneREQ[3]" ; - if ($sp{'file='} && -f "$sp{'file='}") { - print $body_file "\n", read_file($sp{'file='}); - } - close $body_file - or logit("warning: an error occurred while closing $tmp_email_body"); - logit("executing '$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body'") if ($verbose); - system("$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body"); - if ($?) { logit("error: mailing failed: $?") } - unlink($tmp_email_body); - } else { - logit("error: couldn't open temporary file for mailing: $?"); - } - } # end we have non-empty email address(es) for this mail - } # end we have recipient(s) for this mail - } # end for each mail - } # we have mailing(s) in table for this event - } # end we know how to mail from config setting - - # ---- process action(s) if we have any for this event - my $allActions = fetch_actions($REQ[1]); - - if (@$allActions) { - for my $action (@$allActions) { - my $cmd = sprintf("%s %s", $action->[0], $REQ[3]); - logit("executing action '$cmd'") if ($verbose); - system($cmd); - if ($?) { logit("action command [$cmd] failed: $?: $!") } - } - } else { - logit("no actions for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); - } + my $queued = ; # input looks like "timestamp | event-name | emitting-pid | message" + $queued =~ tr/\0/\n/; # x00 assumed instead of \n in pipe, translate back + chomp $queued; + +#?? todo: check for queued enclosed in my defined-delimiters ==> my implementation of boundaries to +#?? validate non-interleaved msg from other writing-ends ??? + my @REQ = split(/\|/, $queued); + + # The message argument may be empty (in case of action without argument). + if (@REQ == 3) { + push(@REQ, ''); + } + + if (@REQ != 4) { + logit("ignoring invalid request [@REQ]"); + next; + } + + WebObs::Users::refreshUsers(); + + # shorten the message just for verbose mode display + my $shortreq3 = (length($REQ[3]) > 33) ? substr($REQ[3],0,15)."...".substr($REQ[3],-15) : $REQ[3]; + $shortreq3 =~ s/\n//g; + logit("got event [$REQ[1]] from $REQ[2] saying [$REQ[0] - $shortreq3]") if ($verbose); + my $sql = my $eventclause = ''; + my $validclause = " validity = 'Y' "; + +# ---- process emailing if we know how to do it and have mailid(s) for this event $REQ[1] + if (defined($WEBOBS{POSTBOARD_MAILER})) { + $WEBOBS{POSTBOARD_MAILER_OPTS} ||= ''; + $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT} ||= "notify"; + + my $allMails = fetch_emails($REQ[1]); + + if (not @$allMails) { + logit("no mailing for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); + } else { + + for my $row (@$allMails) { + + my @oneMAIL = @$row; + my @oneREQ = @REQ; # save original request (maybe overkill) + +# Parse the incoming request's message ($oneREQ[3]): look for special keywords +# Message syntax is: [any text][keyword=[value-allowing-embedded-blanks]...] +# no | allowed in message; no keyword in 'any text' of course +# $px will be set to 'any text' +# %sp will gather parsed keywords as $sp{'keyword='} = 'value' (trimmed) + my $re = join('|', ('rc', 'cmd', 'log', 'uid', 'org', 'file', 'subject', 'attach')); + my ($px, %sp) = map { s/^\s+|\s+$//gr } split(/((?:$re)=)\s*/, $oneREQ[3]); + + # Any event's message can override defaults found in table 'notifications' + # uid= + if ($sp{'uid='}) { + if ($USERIDS{$sp{'uid='}}) { + $oneMAIL[0] = $sp{'uid='}; + } else { + logit("warning: ignoring unknown recipient uid in $oneREQ[3]"); + } + } + + # subject= + if (defined($sp{'subject='})) { + $oneMAIL[1] = $sp{'subject='}; + } + + # attach= + if (defined($sp{'attach='})) { + $oneMAIL[2] = $sp{'attach='}; + } + + # Intercept the special 'submitrc.jid' event for special email formatting + if ($oneREQ[1] =~ s/^submitrc\.//) { + $oneREQ[3] = ""; # create a brand new $oneREQ[3] for normal mail processing below + if (defined($sp{'org='}) && $sp{'org='} =~ m/^R/) { + + # it is an end-of-request (submit) : + $oneMAIL[1] = "request $oneREQ[1] has ended"; + $oneREQ[3] .= "request submitted by "; + $oneREQ[3] .= $sp{'uid='} ? "$sp{'uid='}\n" : "* unspecified uid *\n" ; + } else { + + # it is an end-of-scheduled job : + $oneMAIL[1] = "scheduled job $oneREQ[1] has ended"; + + # ignore this mail (ie. do NOT send) if an rc-condition is not met + next if (defined($sp{'rc='}) && !rccond($oneMAIL[4],$sp{'rc='})); + } + if (defined($sp{'cmd='})) { + $oneREQ[3] .= "Command = $sp{'cmd='}\n"; + } + if (defined($sp{'rc='})) { + $oneREQ[3] .= "Ended with rc=$sp{'rc='}\n"; + } + if (defined($sp{'log='})) { + $sp{'log='} =~ s/[\[\] ]//g; + $oneREQ[3] .= "Log = $WEBOBS{ROOT_URL}/cgi-bin/index.pl?page=/cgi-bin/schedulerLogs.pl?log=$sp{'log='}\n"; + } + if ($px ne '') { + $oneREQ[3] .= "\n$px\n"; + } + } else { + + # event other than '^submitrc\.' + $oneREQ[3] = $px if ($px); + } + + # Continue with mail processing + my $allAddrs = fetch_email_addrs($oneMAIL[0]); + + if (not @$allAddrs) { + logit("error: recipient uid/gid '$oneMAIL[0]' " + ."not found in database, aborting mailing."); + } else { + my $addrlist = join(' ', map { $_->[0] } @$allAddrs); + if (not $addrlist) { + logit("warning: no email address defined for recipient" + ." uid/gid '$oneMAIL[0]', aborting mailing."); + } else { + my $options = $WEBOBS{POSTBOARD_MAILER_OPTS}; + if ($oneMAIL[1] and $oneMAIL[1] ne '-') { + $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $oneMAIL[1]\'"; + } else { + $options .= " -s \'[WebObs-$WEBOBS{WEBOBS_ID}] $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT}\'"; + } + if ($oneMAIL[2] and $oneMAIL[2] ne '-' and -e $oneMAIL[2]) { + $options .= " -a \'$oneMAIL[2]\'"; + } + if ($oneREQ[2] =~ m/^([^.@]+)(\.[^.@]+)*@(([^.@]+\.)+([^.@]+))$/) { + my $domain = $3; + my $fulln = ''; + for my $login (keys(%USERS)) { + if ($USERS{$login}{EMAIL} =~ m/^$oneREQ[2]/) { + $fulln = $USERS{$login}{FULLNAME}; + } + } + if ($fulln ne '') { + $options .= qq( -e 'set from="$fulln <$oneREQ[2]>"'); + } + } + my $tmp_email_body = sprintf ("$WEBOBS{PATH_TMP_APACHE}/WOPB.$$.%16.6f", time); + if (open(my $body_file, ">", $tmp_email_body)) { + print $body_file "$oneREQ[3]" ; + if ($sp{'file='} && -f "$sp{'file='}") { + print $body_file "\n", read_file($sp{'file='}); + } + close $body_file + or logit("warning: an error occurred while closing $tmp_email_body"); + logit("executing '$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body'") if ($verbose); + system("$WEBOBS{POSTBOARD_MAILER} $options -- $addrlist < $tmp_email_body"); + if ($?) { logit("error: mailing failed: $?") } + unlink($tmp_email_body); + } else { + logit("error: couldn't open temporary file for mailing: $?"); + } + } # end we have non-empty email address(es) for this mail + } # end we have recipient(s) for this mail + } # end for each mail + } # we have mailing(s) in table for this event + } # end we know how to mail from config setting + + # ---- process action(s) if we have any for this event + my $allActions = fetch_actions($REQ[1]); + + if (@$allActions) { + for my $action (@$allActions) { + my $cmd = sprintf("%s %s", $action->[0], $REQ[3]); + logit("executing action '$cmd'") if ($verbose); + system($cmd); + if ($?) { logit("action command [$cmd] failed: $?: $!") } + } + } else { + logit("no actions for [$REQ[1]] in table $WEBOBS{SQL_TABLE_NOTIFICATIONS}") if ($verbose); + } } # end of while (1) endit(99); - # Function definitions -------------------------------------------------------- sub db_connect { - # Open a connection to a SQLite database - # - # Usage example: - # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) - # || die "Error connecting to $dbname: $DBI::errstr"; - # - my $dbname = shift; - return DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) -} + # Open a connection to a SQLite database + # + # Usage example: + # my $dbh = db_connect($WEBOBS{SQL_DB_POSTBOARD}) + # || die "Error connecting to $dbname: $DBI::errstr"; + # + my $dbname = shift; + return DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) +} sub get_subscriptions_clause { - # Build and return the SQL 'where' clause to select subscriptions - # corresponding to the event. - my $event_name = shift; - my $where; - - if ($event_name =~ m/^submitrc\.(.*)$/) { - # Event is 'submitrc.{something}': grab subscriptions for - # 'submitrc.', 'submitrc.rc*', and 'submitrc.something.rc*' - return "(event = 'submitrc.' OR event LIKE 'submitrc.rc%' OR event LIKE 'submitrc.$1.rc%')"; - } - if ($event_name =~ m/^([^\.]*)\.(.*)$/) { - # Event is 'majorid.{minorid}': grab 'majorid.' + 'majorid.minorid' subscriptions - return "(event = '$event_name' OR event = '$1.')"; - } - # Event is 'majorid': grab 'majorid' subscriptions - return "event = '$event_name'"; -} + # Build and return the SQL 'where' clause to select subscriptions + # corresponding to the event. + my $event_name = shift; + my $where; -sub fetch_all { - # Connect to a database, run the given SQL statement, and - # return a reference to an array of array references. - my $dbname = shift; - my $query = shift; - - my $dbh = db_connect($dbname); - if (not $dbh) { - logit("Error connecting to $dbname: $DBI::errstr"); - return; - } - # Will raise an error if anything goes wrong - my $ref = $dbh->selectall_arrayref($query); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $dbname: " - . $dbh->errstr; - return $ref; + if ($event_name =~ m/^submitrc\.(.*)$/) { + + # Event is 'submitrc.{something}': grab subscriptions for + # 'submitrc.', 'submitrc.rc*', and 'submitrc.something.rc*' + return "(event = 'submitrc.' OR event LIKE 'submitrc.rc%' OR event LIKE 'submitrc.$1.rc%')"; + } + if ($event_name =~ m/^([^\.]*)\.(.*)$/) { + +# Event is 'majorid.{minorid}': grab 'majorid.' + 'majorid.minorid' subscriptions + return "(event = '$event_name' OR event = '$1.')"; + } + + # Event is 'majorid': grab 'majorid' subscriptions + return "event = '$event_name'"; } +sub fetch_all { -sub fetch_emails { - # Return the list of email subscriptions for an event - my $event_name = shift; - my $where_event = get_subscriptions_clause($event_name); - my $q = "SELECT uid,mailsubject,mailattach,validity,event" - ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." WHERE uid != '-' AND validity = 'Y' AND $where_event"; - - return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); + # Connect to a database, run the given SQL statement, and + # return a reference to an array of array references. + my $dbname = shift; + my $query = shift; + + my $dbh = db_connect($dbname); + if (not $dbh) { + logit("Error connecting to $dbname: $DBI::errstr"); + return; + } + + # Will raise an error if anything goes wrong + my $ref = $dbh->selectall_arrayref($query); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $dbname: " + . $dbh->errstr; + return $ref; } +sub fetch_emails { -sub fetch_actions { - # Return the list of actions for an event - my $event_name = shift; - my $where_event = get_subscriptions_clause($event_name); - my $q = "SELECT action FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" - ." WHERE action != '-' AND validity = 'Y' AND $where_event"; + # Return the list of email subscriptions for an event + my $event_name = shift; + my $where_event = get_subscriptions_clause($event_name); + my $q = "SELECT uid,mailsubject,mailattach,validity,event" + ." FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." WHERE uid != '-' AND validity = 'Y' AND $where_event"; - return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); + return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); } +sub fetch_actions { -sub fetch_email_addrs { - # Return the list of email addresses for a user or a group - my $id = shift; # user or group id - my $q = "SELECT email FROM $WEBOBS{SQL_TABLE_USERS}" - ." WHERE uid = '$id'" - ." OR uid IN (SELECT uid FROM groups WHERE gid='$id')"; + # Return the list of actions for an event + my $event_name = shift; + my $where_event = get_subscriptions_clause($event_name); + my $q = "SELECT action FROM $WEBOBS{SQL_TABLE_NOTIFICATIONS}" + ." WHERE action != '-' AND validity = 'Y' AND $where_event"; - return fetch_all($WEBOBS{SQL_DB_USERS}, $q); + return fetch_all($WEBOBS{SQL_DB_POSTBOARD}, $q); } +sub fetch_email_addrs { + # Return the list of email addresses for a user or a group + my $id = shift; # user or group id + my $q = "SELECT email FROM $WEBOBS{SQL_TABLE_USERS}" + ." WHERE uid = '$id'" + ." OR uid IN (SELECT uid FROM groups WHERE gid='$id')"; + + return fetch_all($WEBOBS{SQL_DB_USERS}, $q); +} # ---------------------------------------------------------- # read mail contents from a file into a scalar # ---------------------------------------------------------- sub read_file { - my $filename = shift; - my $file; - my $content = ""; - if (not (defined($filename) && open($file, $filename))) { - logit("warning: couldn't read $filename"); - return; - } - local $/ = undef; - $content = <$file>; - close($file) or logit("warning: an error occured while closing $filename"); - return $content; + my $filename = shift; + my $file; + my $content = ""; + if (not (defined($filename) && open($file, $filename))) { + logit("warning: couldn't read $filename"); + return; + } + local $/ = undef; + $content = <$file>; + close($file) or logit("warning: an error occured while closing $filename"); + return $content; } # ---------------------------------------------------------- @@ -513,42 +523,42 @@ sub read_file { # eg: rccond ('submitrc.jidx.rc>=0, 0) returns true (1) # ---------------------------------------------------------- sub rccond { - return 1 if (@_ != 2); - return eval "($_[1] $1 $2)"?1:0 if ($_[0] =~ m/submitrc\..*rc([=>>$LOGNAME")) { - print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); - exit(1); + print(STDERR "Cannot start: unable to open $LOGNAME: $!\n"); + exit(1); } # ---- initialize: internal structures @@ -391,39 +392,39 @@ BEGIN $CFGF = $WEBOBS{CONF_SCHEDULER} if ($CFGF eq '' && -e $WEBOBS{CONF_SCHEDULER}); %SCHED = readCfg($CFGF); if ( scalar(keys(%SCHED)) <= 1 ) { - logit("scheduler can't start: no or invalid configuration file"); - printf("scheduler can't start: no or invalid configuration file\n"); - myexit(1); + logit("scheduler can't start: no or invalid configuration file"); + printf("scheduler can't start: no or invalid configuration file\n"); + myexit(1); } if ( !defined($SCHED{SQL_DB_JOBS}) ) { - logit("scheduler can't start: no JOBS database"); - printf("scheduler can't start: no JOBS database\n"); - myexit(1); + logit("scheduler can't start: no JOBS database"); + printf("scheduler can't start: no JOBS database\n"); + myexit(1); } # ---- UDP non-blocking socket, for incoming users requests # ----------------------------------------------------------------------------- my $SOCK = IO::Socket::INET->new( - 'LocalAddr' => $SCHED{LISTEN_ADDR} || 'localhost', - 'LocalPort' => $SCHED{PORT}, - 'Proto' => 'udp', - 'Blocking' => 0, -); + 'LocalAddr' => $SCHED{LISTEN_ADDR} || 'localhost', + 'LocalPort' => $SCHED{PORT}, + 'Proto' => 'udp', + 'Blocking' => 0, + ); my $sock_desc = sprintf("UDP socket %s:%d", $SCHED{LISTEN_ADDR} || 'localhost', - $SCHED{PORT}); + $SCHED{PORT}); if (!$SOCK) { - my $err = "scheduler[$$] cannot start because of $sock_desc error: $!"; - logit($err); - printf($err); - myexit(1); + my $err = "scheduler[$$] cannot start because of $sock_desc error: $!"; + logit($err); + printf($err); + myexit(1); } # ---- system load averages access+interpretation setups # ----------------------------------------------------------------------------- if (open FILE, "< /proc/cpuinfo") { - $ncpus = scalar grep(/^processor\s+:/,); - close FILE; + $ncpus = scalar grep(/^processor\s+:/,); + close FILE; } our ($avg1,$avg5,$avg15) = 0; # work-vars for sys load averages @@ -431,27 +432,27 @@ BEGIN # ----------------------------------------------------------------------------- system("mkdir -p $SAVELOGPATH"); if ( ! -d "$SAVELOGPATH" ) { - logit("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!"); - printf("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!\n"); - myexit(1); + logit("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!"); + printf("scheduler $$ won't start, couldn't mkdir $SAVELOGPATH: $? $!\n"); + myexit(1); } # --- root of all jobs' logs (STDOUT/STDERR redirections) directories # ----------------------------------------------------------------------------- system("mkdir -p $SCHED{PATH_STD}"); if ( ! -d $SCHED{PATH_STD} ) { - logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!"); - printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!\n"); - myexit(1); + logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!"); + printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_STD}: $? $!\n"); + myexit(1); } # --- root of all jobs' 'resource' (enq=locks) directories # ----------------------------------------------------------------------------- system("mkdir -p $SCHED{PATH_RES}"); if ( ! -d $SCHED{PATH_RES} ) { - logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!"); - printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!\n"); - myexit(1); + logit("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!"); + printf("scheduler $$ won't start, couldn't mkdir $SCHED{PATH_RES}: $? $!\n"); + myexit(1); } system("rm -f $SCHED{PATH_RES}/*"); @@ -507,24 +508,24 @@ BEGIN # ---- make sure that all past runs are marked as ended for reporting purposes # ---- since we have no more knowledge/control over them when (re)starting if (defined($SCHED{CLEANUP_RUNS}) && $SCHED{CLEANUP_RUNS} ne '') { - my ($zrc, $zmsg) = split(/,/, $SCHED{CLEANUP_RUNS}); - $zrc ||= 999; - $zmsg ||= 'zombie'; - my $ztime = time; - my $q = "UPDATE runs SET endts=$ztime,rc=$zrc,rcmsg='$zmsg' WHERE endts=0"; - - my $dbh = db_connect($SCHED{SQL_DB_JOBS}); - if (not $dbh) { - logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); - myexit(1); - } - my $rv = $dbh->do($q); - $rv = 0 if ($rv == 0E0); - logit("cleaned up zombie runs: $rv"); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " - . $dbh->errstr; + my ($zrc, $zmsg) = split(/,/, $SCHED{CLEANUP_RUNS}); + $zrc ||= 999; + $zmsg ||= 'zombie'; + my $ztime = time; + my $q = "UPDATE runs SET endts=$ztime,rc=$zrc,rcmsg='$zmsg' WHERE endts=0"; + + my $dbh = db_connect($SCHED{SQL_DB_JOBS}); + if (not $dbh) { + logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); + myexit(1); + } + my $rv = $dbh->do($q); + $rv = 0 if ($rv == 0E0); + logit("cleaned up zombie runs: $rv"); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " + . $dbh->errstr; } # ---- loop forever handling commands and jobs to be started @@ -532,35 +533,35 @@ BEGIN # SCHEDULING LOOP - # wait (sleep) for next clock tick - # start clock tick processing - # decrement current BEAT count: it will trigger actual job scheduling when reaching 0 - # check the non-blocking UDP socket for clients' commands: - # processes 'commands' and also queues 'job requests' in JOBRQ - # leave (ignore) this tick if in PAUSE mode or not yet reach BEAT (not 0) - # at each BEAT tick (BEAT = 0) - # restore BEAT count - # decrement time in JOBQ for all jobs there, cancel them if needed - # triggers REAPER and ignore this tick if max number of forked kids reached - # ignore this tick if current system load too high (SYSLOAD) - # select candidate jobs for this BEAT tick from JOBRQ and JOBS DataBase - # all JOBRQ jobs - # + DataBase jobs whose last 'run' is older than their defined RUNINTERVAL. - # applying LMISS or EMISS biases to slow down 'candidate not forked loop' - # loop thru all candidate jobs: - # build job's execution command (kidcmd) as its XEQ1 + XEQ2 + XEQ3 - # insert into the RUNQ a candidate job that is allowed to be forked: - # having its defined MAXSYSLOAD less than the current system load 5' average - # may ENQ its defined resource - # candidates not eligible to RUNQ and coming from JOBRQ will 'return' to JOBRQ - # fork a kid to execute job - # kid's code inherits from parent's variables at time of fork - # kid's code triggers a system 'exec kidcmd' - # links kid's pid to runQ's id (both ways) for the job just started - # triggers REAPER that processes ended kids if any (non-blocking waitpid for kids) - # cleanup kids'/job's references - # update DataBase with 'last run' information for job - # loop after adjusting next wait time (loop execution drift) +# wait (sleep) for next clock tick +# start clock tick processing +# decrement current BEAT count: it will trigger actual job scheduling when reaching 0 +# check the non-blocking UDP socket for clients' commands: +# processes 'commands' and also queues 'job requests' in JOBRQ +# leave (ignore) this tick if in PAUSE mode or not yet reach BEAT (not 0) +# at each BEAT tick (BEAT = 0) +# restore BEAT count +# decrement time in JOBQ for all jobs there, cancel them if needed +# triggers REAPER and ignore this tick if max number of forked kids reached +# ignore this tick if current system load too high (SYSLOAD) +# select candidate jobs for this BEAT tick from JOBRQ and JOBS DataBase +# all JOBRQ jobs +# + DataBase jobs whose last 'run' is older than their defined RUNINTERVAL. +# applying LMISS or EMISS biases to slow down 'candidate not forked loop' +# loop thru all candidate jobs: +# build job's execution command (kidcmd) as its XEQ1 + XEQ2 + XEQ3 +# insert into the RUNQ a candidate job that is allowed to be forked: +# having its defined MAXSYSLOAD less than the current system load 5' average +# may ENQ its defined resource +# candidates not eligible to RUNQ and coming from JOBRQ will 'return' to JOBRQ +# fork a kid to execute job +# kid's code inherits from parent's variables at time of fork +# kid's code triggers a system 'exec kidcmd' +# links kid's pid to runQ's id (both ways) for the job just started +# triggers REAPER that processes ended kids if any (non-blocking waitpid for kids) +# cleanup kids'/job's references +# update DataBase with 'last run' information for job +# loop after adjusting next wait time (loop execution drift) # Alert of the start of the scheduler (the same way we alert of its shutdown) notifyit("scheduler.critical|$$|scheduler is starting"); @@ -568,189 +569,193 @@ BEGIN our $BEAT = $SCHED{BEAT}; while (1) { - my $psdmsg = sprintf ("%u %s wait %d (d=%f,beat=%d)", $$,$PAUSED?" paused":"",int($adjutick),$adjutick-int($adjutick),$BEAT); - logit($psdmsg) if ($verbose2); - usleep(int($adjutick)); - - my $t0 = [gettimeofday]; - $BEAT-- if (!$PAUSED); - - UDPS(); - if (!$PAUSED && !$BEAT) { - $BEAT = $SCHED{BEAT}; - TTLJOBRQ(); - if (REAPER() == $SCHED{MAX_CHILDREN}) { - notifyit("scheduler.critical|$$|Maximum number of started processes reached"); - next; - }; - if (SYSLOAD()) { - notifyit("scheduler.critical|$$|Loadavg thresholds reached"); - next; - } - CANDIDATES(); - if ($verbose2) { - logit(scalar(keys(%CANDIDATES))." candidate(s): "); - for my $c (keys(%CANDIDATES)) { - logit(" $CANDIDATES{$c}{JID}: $CANDIDATES{$c}{XEQ1} $CANDIDATES{$c}{XEQ2} $CANDIDATES{$c}{XEQ3} "); - } - } - for my $rid (keys(%CANDIDATES)) { - # build the actual command to be executed from components XEQx - - # no leading/trailing blanks in EACH components THEN derefrence $WEBOBS{} variables - $CANDIDATES{$rid}{XEQ1} =~ s/^\s+|\s+$//g; - $CANDIDATES{$rid}{XEQ2} =~ s/^\s+|\s+$//g; - $CANDIDATES{$rid}{XEQ3} =~ s/^\s+|\s+$//g; - - my $kidcmd = "$CANDIDATES{$rid}{XEQ1} $CANDIDATES{$rid}{XEQ2} $CANDIDATES{$rid}{XEQ3}"; - $kidcmd =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; - - # check if eligible for RUNQ ? - if ($CANDIDATES{$rid}{MAXSYSLOAD} <= $avg5) { - logit("jid($CANDIDATES{$rid}{JID}) candidate but CpuLoad too high"); - notifyit("scheduler.warning|$$|Job [ $CANDIDATES{$rid}{JID} ] candidate but CpuLoad too high"); - if ($SCHED{LMISS_BIAS}>0) { - $LMISS{$CANDIDATES{$rid}{JID}} = time; - } - next; - } - if (ENQ($CANDIDATES{$rid}{RES},$CANDIDATES{$rid}{JID}) == 1) { - logit("jid($CANDIDATES{$rid}{JID}) candidate but Resource busy"); - if ($SCHED{EMISS_BIAS}>0) { - $EMISS{$CANDIDATES{$rid}{JID}} = time; - } - next; - } - - # candidate is eligible, remove it from JOBRQ if it came in that way - if ($CANDIDATES{$rid}{ORG} eq "R") { - logit("rid $rid jid($CANDIDATES{$rid}{JID}) candidate, removed from JOBRQ") if ($verbose); - delete($JOBRQ{$rid}) - } - - # create the RUNQ structure for this job - my $Qid = $rid; - $RUNQ{$Qid}{kidcmd} = $kidcmd; - $RUNQ{$Qid}{kid} = 0; - $RUNQ{$Qid}{res} = $CANDIDATES{$rid}{RES} ; - $RUNQ{$Qid}{jid} = $CANDIDATES{$rid}{JID}; - $RUNQ{$Qid}{uid} = $CANDIDATES{$rid}{UID}; - $RUNQ{$Qid}{ORG} = $CANDIDATES{$rid}{ORG}; - - # take care of stdout/err redirections and targets - my $redir = '>'; - (my $RTNE_ = $CANDIDATES{$rid}{XEQ2}) =~ s/\s+/_/g; - $CANDIDATES{$rid}{LOGPATH} ||= $RTNE_ ; - if ($CANDIDATES{$rid}{LOGPATH} =~ m/(^>{1,2})(.*)$/) { - $redir = $1; - $CANDIDATES{$rid}{LOGPATH} = $2; - } - - $RUNQ{$Qid}{started} = time; - $CANDIDATES{$rid}{LOGPATH} =~ s/\{TS\}/$RUNQ{$Qid}{started}/g ; - $CANDIDATES{$rid}{LOGPATH} =~ s/\{RTNE\}/$RTNE_/g ; - my ($logfn, $logfd) = fileparse($CANDIDATES{$rid}{LOGPATH}); - $logfd =~ s|/$||; # Remove trailing slash from the dir - $RUNQ{$Qid}{logfd} = $logfd; - $RUNQ{$Qid}{logfn} = $logfn; - - # from now on we don't need the $CANDIDATES{$rid} anymore - delete($CANDIDATES{$rid}); - make_path("$SCHED{PATH_STD}/$logfd"); - - $RUNQ{$Qid}{kidcmd} =~ s/'/''/g; - DBUPDATE("UPDATE jobs set laststrts=$RUNQ{$Qid}{started} WHERE jid='$RUNQ{$Qid}{jid}'"); - DBUPDATE("INSERT INTO runs (jid,org,startts,cmd,endts)" - ." VALUES ('$RUNQ{$Qid}{jid}', '$RUNQ{$Qid}{ORG}', $RUNQ{$Qid}{started}, '$RUNQ{$Qid}{kidcmd}', 0)"); - DBUPDATE("DELETE FROM runs WHERE startts<=$RUNQ{$Qid}{started}-($SCHED{DAYS_IN_RUN}*86400) AND endts <> 0 "); - $JSTARTED++; - - my $kid = fork(); - if (!defined($kid)) { - logit("$$ couldn't fork [ $kidcmd ] !"); - notifyit("scheduler.critical|$$|couldn't fork [ $kidcmd ]"); - next; - } - - if ($kid == 0) { - # Child code - - # Create a new process group for the current process - setpgrp; - - my $log_basename = "$SCHED{PATH_STD}/$logfd/$logfn"; - my $merge_logs; - my $output_name; - my $run_path_ext; - my $stdout_ext; - - if ($SCHED{'MERGE_JOB_LOGS'} - and $SCHED{'MERGE_JOB_LOGS'} =~ /^\s*(?:y(?:es)?|1)\s*$/i) { - $merge_logs = 1; - $output_name = "STDOUT+STDERR"; - $run_path_ext = "log"; - $stdout_ext = "log"; - } else { - $merge_logs = 0; - $output_name = "STDOUT"; - $run_path_ext = "std{out,err}"; - $stdout_ext = "stdout"; - } - - open(STDOUT, $redir, "$log_basename.$stdout_ext") - or die "Could not redirect STDOUT: $!"; - printf(STDOUT "\n*** %s WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", $output_name, - strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); - - if ($merge_logs) { - # stdout and stderr should be redirected to the same file - open STDERR, ">&", \*STDOUT - or die "Could not redirect STDERR to STDOUT: $!";; - } else { - # Default behaviour: stdout and stderr should be redirected to different files - open STDERR, $redir, "$log_basename.stderr" - or die "Could not redirect STDERR: $!";; - printf(STDERR "\n*** STDERR WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", - strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); - } - DBUPDATE("UPDATE runs SET kid=$$,stdpath='$redir $logfd/$logfn.$run_path_ext'" - ." WHERE jid='$RUNQ{$Qid}{jid}' AND startts=$RUNQ{$Qid}{started}"); - - # alea jacta est ... one way ticket to the job ! - # exec may return on -1 (wrong attrs): force kid exit (so that reaper will see it) - exec $kidcmd - or logit("$$ couldn't exec [ $kidcmd ]: $? $!"); - - # Exit if exec failed - exit(-1); - - } # end of if ($kid == 0) - - # Continuing with parent's code - $RUNQ{$Qid}{kid} = $kid; # link runQ element to kid pid - $kids{$kid} = $Qid; # link kid pid list to runQ - if ($verbose) { - logit("forked $kid [ $kidcmd ] Q:$Qid,R(Q):$RUNQ{$Qid}{kid},K:$kids{$kid}"); - logit("logs $kid: $redir $logfd/$logfn.std{out,err}"); - } - next; - } # end of for my $rid (keys(%CANDIDATES)) - - REAPER(); - if ($verbose2) { - logit("$$ runQ: "); - for my $j (keys(%RUNQ)) { - logit(" runQ $j : jid($RUNQ{$j}{jid}) pid=$RUNQ{$j}{kid} started=$RUNQ{$j}{started} cmd=$RUNQ{$j}{kidcmd}"); - } - } - - my $tvi = tv_interval($t0); - if (($adjutick = $utick - $tvi) <= 0) { - logit("$$ drift >= $SCHED{TICK} !!!"); - $adjutick = 0; - } - $ELT += $tvi; - } + my $psdmsg = sprintf ("%u %s wait %d (d=%f,beat=%d)", $$,$PAUSED?" paused":"",int($adjutick),$adjutick-int($adjutick),$BEAT); + logit($psdmsg) if ($verbose2); + usleep(int($adjutick)); + + my $t0 = [gettimeofday]; + $BEAT-- if (!$PAUSED); + + UDPS(); + if (!$PAUSED && !$BEAT) { + $BEAT = $SCHED{BEAT}; + TTLJOBRQ(); + if (REAPER() == $SCHED{MAX_CHILDREN}) { + notifyit("scheduler.critical|$$|Maximum number of started processes reached"); + next; + }; + if (SYSLOAD()) { + notifyit("scheduler.critical|$$|Loadavg thresholds reached"); + next; + } + CANDIDATES(); + if ($verbose2) { + logit(scalar(keys(%CANDIDATES))." candidate(s): "); + for my $c (keys(%CANDIDATES)) { + logit(" $CANDIDATES{$c}{JID}: $CANDIDATES{$c}{XEQ1} $CANDIDATES{$c}{XEQ2} $CANDIDATES{$c}{XEQ3} "); + } + } + for my $rid (keys(%CANDIDATES)) { + + # build the actual command to be executed from components XEQx + +# no leading/trailing blanks in EACH components THEN derefrence $WEBOBS{} variables + $CANDIDATES{$rid}{XEQ1} =~ s/^\s+|\s+$//g; + $CANDIDATES{$rid}{XEQ2} =~ s/^\s+|\s+$//g; + $CANDIDATES{$rid}{XEQ3} =~ s/^\s+|\s+$//g; + + my $kidcmd = "$CANDIDATES{$rid}{XEQ1} $CANDIDATES{$rid}{XEQ2} $CANDIDATES{$rid}{XEQ3}"; + $kidcmd =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g; + + # check if eligible for RUNQ ? + if ($CANDIDATES{$rid}{MAXSYSLOAD} <= $avg5) { + logit("jid($CANDIDATES{$rid}{JID}) candidate but CpuLoad too high"); + notifyit("scheduler.warning|$$|Job [ $CANDIDATES{$rid}{JID} ] candidate but CpuLoad too high"); + if ($SCHED{LMISS_BIAS}>0) { + $LMISS{$CANDIDATES{$rid}{JID}} = time; + } + next; + } + if (ENQ($CANDIDATES{$rid}{RES},$CANDIDATES{$rid}{JID}) == 1) { + logit("jid($CANDIDATES{$rid}{JID}) candidate but Resource busy"); + if ($SCHED{EMISS_BIAS}>0) { + $EMISS{$CANDIDATES{$rid}{JID}} = time; + } + next; + } + + # candidate is eligible, remove it from JOBRQ if it came in that way + if ($CANDIDATES{$rid}{ORG} eq "R") { + logit("rid $rid jid($CANDIDATES{$rid}{JID}) candidate, removed from JOBRQ") if ($verbose); + delete($JOBRQ{$rid}) + } + + # create the RUNQ structure for this job + my $Qid = $rid; + $RUNQ{$Qid}{kidcmd} = $kidcmd; + $RUNQ{$Qid}{kid} = 0; + $RUNQ{$Qid}{res} = $CANDIDATES{$rid}{RES} ; + $RUNQ{$Qid}{jid} = $CANDIDATES{$rid}{JID}; + $RUNQ{$Qid}{uid} = $CANDIDATES{$rid}{UID}; + $RUNQ{$Qid}{ORG} = $CANDIDATES{$rid}{ORG}; + + # take care of stdout/err redirections and targets + my $redir = '>'; + (my $RTNE_ = $CANDIDATES{$rid}{XEQ2}) =~ s/\s+/_/g; + $CANDIDATES{$rid}{LOGPATH} ||= $RTNE_ ; + if ($CANDIDATES{$rid}{LOGPATH} =~ m/(^>{1,2})(.*)$/) { + $redir = $1; + $CANDIDATES{$rid}{LOGPATH} = $2; + } + + $RUNQ{$Qid}{started} = time; + $CANDIDATES{$rid}{LOGPATH} =~ s/\{TS\}/$RUNQ{$Qid}{started}/g ; + $CANDIDATES{$rid}{LOGPATH} =~ s/\{RTNE\}/$RTNE_/g ; + my ($logfn, $logfd) = fileparse($CANDIDATES{$rid}{LOGPATH}); + $logfd =~ s|/$||; # Remove trailing slash from the dir + $RUNQ{$Qid}{logfd} = $logfd; + $RUNQ{$Qid}{logfn} = $logfn; + + # from now on we don't need the $CANDIDATES{$rid} anymore + delete($CANDIDATES{$rid}); + make_path("$SCHED{PATH_STD}/$logfd"); + + $RUNQ{$Qid}{kidcmd} =~ s/'/''/g; + DBUPDATE("UPDATE jobs set laststrts=$RUNQ{$Qid}{started} WHERE jid='$RUNQ{$Qid}{jid}'"); + DBUPDATE("INSERT INTO runs (jid,org,startts,cmd,endts)" + ." VALUES ('$RUNQ{$Qid}{jid}', '$RUNQ{$Qid}{ORG}', $RUNQ{$Qid}{started}, '$RUNQ{$Qid}{kidcmd}', 0)"); + DBUPDATE("DELETE FROM runs WHERE startts<=$RUNQ{$Qid}{started}-($SCHED{DAYS_IN_RUN}*86400) AND endts <> 0 "); + $JSTARTED++; + + my $kid = fork(); + if (!defined($kid)) { + logit("$$ couldn't fork [ $kidcmd ] !"); + notifyit("scheduler.critical|$$|couldn't fork [ $kidcmd ]"); + next; + } + + if ($kid == 0) { + + # Child code + + # Create a new process group for the current process + setpgrp; + + my $log_basename = "$SCHED{PATH_STD}/$logfd/$logfn"; + my $merge_logs; + my $output_name; + my $run_path_ext; + my $stdout_ext; + + if ($SCHED{'MERGE_JOB_LOGS'} + and $SCHED{'MERGE_JOB_LOGS'} =~ /^\s*(?:y(?:es)?|1)\s*$/i) { + $merge_logs = 1; + $output_name = "STDOUT+STDERR"; + $run_path_ext = "log"; + $stdout_ext = "log"; + } else { + $merge_logs = 0; + $output_name = "STDOUT"; + $run_path_ext = "std{out,err}"; + $stdout_ext = "stdout"; + } + + open(STDOUT, $redir, "$log_basename.$stdout_ext") + or die "Could not redirect STDOUT: $!"; + printf(STDOUT "\n*** %s WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", $output_name, + strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); + + if ($merge_logs) { + + # stdout and stderr should be redirected to the same file + open STDERR, ">&", \*STDOUT + or die "Could not redirect STDERR to STDOUT: $!";; + } else { + + # Default behaviour: stdout and stderr should be redirected to different files + open STDERR, $redir, "$log_basename.stderr" + or die "Could not redirect STDERR: $!";; + printf(STDERR "\n*** STDERR WEBOBS JOB *** STARTED %s [ %s ] ***\n\n", + strftime("%Y-%m-%d %H:%M:%S", localtime($RUNQ{$Qid}{started})), $kidcmd); + } + DBUPDATE("UPDATE runs SET kid=$$,stdpath='$redir $logfd/$logfn.$run_path_ext'" + ." WHERE jid='$RUNQ{$Qid}{jid}' AND startts=$RUNQ{$Qid}{started}"); + +# alea jacta est ... one way ticket to the job ! +# exec may return on -1 (wrong attrs): force kid exit (so that reaper will see it) + exec $kidcmd + or logit("$$ couldn't exec [ $kidcmd ]: $? $!"); + + # Exit if exec failed + exit(-1); + + } # end of if ($kid == 0) + + # Continuing with parent's code + $RUNQ{$Qid}{kid} = $kid; # link runQ element to kid pid + $kids{$kid} = $Qid; # link kid pid list to runQ + if ($verbose) { + logit("forked $kid [ $kidcmd ] Q:$Qid,R(Q):$RUNQ{$Qid}{kid},K:$kids{$kid}"); + logit("logs $kid: $redir $logfd/$logfn.std{out,err}"); + } + next; + } # end of for my $rid (keys(%CANDIDATES)) + + REAPER(); + if ($verbose2) { + logit("$$ runQ: "); + for my $j (keys(%RUNQ)) { + logit(" runQ $j : jid($RUNQ{$j}{jid}) pid=$RUNQ{$j}{kid} started=$RUNQ{$j}{started} cmd=$RUNQ{$j}{kidcmd}"); + } + } + + my $tvi = tv_interval($t0); + if (($adjutick = $utick - $tvi) <= 0) { + logit("$$ drift >= $SCHED{TICK} !!!"); + $adjutick = 0; + } + $ELT += $tvi; + } } # you should never get there ! @@ -760,169 +765,177 @@ BEGIN # non-blocking wait for children exit # ----------------------------------- sub REAPER { - my @DBupdates; - - while (($dcd = waitpid(-1, &WNOHANG)) > 0) { - my $dcdRC = ${^CHILD_ERROR_NATIVE}; # default, see below each case - my $tend = time; - my $dcdmsg = ''; - - if ($? == -1) { - $dcdmsg = sprintf (" failed to execute: $!"); - } elsif ($? & 127) { - $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); - } else { - $dcdRC = $? >> 8; - $dcdmsg = sprintf ("*%d", $dcdRC); - } - - my $dcdQid = $kids{$dcd}; - if ($dcdRC != 0) { - notifyit("scheduler.critical|$$|Job $RUNQ{$dcdQid}{jid} started at $RUNQ{$dcdQid}{started} returned non-null code $dcdRC.\nError message was : $dcdmsg"); - } - DBUPDATE("UPDATE runs SET endts=$tend,rc=$dcdRC,rcmsg=\"$dcdmsg\" WHERE jid=\"$RUNQ{$dcdQid}{jid}\" AND startts=$RUNQ{$dcdQid}{started}"); - - my $notifytxt = "submitrc.$RUNQ{$dcdQid}{jid}|$$|" - ."org=$RUNQ{$dcdQid}{ORG} rc=$dcdRC cmd=[ $RUNQ{$dcdQid}{kidcmd} ] log=[ $RUNQ{$dcdQid}{logfd}/$RUNQ{$dcdQid}{logfn}.std{out,err} ] "; - if (defined($RUNQ{$dcdQid}{uid}) && $RUNQ{$dcdQid}{uid} ne '') { - $notifytxt .= "uid=$RUNQ{$dcdQid}{uid}"; - } - WebObs::Config::notify($notifytxt); - - $JENDED++; - logit("reaper: kid($dcd), runQ($dcdQid), jid($RUNQ{$dcdQid}{jid})") if ($verbose); - DEQ($RUNQ{$dcdQid}{res},$RUNQ{$dcdQid}{jid}); - delete $RUNQ{$dcdQid}; - delete $kids{$dcd}; - } - return scalar(keys(%kids)); + my @DBupdates; + + while (($dcd = waitpid(-1, &WNOHANG)) > 0) { + my $dcdRC = ${^CHILD_ERROR_NATIVE}; # default, see below each case + my $tend = time; + my $dcdmsg = ''; + + if ($? == -1) { + $dcdmsg = sprintf (" failed to execute: $!"); + } elsif ($? & 127) { + $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); + } else { + $dcdRC = $? >> 8; + $dcdmsg = sprintf ("*%d", $dcdRC); + } + + my $dcdQid = $kids{$dcd}; + if ($dcdRC != 0) { + notifyit("scheduler.critical|$$|Job $RUNQ{$dcdQid}{jid} started at $RUNQ{$dcdQid}{started} returned non-null code $dcdRC.\nError message was : $dcdmsg"); + } + DBUPDATE("UPDATE runs SET endts=$tend,rc=$dcdRC,rcmsg=\"$dcdmsg\" WHERE jid=\"$RUNQ{$dcdQid}{jid}\" AND startts=$RUNQ{$dcdQid}{started}"); + + my $notifytxt = "submitrc.$RUNQ{$dcdQid}{jid}|$$|" + ."org=$RUNQ{$dcdQid}{ORG} rc=$dcdRC cmd=[ $RUNQ{$dcdQid}{kidcmd} ] log=[ $RUNQ{$dcdQid}{logfd}/$RUNQ{$dcdQid}{logfn}.std{out,err} ] "; + if (defined($RUNQ{$dcdQid}{uid}) && $RUNQ{$dcdQid}{uid} ne '') { + $notifytxt .= "uid=$RUNQ{$dcdQid}{uid}"; + } + WebObs::Config::notify($notifytxt); + + $JENDED++; + logit("reaper: kid($dcd), runQ($dcdQid), jid($RUNQ{$dcdQid}{jid})") if ($verbose); + DEQ($RUNQ{$dcdQid}{res},$RUNQ{$dcdQid}{jid}); + delete $RUNQ{$dcdQid}; + delete $kids{$dcd}; + } + return scalar(keys(%kids)); } # ------------------------------ # Exit scheduler on STOP command # ------------------------------ sub exit_after_jobs { - $PAUSED = 2; # Do not schedule new jobs - logit("scheduler[$$]: stop requested, waiting for kid(s) to exit..."); - notifyit("scheduler.critical|$$|scheduler is shutting down as requested."); - while (REAPER() != 0) { sleep(1); UDPS() }; - logit("kid(s) stopped. Exiting."); - myexit(0); + $PAUSED = 2; # Do not schedule new jobs + logit("scheduler[$$]: stop requested, waiting for kid(s) to exit..."); + notifyit("scheduler.critical|$$|scheduler is shutting down as requested."); + while (REAPER() != 0) { sleep(1); UDPS() }; + logit("kid(s) stopped. Exiting."); + myexit(0); } # ------------------------ # Exit scheduler on signal # ------------------------ sub exit_on_signal { - my $signame = shift || ''; - my $exit_code = shift // 1; - - logit("caught a SIG$signame"); - notifyit("scheduler.critical|$$|scheduler stopping on signal $signame"); - my $ets = REAPER(); # any extra-terrestrial survivors ? - logit("$ets kid(s) are still alive.") if ($ets>0); - print("exiting on signal SIG$signame.") if (-t STDOUT); - myexit($exit_code); + my $signame = shift || ''; + my $exit_code = shift // 1; + + logit("caught a SIG$signame"); + notifyit("scheduler.critical|$$|scheduler stopping on signal $signame"); + my $ets = REAPER(); # any extra-terrestrial survivors ? + logit("$ets kid(s) are still alive.") if ($ets>0); + print("exiting on signal SIG$signame.") if (-t STDOUT); + myexit($exit_code); } # ---------------------------------------------------------- # SYSLOAD true if system's loadavg > user-defined thresholds # ---------------------------------------------------------- sub SYSLOAD { - # ---- grab fresh system's loadavg figures - if (open FILE, "< /proc/loadavg") { - ($avg1, $avg5, $avg15, undef, undef) = split / /, ; - close FILE; - # load averages in users's definitions are relative to 1 cpu; - # fix /proc/loadavg values to match actual number of cpus - $avg1 /= $ncpus; $avg5 /= $ncpus; $avg15 /= $ncpus; - # ---- system's loadavg vs user thresholds - if ($avg1>$SCHED{LOADAVG1_THRESHOLD} || $avg5>$SCHED{LOADAVG5_THRESHOLD} || $avg15>$SCHED{LOADAVG15_THRESHOLD}) { - #logit(" $$ system load > threshold: $avg1/$SCHED{LOADAVG1_THRESHOLD} $avg5/$SCHED{LOADAVG5_THRESHOLD} $avg15/$SCHED{LOADAVG15_THRESHOLD}") if ($verbose); - logit(" $$ system load > threshold") if ($verbose); - return(1); - } - } else { - logit("$$ cpu loadavg not refreshed: $!"); - } - return(0); + + # ---- grab fresh system's loadavg figures + if (open FILE, "< /proc/loadavg") { + ($avg1, $avg5, $avg15, undef, undef) = split / /, ; + close FILE; + + # load averages in users's definitions are relative to 1 cpu; + # fix /proc/loadavg values to match actual number of cpus + $avg1 /= $ncpus; $avg5 /= $ncpus; $avg15 /= $ncpus; + + # ---- system's loadavg vs user thresholds + if ($avg1>$SCHED{LOADAVG1_THRESHOLD} || $avg5>$SCHED{LOADAVG5_THRESHOLD} || $avg15>$SCHED{LOADAVG15_THRESHOLD}) { + +#logit(" $$ system load > threshold: $avg1/$SCHED{LOADAVG1_THRESHOLD} $avg5/$SCHED{LOADAVG5_THRESHOLD} $avg15/$SCHED{LOADAVG15_THRESHOLD}") if ($verbose); + logit(" $$ system load > threshold") if ($verbose); + return(1); + } + } else { + logit("$$ cpu loadavg not refreshed: $!"); + } + return(0); } # ---------------------------------------------------------- # CANDIDATES select all jobs that could be run now, from DB and Q # ---------------------------------------------------------- sub CANDIDATES { - %CANDIDATES = %{DBSELECT()}; - for my $key (keys %CANDIDATES) { - usleep 1; - my $art = time; - $CANDIDATES{$art} = delete $CANDIDATES{$key}; - } - - for my $jtk (keys(%JOBRQ)) { - my $jrq = $JOBRQ{$jtk}{REQ}; - $jrq =~ s/^\s+|\s+$//g; - if ( $jrq =~ m/JID=\s*(.+)\s*/i ) { - # a %CANDIDATES entry from a submit "jid=" - my $jrqid = $1; - my %tmp = %{DBSELECT($jrqid)}; - if (defined($tmp{$jrqid})) { - $CANDIDATES{$jtk} = delete $tmp{$jrqid}; - } else { - logit("$$ deleting submitted job jid($jrqid): not defined"); - delete($JOBRQ{$jtk}); - } - } else { - # a %CANDIDATES entry from a submit "XEQ1:gnagna,XEQ2:blabla,..." - if (JDPARSE($jtk) == 0) { - logit("$$ deleting submitted job jid($JOBRQ{$jtk}{JID}): parse failed [ $jrq ]"); - delete($JOBRQ{$jtk}); - } - } - } - # ignore JIDs for which exists a 'pending delay' due to a previous threshold OR enq condition - for my $key (keys %CANDIDATES) { - if (defined($LMISS{$CANDIDATES{$key}{JID}})) { - if ($LMISS{$CANDIDATES{$key}{JID}} + $SCHED{LMISS_BIAS} >= time) { - delete $CANDIDATES{$key}; - } else { - delete $LMISS{$CANDIDATES{$key}}; - } - } - if (defined($EMISS{$CANDIDATES{$key}{JID}})) { - if ($EMISS{$CANDIDATES{$key}{JID}} + $SCHED{EMISS_BIAS} >= time) { - delete $CANDIDATES{$key}; - } else { - delete $EMISS{$CANDIDATES{$key}}; - } - } - } - return scalar(keys(%CANDIDATES)); + %CANDIDATES = %{DBSELECT()}; + for my $key (keys %CANDIDATES) { + usleep 1; + my $art = time; + $CANDIDATES{$art} = delete $CANDIDATES{$key}; + } + + for my $jtk (keys(%JOBRQ)) { + my $jrq = $JOBRQ{$jtk}{REQ}; + $jrq =~ s/^\s+|\s+$//g; + if ( $jrq =~ m/JID=\s*(.+)\s*/i ) { + + # a %CANDIDATES entry from a submit "jid=" + my $jrqid = $1; + my %tmp = %{DBSELECT($jrqid)}; + if (defined($tmp{$jrqid})) { + $CANDIDATES{$jtk} = delete $tmp{$jrqid}; + } else { + logit("$$ deleting submitted job jid($jrqid): not defined"); + delete($JOBRQ{$jtk}); + } + } else { + + # a %CANDIDATES entry from a submit "XEQ1:gnagna,XEQ2:blabla,..." + if (JDPARSE($jtk) == 0) { + logit("$$ deleting submitted job jid($JOBRQ{$jtk}{JID}): parse failed [ $jrq ]"); + delete($JOBRQ{$jtk}); + } + } + } + +# ignore JIDs for which exists a 'pending delay' due to a previous threshold OR enq condition + for my $key (keys %CANDIDATES) { + if (defined($LMISS{$CANDIDATES{$key}{JID}})) { + if ($LMISS{$CANDIDATES{$key}{JID}} + $SCHED{LMISS_BIAS} >= time) { + delete $CANDIDATES{$key}; + } else { + delete $LMISS{$CANDIDATES{$key}}; + } + } + if (defined($EMISS{$CANDIDATES{$key}{JID}})) { + if ($EMISS{$CANDIDATES{$key}{JID}} + $SCHED{EMISS_BIAS} >= time) { + delete $CANDIDATES{$key}; + } else { + delete $EMISS{$CANDIDATES{$key}}; + } + } + } + return scalar(keys(%CANDIDATES)); } + # ---------------------------------------------------------- # helper: parse job definitions from Q (ie. user input) # its JID (dynamic, negative) has been assigned when command was received # parses user's string "XEQ1:'launch text',XEQ2:'routine text',XEQ3:'a1 a2',...." # ---------------------------------------------------------- sub JDPARSE { - my $jrq = $JOBRQ{$_[0]}{REQ}; - my @req = split(/,/,$jrq); - my %KW = map { split(/:/,$_,2) } @req; - $KW{XEQ1} ||= ''; - $KW{XEQ2} ||= ''; - $KW{XEQ3} ||= ''; - $KW{MAXINSTANCES} ||= 0; - $KW{MAXSYSLOAD} ||= 0.8; - $KW{LOGPATH} ||= 'undef'; - $KW{RES} ||= ''; - $KW{UID} ||= ''; - $KW{ORG} = 'R'; - if ("$KW{XEQ1}$KW{XEQ2}$KW{XEQ3}" ne "") { - $CANDIDATES{$_[0]} = \%KW; - $CANDIDATES{$_[0]}{JID} = $JOBRQ{$_[0]}{JID}; - return 1; - } - return 0; + my $jrq = $JOBRQ{$_[0]}{REQ}; + my @req = split(/,/,$jrq); + my %KW = map { split(/:/,$_,2) } @req; + $KW{XEQ1} ||= ''; + $KW{XEQ2} ||= ''; + $KW{XEQ3} ||= ''; + $KW{MAXINSTANCES} ||= 0; + $KW{MAXSYSLOAD} ||= 0.8; + $KW{LOGPATH} ||= 'undef'; + $KW{RES} ||= ''; + $KW{UID} ||= ''; + $KW{ORG} = 'R'; + if ("$KW{XEQ1}$KW{XEQ2}$KW{XEQ3}" ne "") { + $CANDIDATES{$_[0]} = \%KW; + $CANDIDATES{$_[0]}{JID} = $JOBRQ{$_[0]}{JID}; + return 1; + } + return 0; } # ---------------------------------------------------------- @@ -930,16 +943,16 @@ sub JDPARSE { # and cancels (removes) those jobs whose ttl drops below 0 # ---------------------------------------------------------- sub TTLJOBRQ { - for my $j (keys(%JOBRQ)) { - $JOBRQ{$j}{TTL} -= $SCHED{BEAT}*($utick/1000000); - if ($JOBRQ{$j}{TTL} <= 0) { - logit("cancelling TTL-expired waiting job jid($JOBRQ{$j}{JID}) [ $JOBRQ{$j}{REQ} ]"); - delete($JOBRQ{$j}); - delete($LMISS{$JOBRQ{$j}{JID}}) if (defined($LMISS{$JOBRQ{$j}{JID}})); - delete($EMISS{$JOBRQ{$j}{JID}}) if (defined($EMISS{$JOBRQ{$j}{JID}})); - } - } - return; + for my $j (keys(%JOBRQ)) { + $JOBRQ{$j}{TTL} -= $SCHED{BEAT}*($utick/1000000); + if ($JOBRQ{$j}{TTL} <= 0) { + logit("cancelling TTL-expired waiting job jid($JOBRQ{$j}{JID}) [ $JOBRQ{$j}{REQ} ]"); + delete($JOBRQ{$j}); + delete($LMISS{$JOBRQ{$j}{JID}}) if (defined($LMISS{$JOBRQ{$j}{JID}})); + delete($EMISS{$JOBRQ{$j}{JID}}) if (defined($EMISS{$JOBRQ{$j}{JID}})); + } + } + return; } # ---------------------------------------------------------- @@ -950,12 +963,12 @@ sub TTLJOBRQ { # || die "Error connecting to $dbname: $DBI::errstr"; # ---------------------------------------------------------- sub db_connect { - my $dbname = shift; - return DBI->connect("dbi:SQLite:$dbname", "", "", { - 'AutoCommit' => 1, - 'PrintError' => 1, - 'RaiseError' => 1, - }) + my $dbname = shift; + return DBI->connect("dbi:SQLite:$dbname", "", "", { + 'AutoCommit' => 1, + 'PrintError' => 1, + 'RaiseError' => 1, + }) } # ---------------------------------------------------------- @@ -964,56 +977,58 @@ sub db_connect { # if its job's ID (JID) is passed as argument # ---------------------------------------------------------- sub DBSELECT { - my $job_id = shift; - my $origin; - my $wclause; - - if ($job_id) { - $origin = "R"; - $wclause = "JID = '$job_id' "; - } else { - $origin = 'S'; - #FWIW: +BEAT prevent accumulating shifts; cast(LASTSTRTS as int) would also act as floor(LASTSTRTS) - $wclause = "strftime('%s', 'now')-LASTSTRTS+$BEAT >= RUNINTERVAL AND VALIDITY = 'Y' "; - } - - my $dbh = db_connect($SCHED{SQL_DB_JOBS}); - if (not $dbh) { - logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); - myexit(1); - } - - my $q = qq(SELECT JID,"$origin" as ORG,'' as RQ,RES,XEQ1,XEQ2,XEQ3,MAXSYSLOAD,LOGPATH) - .qq( FROM JOBS WHERE $wclause); - # Return reference for future %CANDIDATES = %{$rs}; - my $ref = $dbh->selectall_hashref($q, 'JID'); - - $dbh->disconnect() - or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " - . $dbh->errstr; - return $ref; + my $job_id = shift; + my $origin; + my $wclause; + + if ($job_id) { + $origin = "R"; + $wclause = "JID = '$job_id' "; + } else { + $origin = 'S'; + +#FWIW: +BEAT prevent accumulating shifts; cast(LASTSTRTS as int) would also act as floor(LASTSTRTS) + $wclause = "strftime('%s', 'now')-LASTSTRTS+$BEAT >= RUNINTERVAL AND VALIDITY = 'Y' "; + } + + my $dbh = db_connect($SCHED{SQL_DB_JOBS}); + if (not $dbh) { + logit("Error connecting to $SCHED{SQL_DB_JOBS}: $DBI::errstr"); + myexit(1); + } + + my $q = qq(SELECT JID,"$origin" as ORG,'' as RQ,RES,XEQ1,XEQ2,XEQ3,MAXSYSLOAD,LOGPATH) + .qq( FROM JOBS WHERE $wclause); + + # Return reference for future %CANDIDATES = %{$rs}; + my $ref = $dbh->selectall_hashref($q, 'JID'); + + $dbh->disconnect() + or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " + . $dbh->errstr; + return $ref; } # ---------------------------------------------------------- # insert or update DB : execute SQL query passed in # ---------------------------------------------------------- sub DBUPDATE { - my $query = shift; - return if not $query; - - my $dbh = db_connect($SCHED{SQL_DB_JOBS}); - if (not $dbh) { - logit("Error connecting to $SCHED{SQL_DB_JOBS} for update: $DBI::errstr"); - return; - } - - logit("Executing query [$query]") if ($verbose); - my $rv = $dbh->do($query); # This will die on error - - $dbh->disconnect() - or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " - . $dbh->errstr; - return $rv == 0E0 ? 0 : $rv; + my $query = shift; + return if not $query; + + my $dbh = db_connect($SCHED{SQL_DB_JOBS}); + if (not $dbh) { + logit("Error connecting to $SCHED{SQL_DB_JOBS} for update: $DBI::errstr"); + return; + } + + logit("Executing query [$query]") if ($verbose); + my $rv = $dbh->do($query); # This will die on error + + $dbh->disconnect() + or warn "Got warning while disconnecting from $SCHED{SQL_DB_JOBS}: " + . $dbh->errstr; + return $rv == 0E0 ? 0 : $rv; } # ---------------------------------------------------------- @@ -1025,28 +1040,28 @@ sub DBUPDATE { # returns 1 if resource busy # ---------------------------------------------------------- sub ENQ { - if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { - my $ts = strftime("%Y%m%d-%H%M%S",localtime(time)); - my @res = split(/\+/,$_[0]); - foreach (@res) { s/^\s+|\s+$//g } - - # fails if one of requested resources is not free - foreach (@res) { - my @u = glob("$SCHED{PATH_RES}/$_--*"); - return 1 if scalar(@u) > 0; - } - - # then actually enq all requested resources - foreach (@res) { - my $resource_file = "$SCHED{PATH_RES}/$_--$_[1]-$ts"; - open(my $f, '>', $resource_file) - or die "Unable to create file '$resource_file': $!"; - close($f) - or warn "Error while closing file '$resource_file': $!"; - logit("enq $_, jid($_[1])") if ($verbose); - } - } - return 0 + if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { + my $ts = strftime("%Y%m%d-%H%M%S",localtime(time)); + my @res = split(/\+/,$_[0]); + foreach (@res) { s/^\s+|\s+$//g } + + # fails if one of requested resources is not free + foreach (@res) { + my @u = glob("$SCHED{PATH_RES}/$_--*"); + return 1 if scalar(@u) > 0; + } + + # then actually enq all requested resources + foreach (@res) { + my $resource_file = "$SCHED{PATH_RES}/$_--$_[1]-$ts"; + open(my $f, '>', $resource_file) + or die "Unable to create file '$resource_file': $!"; + close($f) + or warn "Error while closing file '$resource_file': $!"; + logit("enq $_, jid($_[1])") if ($verbose); + } + } + return 0 } # ---------------------------------------------------------- @@ -1058,269 +1073,271 @@ sub ENQ { # ** TBD: could check that only jid that ENQd can DEQ # ---------------------------------------------------------- sub DEQ { - if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { - foreach my $res (split(/\+/,$_[0])) { - $res =~ s/^\s+|\s+$//g; - my @g = glob("$SCHED{PATH_RES}/$res--*"); - if (@g) { - unlink @g; - logit("deq $res, jid($_[1])") if ($verbose); - } - } - } - return 0 + if (defined($_[0]) && defined($_[1]) && $_[0] ne '') { + foreach my $res (split(/\+/,$_[0])) { + $res =~ s/^\s+|\s+$//g; + my @g = glob("$SCHED{PATH_RES}/$res--*"); + if (@g) { + unlink @g; + logit("deq $res, jid($_[1])") if ($verbose); + } + } + } + return 0 } # ---------------------------------------------------------- # UDPS receives incoming cmds/jobs on non-blocking socket # ---------------------------------------------------------- sub UDPS { - my $msg = ''; - my $cmd = ''; - my $ans = ''; - my $junk = ''; - - # Read message from the UDFP socket, if any, or return - $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) or return; - - my $sock_client_id = $SOCK->peerhost().":".$SOCK->peerport(); - $msg =~ s/^\s+|\s+$//g; - ($cmd, $msg) = split / /, $msg, 2; - $cmd ||= 'nil'; - $msg ||= 'nil' ; - for ($cmd) { - if (/^JOB/i && $msg) { - my $timekey = time; - $JOBRQ{$timekey}{REQ} = $msg; - $JOBRQ{$timekey}{TTL} = $SCHED{CANCEL_SUBMIT}; - # assign a dynamic jid, even if overidden later because it appears to be a jid= command - $DynJid = -1 if (--$DynJid < -10E9); # dynamic jid , -10**9 rollover - $JOBRQ{$timekey}{JID} = "$DynJid"; - $ans = "request for job queued\n"; - next; - } - if (/^KILLJOB/i && $msg) { - if (not $msg =~ /^kid=(\d+)$/) { - $ans = "killjob command: invalid argument, should be 'kid=XXX'\n"; - next; - } - my $pid = $1; - logit("killing job $pid") if ($verbose); - my $count = kill 'TERM', $pid; - if ($count > 0) { - $ans = "job with pid = $pid has been killed. Please check!\n"; - } else { - $ans = "ERROR: unable to kill job with pid = $pid. Please check the kid argument.\n"; - } - next; - } - if (/^ENQ/i && $msg) { - if (ENQ($msg,$sock_client_id)) { - $ans = "busy $msg"; - } else { - $ans = "ENQ'd $msg\n"; - } - next; - } - if (/^DEQ/i && $msg) { - if (DEQ($msg,$sock_client_id)) { - $ans = "failed DEQ $msg"; - } else { - $ans = "DEQ'd $msg\n"; - } - next; - } - if (/CMD/i) { - for ($msg) { - if (/^PAUSE$/i && $PAUSED != 2) { - $PAUSED = 1 ; - $ans = "Paused\n"; - next; - } - if (/^RESUME$/i && $PAUSED != 2) { - $PAUSED = 0; - $ans = "Resumed\n"; - next; - } - if (/^RUNQ/i) { - $ans = ''; - if (not %RUNQ) { - $ans .= "No running jobs.\n"; - next; - } - for my $id (sort keys %RUNQ) { - my $start_dt = DateTime->from_epoch(epoch => $id, - time_zone => $local_tz); - $ans .= sprintf("RUNQ(%s) started on %s %s\n", $id, - $start_dt->strftime('%F %T (UTC%z)')); - for my $j (sort keys %{$RUNQ{$id}}) { - $ans .= " $j="; - $ans .= defined($RUNQ{$id}{$j}) ? "$RUNQ{$id}{$j}\n" : "nil\n"; - } - } - next; - } - if (/^JOBQ/i) { - $ans = ''; - if (not %JOBRQ) { - $ans .= "No jobs in waiting queue.\n"; - next; - } - for my $j (sort keys (%JOBRQ)) { - $ans .= "ttl=$JOBRQ{$j}{TTL} ".substr($JOBRQ{$j}{REQ},0,40)."...\n"; - } - next; - } - if (/^QS/i) { - my @jobq = map("$JOBRQ{$_}{JID}", sort(keys(%JOBRQ))); - my @lmiss = sort(keys(%LMISS)); - my @emiss = sort(keys(%EMISS)); - my @runq = map("$RUNQ{$_}{jid} (pid $RUNQ{$_}{kid})", - sort(keys(%RUNQ))); - my @enqs = map { s/$SCHED{PATH_RES}\///; s/--.*$//; $_; } - (sort glob("$SCHED{PATH_RES}/*")); - - $ans = "JOBQ: " . (@jobq ? join(', ', @jobq) : "none") - ."\nLMISS: " . (@lmiss ? join(', ', @lmiss) : "none") - ."\nEMISS: " . (@emiss ? join(', ', @emiss) : "none") - ."\nRUNQ: " . (@runq ? join(', ', @runq) : "none") - ."\nENQs: " . (@enqs ? join(', ', @enqs) : "none") - ."\n"; - next; - } - if (/^VERBOSE$/i && $PAUSED != 2) { - $verbose = 1; - $ans = "Verbose On\n"; - next; - } - if (/^QUIET$/i && $PAUSED != 2) { - $verbose = 0; - $ans = "Verbose Off\n"; - next; - } - if (/^FLOG$/i && $PAUSED != 2) { - $forcesavelog = 1; - $ans = "Log will be backed up on next write\n"; - next; - } - if (/^STOP$/i && $PAUSED != 2) { - $ans = 'Stopping'; - my $nb_kids = keys(%kids); - if ($nb_kids) { - $ans .= " after waiting for $nb_kids job(s)" - ." to end: ".join(', ', keys(%kids)); - } else { - $ans .= " now."; - } - $SOCK->send("$ans\n"); - logit("client ".$sock_client_id." sent [ $msg ]"); - exit_after_jobs(); - next; - } - if (/^STAT$/i) { - my $now = time; - $ans = "STATTIME=".strftime("%Y-%m-%d %H:%M:%S (UTC%z)",localtime($now))."\n"; - my @enqs = glob("$SCHED{PATH_RES}/*"); - my @paused = ('No','Yes','Stopping...'); - $ans .= "STARTED=$STRTTS\n"; - $ans .= "PID=$PID\n"; - $ans .= "USER=$PUID\n"; - $ans .= "uTICK=$utick\n"; - $ans .= "BEAT=$SCHED{BEAT}\n"; - $ans .= sprintf("ELT=%.3f (%.2f%%)\n", $ELT, ($ELT*100)/($now-$STRT)); - $ans .= "LOG=$LOGNAME\n"; - $ans .= "JOBSDB=$SCHED{SQL_DB_JOBS}\n"; - $ans .= "JOBS STDio=$SCHED{PATH_STD}\n"; - $ans .= "JOBS RESource=$SCHED{PATH_RES}\n"; - $ans .= "PAUSED=$paused[$PAUSED]\n"; - $ans .= "#JOBSTART=$JSTARTED\n"; - $ans .= "#JOBSEND=$JENDED\n"; - $ans .= "KIDS=".scalar(keys(%kids))."\n"; - $ans .= "ENQs=".scalar(@enqs)."\n"; - next; - } - $ans = "command unknown or invalid at this time\n"; - } - next; - } - $ans = "Unknown action '$_'.\n"; - } - $SOCK->send($ans); - logit("client ".$sock_client_id." sent [ $cmd $msg ]; reply ".length($ans)." bytes") if ($verbose); + my $msg = ''; + my $cmd = ''; + my $ans = ''; + my $junk = ''; + + # Read message from the UDFP socket, if any, or return + $SOCK->recv($msg, $SCHED{SOCKET_MAXLEN}) or return; + + my $sock_client_id = $SOCK->peerhost().":".$SOCK->peerport(); + $msg =~ s/^\s+|\s+$//g; + ($cmd, $msg) = split / /, $msg, 2; + $cmd ||= 'nil'; + $msg ||= 'nil' ; + for ($cmd) { + if (/^JOB/i && $msg) { + my $timekey = time; + $JOBRQ{$timekey}{REQ} = $msg; + $JOBRQ{$timekey}{TTL} = $SCHED{CANCEL_SUBMIT}; + +# assign a dynamic jid, even if overidden later because it appears to be a jid= command + $DynJid = -1 if (--$DynJid < -10E9); # dynamic jid , -10**9 rollover + $JOBRQ{$timekey}{JID} = "$DynJid"; + $ans = "request for job queued\n"; + next; + } + if (/^KILLJOB/i && $msg) { + if (not $msg =~ /^kid=(\d+)$/) { + $ans = "killjob command: invalid argument, should be 'kid=XXX'\n"; + next; + } + my $pid = $1; + logit("killing job $pid") if ($verbose); + my $count = kill 'TERM', $pid; + if ($count > 0) { + $ans = "job with pid = $pid has been killed. Please check!\n"; + } else { + $ans = "ERROR: unable to kill job with pid = $pid. Please check the kid argument.\n"; + } + next; + } + if (/^ENQ/i && $msg) { + if (ENQ($msg,$sock_client_id)) { + $ans = "busy $msg"; + } else { + $ans = "ENQ'd $msg\n"; + } + next; + } + if (/^DEQ/i && $msg) { + if (DEQ($msg,$sock_client_id)) { + $ans = "failed DEQ $msg"; + } else { + $ans = "DEQ'd $msg\n"; + } + next; + } + if (/CMD/i) { + for ($msg) { + if (/^PAUSE$/i && $PAUSED != 2) { + $PAUSED = 1 ; + $ans = "Paused\n"; + next; + } + if (/^RESUME$/i && $PAUSED != 2) { + $PAUSED = 0; + $ans = "Resumed\n"; + next; + } + if (/^RUNQ/i) { + $ans = ''; + if (not %RUNQ) { + $ans .= "No running jobs.\n"; + next; + } + for my $id (sort keys %RUNQ) { + my $start_dt = DateTime->from_epoch(epoch => $id, + time_zone => $local_tz); + $ans .= sprintf("RUNQ(%s) started on %s %s\n", $id, + $start_dt->strftime('%F %T (UTC%z)')); + for my $j (sort keys %{$RUNQ{$id}}) { + $ans .= " $j="; + $ans .= defined($RUNQ{$id}{$j}) ? "$RUNQ{$id}{$j}\n" : "nil\n"; + } + } + next; + } + if (/^JOBQ/i) { + $ans = ''; + if (not %JOBRQ) { + $ans .= "No jobs in waiting queue.\n"; + next; + } + for my $j (sort keys (%JOBRQ)) { + $ans .= "ttl=$JOBRQ{$j}{TTL} ".substr($JOBRQ{$j}{REQ},0,40)."...\n"; + } + next; + } + if (/^QS/i) { + my @jobq = map("$JOBRQ{$_}{JID}", sort(keys(%JOBRQ))); + my @lmiss = sort(keys(%LMISS)); + my @emiss = sort(keys(%EMISS)); + my @runq = map("$RUNQ{$_}{jid} (pid $RUNQ{$_}{kid})", + sort(keys(%RUNQ))); + my @enqs = map { s/$SCHED{PATH_RES}\///; s/--.*$//; $_; } + (sort glob("$SCHED{PATH_RES}/*")); + + $ans = "JOBQ: " . (@jobq ? join(', ', @jobq) : "none") + ."\nLMISS: " . (@lmiss ? join(', ', @lmiss) : "none") + ."\nEMISS: " . (@emiss ? join(', ', @emiss) : "none") + ."\nRUNQ: " . (@runq ? join(', ', @runq) : "none") + ."\nENQs: " . (@enqs ? join(', ', @enqs) : "none") + ."\n"; + next; + } + if (/^VERBOSE$/i && $PAUSED != 2) { + $verbose = 1; + $ans = "Verbose On\n"; + next; + } + if (/^QUIET$/i && $PAUSED != 2) { + $verbose = 0; + $ans = "Verbose Off\n"; + next; + } + if (/^FLOG$/i && $PAUSED != 2) { + $forcesavelog = 1; + $ans = "Log will be backed up on next write\n"; + next; + } + if (/^STOP$/i && $PAUSED != 2) { + $ans = 'Stopping'; + my $nb_kids = keys(%kids); + if ($nb_kids) { + $ans .= " after waiting for $nb_kids job(s)" + ." to end: ".join(', ', keys(%kids)); + } else { + $ans .= " now."; + } + $SOCK->send("$ans\n"); + logit("client ".$sock_client_id." sent [ $msg ]"); + exit_after_jobs(); + next; + } + if (/^STAT$/i) { + my $now = time; + $ans = "STATTIME=".strftime("%Y-%m-%d %H:%M:%S (UTC%z)",localtime($now))."\n"; + my @enqs = glob("$SCHED{PATH_RES}/*"); + my @paused = ('No','Yes','Stopping...'); + $ans .= "STARTED=$STRTTS\n"; + $ans .= "PID=$PID\n"; + $ans .= "USER=$PUID\n"; + $ans .= "uTICK=$utick\n"; + $ans .= "BEAT=$SCHED{BEAT}\n"; + $ans .= sprintf("ELT=%.3f (%.2f%%)\n", $ELT, ($ELT*100)/($now-$STRT)); + $ans .= "LOG=$LOGNAME\n"; + $ans .= "JOBSDB=$SCHED{SQL_DB_JOBS}\n"; + $ans .= "JOBS STDio=$SCHED{PATH_STD}\n"; + $ans .= "JOBS RESource=$SCHED{PATH_RES}\n"; + $ans .= "PAUSED=$paused[$PAUSED]\n"; + $ans .= "#JOBSTART=$JSTARTED\n"; + $ans .= "#JOBSEND=$JENDED\n"; + $ans .= "KIDS=".scalar(keys(%kids))."\n"; + $ans .= "ENQs=".scalar(@enqs)."\n"; + next; + } + $ans = "command unknown or invalid at this time\n"; + } + next; + } + $ans = "Unknown action '$_'.\n"; + } + $SOCK->send($ans); + logit("client ".$sock_client_id." sent [ $cmd $msg ]; reply ".length($ans)." bytes") if ($verbose); } # ---------------------------------------------------------- # write to scheduler's log # ---------------------------------------------------------- sub logit { - my ($logtxt) = @_; - my $TS=[gettimeofday]; - my $ts=sprintf ("%s.%6.6s", strftime("%Y-%m-%d %H:%M:%S",localtime(@$TS[0])),@$TS[1]*100); - my $tsdate=substr($ts,0,10); - - if (($lldate ne '' && $tsdate ne $lldate) || $forcesavelog == 1) { - # it is time to save the log file and start a new one - $forcesavelog = 0; - close(LOG); - (my $tsfn = $ts) =~ s| |-|g; - my $rc = move("$LOGNAME", "$SAVELOGPATH/$tsfn"); - open LOG, ">>$LOGNAME"; - if ($rc == 0) { - print LOG "$ts saved log to $SAVELOGPATH/$tsfn\n"; - } else { - print LOG "$ts: Error: could not move file '$LOGNAME' to '$SAVELOGPATH/$tsfn'\n"; - } - } - - if ($logtxt ne $DITTO) { - if ($DITTO ne '' && $DITTOCNT != 0) { - print LOG "$ts $DITTO (x$DITTOCNT)\n"; - } - print LOG "$ts $logtxt\n"; - $DITTO = $logtxt; - $DITTOCNT = 0; - } else { - if ($DITTOCNT++ == $SCHED{DITTO_LOG_MAX}-1) { - print LOG "$ts $DITTO (x$DITTOCNT)\n"; - $DITTOCNT = 0; - } - } - $lldate = $tsdate; + my ($logtxt) = @_; + my $TS=[gettimeofday]; + my $ts=sprintf ("%s.%6.6s", strftime("%Y-%m-%d %H:%M:%S",localtime(@$TS[0])),@$TS[1]*100); + my $tsdate=substr($ts,0,10); + + if (($lldate ne '' && $tsdate ne $lldate) || $forcesavelog == 1) { + + # it is time to save the log file and start a new one + $forcesavelog = 0; + close(LOG); + (my $tsfn = $ts) =~ s| |-|g; + my $rc = move("$LOGNAME", "$SAVELOGPATH/$tsfn"); + open LOG, ">>$LOGNAME"; + if ($rc == 0) { + print LOG "$ts saved log to $SAVELOGPATH/$tsfn\n"; + } else { + print LOG "$ts: Error: could not move file '$LOGNAME' to '$SAVELOGPATH/$tsfn'\n"; + } + } + + if ($logtxt ne $DITTO) { + if ($DITTO ne '' && $DITTOCNT != 0) { + print LOG "$ts $DITTO (x$DITTOCNT)\n"; + } + print LOG "$ts $logtxt\n"; + $DITTO = $logtxt; + $DITTOCNT = 0; + } else { + if ($DITTOCNT++ == $SCHED{DITTO_LOG_MAX}-1) { + print LOG "$ts $DITTO (x$DITTOCNT)\n"; + $DITTOCNT = 0; + } + } + $lldate = $tsdate; } # ---------------------------------------------------------- # send notification to postboard # ---------------------------------------------------------- sub notifyit { - my ($ntftxt) = @_; - my $ntf; - - if ($ntftxt ne $DITTONTF) { - if ($DITTONTF ne '' && $DITTONTFCNT != 0){ - $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); - WebObs::Config::notify("$ntf"); - } - $ntf=sprintf ("%s", $ntftxt); - WebObs::Config::notify("$ntf"); - $DITTONTF = $ntftxt; - $DITTONTFCNT = 0; - } else { - if ($DITTONTFCNT++ == $SCHED{DITTO_LOG_MAX}-1) { - $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); - WebObs::Config::notify("$ntf"); - $DITTONTFCNT = 0; - } - } + my ($ntftxt) = @_; + my $ntf; + + if ($ntftxt ne $DITTONTF) { + if ($DITTONTF ne '' && $DITTONTFCNT != 0){ + $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); + WebObs::Config::notify("$ntf"); + } + $ntf=sprintf ("%s", $ntftxt); + WebObs::Config::notify("$ntf"); + $DITTONTF = $ntftxt; + $DITTONTFCNT = 0; + } else { + if ($DITTONTFCNT++ == $SCHED{DITTO_LOG_MAX}-1) { + $ntf=sprintf ("%s (x%s)", $DITTONTF,$DITTONTFCNT); + WebObs::Config::notify("$ntf"); + $DITTONTFCNT = 0; + } + } } # ---------------------------------------------------------- # clean exit with optional rc # ---------------------------------------------------------- sub myexit { - my $code = shift // 1; - logit("scheduler[$$] exiting with code $code."); - close(LOG); - exit($code); + my $code = shift // 1; + logit("scheduler[$$] exiting with code $code."); + close(LOG); + exit($code); } __END__ diff --git a/CODE/perl/seiscomp2mc3.pl b/CODE/perl/seiscomp2mc3.pl index 7a30c136..75ea8158 100755 --- a/CODE/perl/seiscomp2mc3.pl +++ b/CODE/perl/seiscomp2mc3.pl @@ -44,6 +44,7 @@ =head1 DEPENDENCIES use WebObs::Config; use WebObs::QML; + # Date parsing library use DateTime::Format::Strptime; @@ -62,60 +63,60 @@ =head1 DEPENDENCIES # ---- help text when no arguments if (@ARGV == 0) { - print "WebObs SeisComP to MC3 seismic bulletin\n\n", - "Usage: $0 COMMAND [OPTIONS]\n\n", - "\tThe script checks new events in QuakeML SeisComP database and updates\n", - "\tif necessary the MC3 database by creating new events entries. List of\n", - "\tavailable commands and options:\n\n", - "\tupdate\n", - "\t\tUpdates MC3 database.\n", - "\tcheck\n", - "\t\tchecks MC3 database (read only).\n", - "\tdumper\n", - "\t\tchecks and dumps XML tree (read only).\n", - "\t-f MC3NAME\n", - "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", - "\t-n SEFRAN3 name\n", - "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", - "\n\tFrancois Beauducel, IPGP \n\n" - ; - exit(0); + print "WebObs SeisComP to MC3 seismic bulletin\n\n", + "Usage: $0 COMMAND [OPTIONS]\n\n", + "\tThe script checks new events in QuakeML SeisComP database and updates\n", + "\tif necessary the MC3 database by creating new events entries. List of\n", + "\tavailable commands and options:\n\n", + "\tupdate\n", + "\t\tUpdates MC3 database.\n", + "\tcheck\n", + "\t\tchecks MC3 database (read only).\n", + "\tdumper\n", + "\t\tchecks and dumps XML tree (read only).\n", + "\t-f MC3NAME\n", + "\t\tSpecifies MC3 conf name. Default is MC3_DEFAULT_NAME in WEBOBS.conf.\n", + "\t-n SEFRAN3 name\n", + "\t\tSpecifies SEFRAN3 name to use as reference. Default is SEFRAN3_DEFAULT_NAME in WEBOBS.conf.\n", + "\n\tFrancois Beauducel, IPGP \n\n" + ; + exit(0); } # ---- check for command and option my $arg; if (@ARGV > 0) { - $arg = shift; - if (!($arg =~ /update|check|dumper/)) { - print "'$arg' invalid command\n"; - exit(1); - } - my $opt = shift || ''; - if ( $opt =~ /-f/ ) { - $opt = shift; - if ( $opt ) { - if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { - $mc3 = $opt; - } else { - print "'$opt' does not exists\n"; - exit(1); - } - } else { - print "invalid -f option\n"; - exit(1); - } - } - if ( $opt =~ /-n/ ) { - $opt = shift; - if ( $opt ) { - $sefran3_name = $opt; - print "-n option $sefran3_name\n"; - $opt = shift || ''; - } else { - print "invalid -n option\n"; - exit(1); - } - } + $arg = shift; + if (!($arg =~ /update|check|dumper/)) { + print "'$arg' invalid command\n"; + exit(1); + } + my $opt = shift || ''; + if ( $opt =~ /-f/ ) { + $opt = shift; + if ( $opt ) { + if ( -e "$WEBOBS{ROOT_CONF}/$opt.conf" ) { + $mc3 = $opt; + } else { + print "'$opt' does not exists\n"; + exit(1); + } + } else { + print "invalid -f option\n"; + exit(1); + } + } + if ( $opt =~ /-n/ ) { + $opt = shift; + if ( $opt ) { + $sefran3_name = $opt; + print "-n option $sefran3_name\n"; + $opt = shift || ''; + } else { + print "invalid -n option\n"; + exit(1); + } + } } # ---- read config @@ -124,8 +125,8 @@ =head1 DEPENDENCIES my @blacklist_types = split(/,/,$MC3{SC3_EVENT_TYPES_BLACKLIST}); if (! -d $MC3{SC3_EVENTS_ROOT} ) { - print "creating $MC3{SC3_EVENTS_ROOT}\n"; - my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); + print "creating $MC3{SC3_EVENTS_ROOT}\n"; + my @rcme = qx(mkdir -p $MC3{SC3_EVENTS_ROOT} ); } # ---- gets the list of last events @@ -135,340 +136,358 @@ =head1 DEPENDENCIES # checks if events exist in MC database for (@last) { - my $name = $_; - $name =~ s/$MC3{SC3_EVENTS_ROOT}\///; - my ($evt_y,$evt_m,$evt_d,$evt_id) = split(/\//,$name); - my $fullname = "$_/$evt_id.last.xml"; - print "--- checking $fullname ---\n"; - - my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; - my @lines = qx(grep "$evt_id" $mc_path|cut -d'|' -f14|xargs echo -n); - my $mc_file; - - if (@lines) { - # event's ID already exists in MC: do nothing (for the moment...) - $mc_file = ""; - } else { - - # ------------------------------------------------------------------------- - # event seems new: updates MC file - print "new event : $evt_id\n"; - - my @tab; - my $s; - - my @event = qx($WEBOBS{XML2_PRGM} < $fullname); - - $s = '/seiscomp/EventParameters'; - foreach (@event) { s/^$s//g; } - - if ($arg =~ /dumper/) { - print join('',@event); - } - chomp(@event); - - # --- gets event type - my $evt_type = findvalue('/event/type=',\@event) // ''; - print "event type = $evt_type\n"; - if (grep(/^$evt_type$/,@blacklist_types)) { - print "Warning: Event type '$evt_type' is blacklisted!\n"; - } else { - - # --- gets preferred origin ID - my $evt_origID = findvalue('/event/preferredOriginID=',\@event); - print "origin ID = $evt_origID\n"; - - # --- selects preferred origin - my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); - - # --- gets origin:time - my $evt_time = findvalue('/time/value=',\@origin); - print "origin time = $evt_time\n"; - - # --- gets origin:latitude - my $evt_lat = findvalue('/latitude/value=',\@origin); - print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; - - # --- gets origin:longitude - my $evt_lon = findvalue('/longitude/value=',\@origin); - print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; - - # --- gets origin:methodID - my $evt_mcID = findvalue('/methodID=',\@origin) // ''; - print "origin methodID (MCID) = $evt_mcID\n"; - my ($mcIDname,$mcIDym,$mcIDid) = split(/\//,$evt_mcID); - - # --- gets origin:depth - my $evt_dep = findvalue('/depth/value=',\@origin); - print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; - - # --- gets origin:evaluationMode and origin:evaluationStatus - my $evt_mode = findvalue('/evaluationMode=',\@origin); - my $evt_status = findvalue('/evaluationStatus=',\@origin); - if ($evt_status && $evt_status eq 'confirmed') { - $evt_type = 'UNKNOWN'; - } else { - $evt_type = 'AUTO'; - } - - print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; - print "origin status = ".($evt_status ? "$evt_status":"")."\n"; - - # --- gets preferred magnitude ID - my $evt_magID = findvalue('/event/preferredMagnitudeID=',\@event); - - my $evt_mag = ''; - my $evt_smag = ''; - my @magnitude; - if ($evt_magID) { - print "origin magnitude ID = $evt_magID\n"; - @magnitude = findnode('/origin/magnitude',"/\@publicID=$evt_magID",\@event); - } else { - @magnitude = findnode('/origin/magnitude','/\@publicID=',\@event); - print "* Warning: no preferred magnitude! Takes first...\n"; - } - if (@magnitude) { - $evt_mag = findvalue('/magnitude/value=',\@magnitude); - print "origin magnitude = $evt_mag\n"; - $evt_smag = $evt_mag; - } else { - print "* Warning: no magnitude!\n"; - } - - - # --- selects first pick - # sorting pick:time:value = chronological order - @tab = sort(findvalues('/pick/time/value=',\@event)); - my $evt_pick = $tab[0]; - my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); - my $evt_pickID = findvalue('/\@publicID=',\@pick); - my $evt_sdate = substr($evt_pick,0,10) // ''; - my $evt_stime = substr($evt_pick,11,11) // ''; - $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" - my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; - my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; - my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; - my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; - my $evt_scode = "$NET.$STA.$LOC.$CHA"; - print "station pickID = $evt_pickID\n"; - print "station time = $evt_pick\n"; - print "station code = $evt_scode\n"; - - - my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); - - my $evt_pha = ''; - my $evt_dist = ''; - my $evt_unique = 0; - my $evt_SP = ''; - if (@arrival) { - # --- unique arrival or not - if (scalar(@arrival) == 1) { - $evt_unique = 1; - } - - # --- finds first station phase and distance (using "origin:arrival") - $evt_pha = findvalue('/phase=',\@arrival); - $evt_dist = findvalue('/distance=',\@arrival); - $evt_dist *= 111 if ($evt_dist); - print "station phase = $evt_pha\n"; - print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; - # --- computes S-P and duration from distance and magnitude - $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); - print "station S-P = $evt_SP\n"; - } else { - print "* Warning: no arrivals (phase, distance, S-P)!\n"; - } - - # --- computes duration from distance and magnitude - my $evt_dur = ''; - if ($evt_smag && $evt_dist) { - $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); - print "station duration = $evt_dur\n"; - if ($evt_dur == 0) { - $evt_dur = ''; - } - } else { - print "* Warning: no duration!\n"; - } - - # --- selects first station arrival (using "amplitude") - my @amplitude = findnode('/amplitude',"/pickID=$evt_pickID",\@event); - - my $evt_samp = ''; - if (@amplitude) { - # --- gets amplitude:value - $evt_samp = findvalue('/amplitude/value=',\@amplitude); - print "station amplitude = $evt_samp\n"; - } else { - print "* Warning: no amplitude!\n"; - } - - if (!$evt_sdate) { - # If the event doesn't have any picks, we get /origin/time/value (already stored in $evt_time) - $evt_sdate = substr($evt_time,0,10) || ''; - $evt_stime = substr($evt_time,11,11) || ''; - $evt_stime =~ s/[A-Z]/0/g; # remove trailing "Z" in "2012-05-07T18:46:53.7Z" - } - - - my $lockFile = "/tmp/.$mc3.lock"; - - if ($arg =~ /update/) { - # --- checks lock file - if (-e $lockFile) { - my $lockWho = qx(cat $lockFile | xargs echo -n); - die "WEBOBS: MC is presently edited by $lockWho ..."; - } else { - my $retLock = qx(echo "$oper" > $lockFile); - } - } - - my $mc_id; - my $newID = 1; - my $maxID = 0; - - # --- reads MC file - my ($mcy,$mcm) = split(/-/,$evt_sdate); - # The date of the event is mandatory - if (defined($mcy)) { - $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; - my @lignes; - if (-e $mc_file) { - print "MC file: $mc_file ..."; - open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); - while() { - my $line = $_; - my $line2=$line; - chomp($line2); - ($mc_id) = split(/\|/,$line2); - # Ignore blank lines - if (defined($mc_id)) { - # check if $evt_mcID found - if ($evt_mcID ne '') { - if ($mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { - my @txt = split(/\|/,$line); - # Sanity check : we mustn't change a SC3 ID already stored in the MC3 file - if ( $txt[13] eq '' ) { - # Sanity check : we update the MC file only if the date of the event is the same (under $max_dts_sc3_mc3) - # It is necessary if the MC file has been corrupted or deleted and the new file doesn't have the same IDs than before, so we can't use the MC IDs stored in SC3 - my $strp = DateTime::Format::Strptime->new( - pattern => '%Y-%m-%d %H:%M:%S', - time_zone => 'UTC', - ); - # Datetimes in XML and MC3 (truncated to second) - my $dt_qml = $strp->parse_datetime($evt_sdate." ".substr($evt_stime,0,8)); - my $dt_mc = $strp->parse_datetime($txt[1]." ".substr($txt[2],0,8)); - # Unix timestamps in XML and MC3 - my $ts_qml=$dt_qml->epoch; - my $ts_mc=$dt_mc->epoch; - # Difference of timestamps : it must be under $max_dts_sc3_mc3 - my $dts=abs($ts_qml-$ts_mc); - # If it's the same event - if ($dts < $max_dts_sc3_mc3) { - $newID = 0; - # Update Event ID - print "Replacing ID $txt[13] by $evt_y/$evt_m/$evt_d/$evt_id (dts $dts)\n"; - $txt[13] = "$evt_y/$evt_m/$evt_d/$evt_id"; - # @txt last field already contains "\n" - $line = join('|',@txt); - } else { - print "Same MC ID ($mc_id) but with different date : $evt_sdate $evt_stime (QML) != $txt[1] $txt[2] (MC)\n" - } - } else { - print "This MC ID ($mc_id) already has a SC3 ID ($txt[13]) !\n" - } - } - } - $maxID = abs($mc_id) if (abs($mc_id) > $maxID); - } - push(@lignes,$line); - } - close(FILE); - print " imported (max ID = $maxID).\n"; - } else { - # MC file does not exist: need to create directory and empty file. - if ($arg =~ /update/) { - qx(mkdir -p `dirname $mc_file`); - open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); - print FILE (""); - close(FILE); - $mc_id = 1; - } - } - - # --- outputs for MC - if ($newID > 0) { - $mc_id = $maxID + 1; - my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$evt_y/$evt_m/$evt_d/$evt_id||$oper|\n"; - print "$newline\n"; - push(@lignes,$newline); - } - - - - if ($arg =~ /update/) { - @lignes = sort Sort_date_with_id(@lignes); - - # Temporary file for sanity check before replacing - my $mc_file_temp="$mc_file.tmp"; - # Open temporary file for writing - open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); - # Write the updated lines - print FILE @lignes; - close(FILE); - # Sanity check : the columns number must always be 17 (empty lines are ignored) - if (system("awk -F'|' 'NF>0&&NF!=17{exit 1}' $mc_file") == 0) { - # Test passed, the file isn't corrupted - # The update should have increased the file size - if ( -s $mc_file_temp >= -s $mc_file ) { - # The file size is increased - # Replace the old file by the new one - if ( system("mv $mc_file_temp $mc_file") == 0 ) { - print "MC file: $mc_file updated\n"; - } else { - Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); - } - } - } else { - print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; - } - - } - } else { - print "No date for this new event !"; - } - if ($arg =~ /update/) { - # --- deletes lock file - if (-e $lockFile) { - unlink $lockFile; - } - } - } - } - - setlocale(LC_NUMERIC,$old_locale); + my $name = $_; + $name =~ s/$MC3{SC3_EVENTS_ROOT}\///; + my ($evt_y,$evt_m,$evt_d,$evt_id) = split(/\//,$name); + my $fullname = "$_/$evt_id.last.xml"; + print "--- checking $fullname ---\n"; + + my $mc_path = "$MC3{ROOT}/*/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}*.txt"; + my @lines = qx(grep "$evt_id" $mc_path|cut -d'|' -f14|xargs echo -n); + my $mc_file; + + if (@lines) { + + # event's ID already exists in MC: do nothing (for the moment...) + $mc_file = ""; + } else { + + # ------------------------------------------------------------------------- + # event seems new: updates MC file + print "new event : $evt_id\n"; + + my @tab; + my $s; + + my @event = qx($WEBOBS{XML2_PRGM} < $fullname); + + $s = '/seiscomp/EventParameters'; + foreach (@event) { s/^$s//g; } + + if ($arg =~ /dumper/) { + print join('',@event); + } + chomp(@event); + + # --- gets event type + my $evt_type = findvalue('/event/type=',\@event) // ''; + print "event type = $evt_type\n"; + if (grep(/^$evt_type$/,@blacklist_types)) { + print "Warning: Event type '$evt_type' is blacklisted!\n"; + } else { + + # --- gets preferred origin ID + my $evt_origID = findvalue('/event/preferredOriginID=',\@event); + print "origin ID = $evt_origID\n"; + + # --- selects preferred origin + my @origin = findnode('/origin',"/\@publicID=$evt_origID",\@event); + + # --- gets origin:time + my $evt_time = findvalue('/time/value=',\@origin); + print "origin time = $evt_time\n"; + + # --- gets origin:latitude + my $evt_lat = findvalue('/latitude/value=',\@origin); + print "origin latitude = ".($evt_lat ? "$evt_lat":"")."\n"; + + # --- gets origin:longitude + my $evt_lon = findvalue('/longitude/value=',\@origin); + print "origin longitude = ".($evt_lon ? "$evt_lon":"")."\n"; + + # --- gets origin:methodID + my $evt_mcID = findvalue('/methodID=',\@origin) // ''; + print "origin methodID (MCID) = $evt_mcID\n"; + my ($mcIDname,$mcIDym,$mcIDid) = split(/\//,$evt_mcID); + + # --- gets origin:depth + my $evt_dep = findvalue('/depth/value=',\@origin); + print "origin depth = ".($evt_dep ? "$evt_dep":"")."\n"; + + # --- gets origin:evaluationMode and origin:evaluationStatus + my $evt_mode = findvalue('/evaluationMode=',\@origin); + my $evt_status = findvalue('/evaluationStatus=',\@origin); + if ($evt_status && $evt_status eq 'confirmed') { + $evt_type = 'UNKNOWN'; + } else { + $evt_type = 'AUTO'; + } + + print "origin mode = ".($evt_mode ? "$evt_mode":"")."\n"; + print "origin status = ".($evt_status ? "$evt_status":"")."\n"; + + # --- gets preferred magnitude ID + my $evt_magID = findvalue('/event/preferredMagnitudeID=',\@event); + + my $evt_mag = ''; + my $evt_smag = ''; + my @magnitude; + if ($evt_magID) { + print "origin magnitude ID = $evt_magID\n"; + @magnitude = findnode('/origin/magnitude',"/\@publicID=$evt_magID",\@event); + } else { + @magnitude = findnode('/origin/magnitude','/\@publicID=',\@event); + print "* Warning: no preferred magnitude! Takes first...\n"; + } + if (@magnitude) { + $evt_mag = findvalue('/magnitude/value=',\@magnitude); + print "origin magnitude = $evt_mag\n"; + $evt_smag = $evt_mag; + } else { + print "* Warning: no magnitude!\n"; + } + + # --- selects first pick + # sorting pick:time:value = chronological order + @tab = sort(findvalues('/pick/time/value=',\@event)); + my $evt_pick = $tab[0]; + my @pick = findnode('/pick',"/time/value=$evt_pick",\@event); + my $evt_pickID = findvalue('/\@publicID=',\@pick); + my $evt_sdate = substr($evt_pick,0,10) // ''; + my $evt_stime = substr($evt_pick,11,11) // ''; + $evt_stime =~ s/[A-Z]/0/g; # sometimes time value is "2012-05-07T18:46:53.7Z" + my $NET = findvalue('/waveformID/@networkCode=',\@pick) // ''; + my $STA = findvalue('/waveformID/@stationCode=',\@pick) // ''; + my $LOC = findvalue('/waveformID/@locationCode=',\@pick) // ''; + my $CHA = findvalue('/waveformID/@channelCode=',\@pick) // ''; + my $evt_scode = "$NET.$STA.$LOC.$CHA"; + print "station pickID = $evt_pickID\n"; + print "station time = $evt_pick\n"; + print "station code = $evt_scode\n"; + + my @arrival = findnode('/arrival',"/pickID=$evt_pickID",\@origin); + + my $evt_pha = ''; + my $evt_dist = ''; + my $evt_unique = 0; + my $evt_SP = ''; + if (@arrival) { + + # --- unique arrival or not + if (scalar(@arrival) == 1) { + $evt_unique = 1; + } + + # --- finds first station phase and distance (using "origin:arrival") + $evt_pha = findvalue('/phase=',\@arrival); + $evt_dist = findvalue('/distance=',\@arrival); + $evt_dist *= 111 if ($evt_dist); + print "station phase = $evt_pha\n"; + print "station distance = ".($evt_dist ? "$evt_dist":"")."\n"; + + # --- computes S-P and duration from distance and magnitude + $evt_SP = ($evt_dist ? sprintf("%1.2f",$evt_dist/8):""); + print "station S-P = $evt_SP\n"; + } else { + print "* Warning: no arrivals (phase, distance, S-P)!\n"; + } + + # --- computes duration from distance and magnitude + my $evt_dur = ''; + if ($evt_smag && $evt_dist) { + $evt_dur = sprintf("%1.2f",10 ** (($evt_smag - $evt_dist*0.0035 + 0.87)/2)); + print "station duration = $evt_dur\n"; + if ($evt_dur == 0) { + $evt_dur = ''; + } + } else { + print "* Warning: no duration!\n"; + } + + # --- selects first station arrival (using "amplitude") + my @amplitude = findnode('/amplitude',"/pickID=$evt_pickID",\@event); + + my $evt_samp = ''; + if (@amplitude) { + + # --- gets amplitude:value + $evt_samp = findvalue('/amplitude/value=',\@amplitude); + print "station amplitude = $evt_samp\n"; + } else { + print "* Warning: no amplitude!\n"; + } + + if (!$evt_sdate) { + +# If the event doesn't have any picks, we get /origin/time/value (already stored in $evt_time) + $evt_sdate = substr($evt_time,0,10) || ''; + $evt_stime = substr($evt_time,11,11) || ''; + $evt_stime =~ s/[A-Z]/0/g; # remove trailing "Z" in "2012-05-07T18:46:53.7Z" + } + + my $lockFile = "/tmp/.$mc3.lock"; + + if ($arg =~ /update/) { + + # --- checks lock file + if (-e $lockFile) { + my $lockWho = qx(cat $lockFile | xargs echo -n); + die "WEBOBS: MC is presently edited by $lockWho ..."; + } else { + my $retLock = qx(echo "$oper" > $lockFile); + } + } + + my $mc_id; + my $newID = 1; + my $maxID = 0; + + # --- reads MC file + my ($mcy,$mcm) = split(/-/,$evt_sdate); + + # The date of the event is mandatory + if (defined($mcy)) { + $mc_file = "$MC3{ROOT}/$mcy/$MC3{PATH_FILES}/$MC3{FILE_PREFIX}$mcy$mcm.txt"; + my @lignes; + if (-e $mc_file) { + print "MC file: $mc_file ..."; + open(FILE, "<$mc_file") || Quit($lockFile," Problem to read $mc_file\n"); + while() { + my $line = $_; + my $line2=$line; + chomp($line2); + ($mc_id) = split(/\|/,$line2); + + # Ignore blank lines + if (defined($mc_id)) { + + # check if $evt_mcID found + if ($evt_mcID ne '') { + if ($mcIDname eq $mc3 && $mcIDym eq "$mcy$mcm" && $mc_id == $mcIDid) { + my @txt = split(/\|/,$line); + + # Sanity check : we mustn't change a SC3 ID already stored in the MC3 file + if ( $txt[13] eq '' ) { + +# Sanity check : we update the MC file only if the date of the event is the same (under $max_dts_sc3_mc3) +# It is necessary if the MC file has been corrupted or deleted and the new file doesn't have the same IDs than before, so we can't use the MC IDs stored in SC3 + my $strp = DateTime::Format::Strptime->new( + pattern => '%Y-%m-%d %H:%M:%S', + time_zone => 'UTC', + ); + + # Datetimes in XML and MC3 (truncated to second) + my $dt_qml = $strp->parse_datetime($evt_sdate." ".substr($evt_stime,0,8)); + my $dt_mc = $strp->parse_datetime($txt[1]." ".substr($txt[2],0,8)); + + # Unix timestamps in XML and MC3 + my $ts_qml=$dt_qml->epoch; + my $ts_mc=$dt_mc->epoch; + + # Difference of timestamps : it must be under $max_dts_sc3_mc3 + my $dts=abs($ts_qml-$ts_mc); + + # If it's the same event + if ($dts < $max_dts_sc3_mc3) { + $newID = 0; + + # Update Event ID + print "Replacing ID $txt[13] by $evt_y/$evt_m/$evt_d/$evt_id (dts $dts)\n"; + $txt[13] = "$evt_y/$evt_m/$evt_d/$evt_id"; + + # @txt last field already contains "\n" + $line = join('|',@txt); + } else { + print "Same MC ID ($mc_id) but with different date : $evt_sdate $evt_stime (QML) != $txt[1] $txt[2] (MC)\n" + } + } else { + print "This MC ID ($mc_id) already has a SC3 ID ($txt[13]) !\n" + } + } + } + $maxID = abs($mc_id) if (abs($mc_id) > $maxID); + } + push(@lignes,$line); + } + close(FILE); + print " imported (max ID = $maxID).\n"; + } else { + + # MC file does not exist: need to create directory and empty file. + if ($arg =~ /update/) { + qx(mkdir -p `dirname $mc_file`); + open(FILE, ">$mc_file") || Quit($lockFile,"Problem to create new file $mc_file\n"); + print FILE (""); + close(FILE); + $mc_id = 1; + } + } + + # --- outputs for MC + if ($newID > 0) { + $mc_id = $maxID + 1; + my $newline = "$mc_id|$evt_sdate|$evt_stime|$evt_type||$evt_dur|s|0|1|$evt_SP|$evt_scode|$evt_unique|$sefran3_name|$evt_y/$evt_m/$evt_d/$evt_id||$oper|\n"; + print "$newline\n"; + push(@lignes,$newline); + } + + if ($arg =~ /update/) { + @lignes = sort Sort_date_with_id(@lignes); + + # Temporary file for sanity check before replacing + my $mc_file_temp="$mc_file.tmp"; + + # Open temporary file for writing + open(FILE, ">$mc_file_temp") || Quit($lockFile,"Problem with file $mc_file_temp !\n"); + + # Write the updated lines + print FILE @lignes; + close(FILE); + + # Sanity check : the columns number must always be 17 (empty lines are ignored) + if (system("awk -F'|' 'NF>0&&NF!=17{exit 1}' $mc_file") == 0) { + + # Test passed, the file isn't corrupted + # The update should have increased the file size + if ( -s $mc_file_temp >= -s $mc_file ) { + + # The file size is increased + # Replace the old file by the new one + if ( system("mv $mc_file_temp $mc_file") == 0 ) { + print "MC file: $mc_file updated\n"; + } else { + Quit($lockFile,"Problem while replacing file $mc_file by $mc_file_temp!\n"); + } + } + } else { + print "Problem with updated file : bad columns number ! Not replacing file $mc_file !\n"; + } + + } + } else { + print "No date for this new event !"; + } + if ($arg =~ /update/) { + + # --- deletes lock file + if (-e $lockFile) { + unlink $lockFile; + } + } + } + } + + setlocale(LC_NUMERIC,$old_locale); } - #-------------------------------------------------------------------------------------------------------------------------------------- sub Sort_date_with_id ($$) { - my ($c,$d) = @_; + my ($c,$d) = @_; - # removes the first field (ID) - $c =~ s/^[\-0-9]+\|//; - $d =~ s/^[\-0-9]+\|//; + # removes the first field (ID) + $c =~ s/^[\-0-9]+\|//; + $d =~ s/^[\-0-9]+\|//; - return $d cmp $c; + return $d cmp $c; } #-------------------------------------------------------------------------------------------------------------------------------------- sub Quit { - if (-e $_[0]) { - unlink $_[0]; - } - die "WEBOBS: $_[1]"; + if (-e $_[0]) { + unlink $_[0]; + } + die "WEBOBS: $_[1]"; } __END__ diff --git a/CODE/perl/sendTHEIA.pl b/CODE/perl/sendTHEIA.pl index c2eab5ae..5af9fc41 100755 --- a/CODE/perl/sendTHEIA.pl +++ b/CODE/perl/sendTHEIA.pl @@ -48,11 +48,11 @@ =head1 DESCRIPTION # ---- local functions # Compress $tmpdir's files into $zipfile without the whole path in the compress archive sub compressTxtFiles { - my $dataset = shift; - my $dataName = (split /\_/, $dataset)[-1]; - my $tmpdir = shift; - zip [ <$tmpdir/*$dataName\_*.txt> ] => "$tmpdir/$dataset.zip", - FilterName => sub { s[^$tmpdir/][] }; + my $dataset = shift; + my $dataName = (split /\_/, $dataset)[-1]; + my $tmpdir = shift; + zip [ <$tmpdir/*$dataName\_*.txt> ] => "$tmpdir/$dataset.zip", + FilterName => sub { s[^$tmpdir/][] }; } # ---- creating tmp and exports/theia directories if required @@ -60,15 +60,15 @@ sub compressTxtFiles { my $theiadir = "$WEBOBS{ROOT_OUTE}/theia/$datedir"; if ( ! -e $tmpdir ) { - make_path($tmpdir, {chmod => 0775}); + make_path($tmpdir, {chmod => 0775}); } if ( ! -e $theiadir ) { - make_path($theiadir, {chmod => 0775}); + make_path($theiadir, {chmod => 0775}); } my $json_validator_path = "$WEBOBS{ROOT_CODE}/bin/java/JSON-schema-validation-0-jar-with-dependencies.jar"; if ( ! -e $json_validator_path ) { - die "Please install $json_validator_path\n"; + die "Please install $json_validator_path\n"; } my @zip_files; @@ -85,58 +85,60 @@ sub compressTxtFiles { my %producer; while( my @row = $sth->fetchrow_array() ) { - %producer = ( - producerId => $row[0], - name => decode("utf8", $row[1]), - title => decode("utf8", $row[2]), - description => decode("utf8", $row[3]), - email => $row[6] - ); - if ($row[4] ne "") { - $producer{'objectives'} = decode("utf8", $row[4]); - } - if ($row[5] ne "") { - $producer{'measuredVariables'} = decode("utf8", $row[5]); - } - if ($row[9] ne "") { - # ---- parsing online resources - my %resource; - foreach(split(/_,/, $row[9])) { - my $typeUrl =(split '@', $_)[0]; - my $url = (split '@', $_)[1]; - if ($typeUrl =~ /download/) { - $resource{'urlDownload'} = $url; - } elsif ($typeUrl =~ /info/) { - $resource{'urlInfo'} = $url; - } elsif ($typeUrl =~ /doi/) { - $resource{'doi'} = $url; - } - } - $producer{'onlineResource'} = \%resource; - } - - # ---- extracting contacts data - - my $stmt2 = qq(SELECT * FROM contacts;); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - my @contacts; - - while( my @row2 = $sth2->fetchrow_array() ) { - if ($row2[4] eq $producer{'producerId'}) { - # ---- parsing contacts - my %contact = ( - firstName => decode("utf8", $row2[1]), - lastName => decode("utf8", $row2[2]), - email => $row2[0], - role => $row2[3], - ); - push(@contacts, \%contact); - } - } - - $producer{'contacts'} = \@contacts; + %producer = ( + producerId => $row[0], + name => decode("utf8", $row[1]), + title => decode("utf8", $row[2]), + description => decode("utf8", $row[3]), + email => $row[6] + ); + if ($row[4] ne "") { + $producer{'objectives'} = decode("utf8", $row[4]); + } + if ($row[5] ne "") { + $producer{'measuredVariables'} = decode("utf8", $row[5]); + } + if ($row[9] ne "") { + + # ---- parsing online resources + my %resource; + foreach(split(/_,/, $row[9])) { + my $typeUrl =(split '@', $_)[0]; + my $url = (split '@', $_)[1]; + if ($typeUrl =~ /download/) { + $resource{'urlDownload'} = $url; + } elsif ($typeUrl =~ /info/) { + $resource{'urlInfo'} = $url; + } elsif ($typeUrl =~ /doi/) { + $resource{'doi'} = $url; + } + } + $producer{'onlineResource'} = \%resource; + } + + # ---- extracting contacts data + + my $stmt2 = qq(SELECT * FROM contacts;); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + my @contacts; + + while( my @row2 = $sth2->fetchrow_array() ) { + if ($row2[4] eq $producer{'producerId'}) { + + # ---- parsing contacts + my %contact = ( + firstName => decode("utf8", $row2[1]), + lastName => decode("utf8", $row2[2]), + email => $row2[0], + role => $row2[3], + ); + push(@contacts, \%contact); + } + } + + $producer{'contacts'} = \@contacts; } $stmt = qq(SELECT * FROM organisations;); @@ -146,15 +148,16 @@ sub compressTxtFiles { my @fundings; while( my @row = $sth->fetchrow_array() ) { - # ---- parsing fundings - my %funding = ( - type => $row[0], - iso3166 => $row[1], - idScanR => $row[4], - name => decode("utf8", $row[3]), - acronym => $row[2], - ); - push(@fundings, \%funding); + + # ---- parsing fundings + my %funding = ( + type => $row[0], + iso3166 => $row[1], + idScanR => $row[4], + name => decode("utf8", $row[3]), + acronym => $row[2], + ); + push(@fundings, \%funding); } $producer{'fundings'} = \@fundings; @@ -165,109 +168,111 @@ sub compressTxtFiles { my @observations; foreach (@channels) { - $stmt = "SELECT * FROM observations "; - $stmt .= "INNER JOIN sampling_features ON observations.stationname = sampling_features.identifier "; - $stmt .= "INNER JOIN observed_properties ON observations.observedproperty = observed_properties.identifier"; - $stmt .= " WHERE observations.identifier = '$_'"; - $stmt = qq($stmt); - $sth = $dbh->prepare( $stmt ); - $rv = $sth->execute() or die $DBI::errstr; - - while( my @row = $sth->fetchrow_array() ) { - # print "\n", join(" ", @row[0 .. $#row-6]), "\n"; - # ---- data from observed_properties table - my %observedProperty = ( - name => decode("utf8", $row[13]), - unit => decode("utf8", $row[14]) - ); - - my @theiaCategories; - foreach (split(',', $row[15])) { - $_ =~ s/(\n)//g; - push(@theiaCategories, $_); - } - $observedProperty{"theiaCategories"} = \@theiaCategories; - - #print $observation{'observedProperty'}{'theiaCategories'}->[0]; - # ---- data from sampling_features table - # ---- parsing coordinates - my $geometry = (split ':', $row[11])[1]; - my $position = (split '\(|\)', $geometry)[1]; - my @coordinates = split(',', $position); - $coordinates[0] += 0; - my $lat = $coordinates[0]; - $coordinates[1] += 0; - my $lon = $coordinates[1]; - $coordinates[2] += 0; - my $alt = $coordinates[2]; - - my @new_crds = ($coordinates[1], $coordinates[0]); - - my %geometry = ( - type => (split '\(|\)', $geometry)[0], - coordinates => \@new_crds, - ); - my %samplingFeature = ( - name => $row[6], - geometry => \%geometry, - type => "Feature", - properties => {} - ); - my %featureOfInterest = ( - samplingFeature => \%samplingFeature, - ); - - my $GRIDType = 'PROC'; - my $GRIDName = (split /\./, $row[6])[0]; - my $NODEName = (split /\./, $row[6])[1]; - my $timescale = (split /\_/, $row[8])[-1]; - $timescale = (split /\./, $timescale)[0]; - my %datafile = ( - name => $producer{'producerId'}."_OBS_$GRIDName.$NODEName\_$observedProperty{'name'}.txt", - ); - my %result = ( - dataFile => \%datafile, - ); - - # ---- now generating the .txt file - my $dataname = "$NODEName\_$timescale.txt"; - my $filepath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/exports/"; - my $chan_nb = 5 + $row[16]; - my $obsfile = "$tmpdir/$datafile{'name'}"; - - # ---- generating .txt files for the observed properties - # ---- header - my $header = "#Date_of_extraction;$today;\n"; - $header .= "#Observation_ID;$row[0];\n"; - $header .= "#Dataset_title;;\n"; - $header .= "#Variable_name;".$row[5].";\n"; - $header .= "dateBeg;dateEnd;latitude;longitude;altitude;value;qualityFlags;\n"; - # ---- content - my $content = "grep -v '^#' $filepath$dataname | awk 'FS=\" \" {print \";\"\$1\"-\"\$2\"-\"\$3\"T\"\$4\":\"\$5\":\"\$6\"Z\",\"$lat\",\"$lon\",\"$alt\",\$$chan_nb\";\"}' OFS=\";\""; - $content = qx($content); - $header .= $content; - open(FILE, '>', $obsfile); - print FILE $header; - close(FILE); - - my %temporalExtent = ( - dateBeg => (split '/', $row[3])[0], - dateEnd => (split '/', $row[3])[1], - ); - - my %observation = ( - observationId => $row[0], - observedProperty => \%observedProperty, - featureOfInterest => \%featureOfInterest, - result => \%result, - dataType => $row[2], - timeSerie => \1, - temporalExtent => \%temporalExtent, - processingLevel => $row[1], - ); - - push(@observations, \%observation); - } + $stmt = "SELECT * FROM observations "; + $stmt .= "INNER JOIN sampling_features ON observations.stationname = sampling_features.identifier "; + $stmt .= "INNER JOIN observed_properties ON observations.observedproperty = observed_properties.identifier"; + $stmt .= " WHERE observations.identifier = '$_'"; + $stmt = qq($stmt); + $sth = $dbh->prepare( $stmt ); + $rv = $sth->execute() or die $DBI::errstr; + + while( my @row = $sth->fetchrow_array() ) { + + # print "\n", join(" ", @row[0 .. $#row-6]), "\n"; + # ---- data from observed_properties table + my %observedProperty = ( + name => decode("utf8", $row[13]), + unit => decode("utf8", $row[14]) + ); + + my @theiaCategories; + foreach (split(',', $row[15])) { + $_ =~ s/(\n)//g; + push(@theiaCategories, $_); + } + $observedProperty{"theiaCategories"} = \@theiaCategories; + + #print $observation{'observedProperty'}{'theiaCategories'}->[0]; + # ---- data from sampling_features table + # ---- parsing coordinates + my $geometry = (split ':', $row[11])[1]; + my $position = (split '\(|\)', $geometry)[1]; + my @coordinates = split(',', $position); + $coordinates[0] += 0; + my $lat = $coordinates[0]; + $coordinates[1] += 0; + my $lon = $coordinates[1]; + $coordinates[2] += 0; + my $alt = $coordinates[2]; + + my @new_crds = ($coordinates[1], $coordinates[0]); + + my %geometry = ( + type => (split '\(|\)', $geometry)[0], + coordinates => \@new_crds, + ); + my %samplingFeature = ( + name => $row[6], + geometry => \%geometry, + type => "Feature", + properties => {} + ); + my %featureOfInterest = ( + samplingFeature => \%samplingFeature, + ); + + my $GRIDType = 'PROC'; + my $GRIDName = (split /\./, $row[6])[0]; + my $NODEName = (split /\./, $row[6])[1]; + my $timescale = (split /\_/, $row[8])[-1]; + $timescale = (split /\./, $timescale)[0]; + my %datafile = ( + name => $producer{'producerId'}."_OBS_$GRIDName.$NODEName\_$observedProperty{'name'}.txt", + ); + my %result = ( + dataFile => \%datafile, + ); + + # ---- now generating the .txt file + my $dataname = "$NODEName\_$timescale.txt"; + my $filepath = "$WEBOBS{ROOT_OUTG}/$GRIDType.$GRIDName/exports/"; + my $chan_nb = 5 + $row[16]; + my $obsfile = "$tmpdir/$datafile{'name'}"; + + # ---- generating .txt files for the observed properties + # ---- header + my $header = "#Date_of_extraction;$today;\n"; + $header .= "#Observation_ID;$row[0];\n"; + $header .= "#Dataset_title;;\n"; + $header .= "#Variable_name;".$row[5].";\n"; + $header .= "dateBeg;dateEnd;latitude;longitude;altitude;value;qualityFlags;\n"; + + # ---- content + my $content = "grep -v '^#' $filepath$dataname | awk 'FS=\" \" {print \";\"\$1\"-\"\$2\"-\"\$3\"T\"\$4\":\"\$5\":\"\$6\"Z\",\"$lat\",\"$lon\",\"$alt\",\$$chan_nb\";\"}' OFS=\";\""; + $content = qx($content); + $header .= $content; + open(FILE, '>', $obsfile); + print FILE $header; + close(FILE); + + my %temporalExtent = ( + dateBeg => (split '/', $row[3])[0], + dateEnd => (split '/', $row[3])[1], + ); + + my %observation = ( + observationId => $row[0], + observedProperty => \%observedProperty, + featureOfInterest => \%featureOfInterest, + result => \%result, + dataType => $row[2], + timeSerie => \1, + temporalExtent => \%temporalExtent, + processingLevel => $row[1], + ); + + push(@observations, \%observation); + } } # ---- extracting datasets data @@ -275,120 +280,127 @@ sub compressTxtFiles { my @datasets; foreach (@nodes) { - chomp($_); - $stmt = qq(SELECT * FROM datasets WHERE datasets.identifier = '$_';); - $sth = $dbh->prepare( $stmt ); - $rv = $sth->execute() or die $DBI::errstr; - - while( my @row = $sth->fetchrow_array() ) { - my $datasetId = (split /_DAT_/, $row[0]) [1]; - (my $GRIDName, my $NODEName) = (split /\./, $datasetId); - my %S = readNode($NODEName, "novsub"); - my %NODE = %{$S{$NODEName}}; - my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; - - my $topicCategories = (split '_', $row[2])[0]; - my @topicCategories; - foreach(split('_,', $topicCategories)) { - my $category = (split(':', $_))[1]; - #$category =~ s/(\r\n)//g; - push(@topicCategories, $category); - } - my %geometry = ( - type => JSON->new->utf8->decode($row[3])->{'type'}, - coordinates => JSON->new->utf8->decode($row[3])->{'coordinates'} - ); - my %spatialExtent = ( - type => "Feature", - properties => {}, - geometry => \%geometry, - ); - # print JSON->new->utf8->decode($row[$#row-1])->{'type'}; - my %dataConstraint = ( - accessUseConstraint => "No conditions to access and use", - ); - - my %metadata = ( - title => decode("utf8", $row[1]), - datasetLineage => $row[4], - dataConstraint => \%dataConstraint, - topicCategories => \@topicCategories, - inspireTheme => (split '_inspireTheme:', $row[2])[1], - spatialExtent => \%spatialExtent, - ); - $metadata{'inspireTheme'} =~ s/(\r\n)//g; - $metadata{'description'} = $desc; - - my %dataset = ( - datasetId => $row[0], - ); - - # ---- extracting contacts data - - my $stmt2 = qq(SELECT * FROM contacts;); - my $sth2 = $dbh->prepare( $stmt2 ); - my $rv2 = $sth2->execute() or die $DBI::errstr; - - my @contacts; - while( my @row2 = $sth2->fetchrow_array() ) { - if ($row2[4] eq $dataset{'datasetId'}) { - # ---- parsing contacts - my %contact = ( - firstName => decode("utf8", $row2[1]), - lastName => decode("utf8", $row2[2]), - email => $row2[0], - role => $row2[3], - ); - push(@contacts, \%contact); - } - } - - $metadata{'contacts'} = \@contacts; - $dataset{'metadata'} = \%metadata; - - my @ds_obs; - foreach(@observations) { - if (defined($_->{'observationId'})) { - my $obsId = (split /\./, $_->{'observationId'})[1]; - $obsId = (split /\_/, $obsId)[0]; - my $datId = (split /\./, $row[0])[1]; - if ($obsId eq $datId) { - push(@ds_obs, $_); - my $filename = decode_json encode_json $_->{'result'}->{'dataFile'}->{'name'}; - # ---- adding the title dataset into $filename - # ---- first we open $filename while creating a new $filename where we will write the line we want to insert - open my $in, '<', "$tmpdir/$filename" or die "Can't read old file: $!"; - open my $out, '>', "$tmpdir/$filename.new" or die "Can't write new file: $!"; - my $title = decode("utf8", $row[1]); - while( <$in> ) { - s/Dataset_title;/Dataset_title;$title/; # ---- writing the dataset title in the right row - print $out $_; - } - close $in; - close $out; - rename "$tmpdir/$filename.new", "$tmpdir/$filename"; - } - } - } - - #print encode_json $ds_obs[0]; - $dataset{'observations'} = \@ds_obs; - #print scalar(@{$dataset{'observations'}}), "\n"; - $empty = $dataset{'observations'} ? "yup" : "nope"; - # ---- compressing observations files into OBSE_DAT_PROC.NODE.zip - if ($empty eq "yup") { - if (@{$dataset{'observations'}}) { - push(@datasets, \%dataset); - compressTxtFiles("$dataset{'datasetId'}", $tmpdir) - #or die "$dataset{'datasetId'} needs to be associated with at least one observation !\n"; - } else { - print "$_ was discarded. There are no observations for this dataset!\n"; - } - } else { - compressTxtFiles("$dataset{'datasetId'}", $tmpdir) - or die "zip failed: $ZipError\n"; - } - } + chomp($_); + $stmt = qq(SELECT * FROM datasets WHERE datasets.identifier = '$_';); + $sth = $dbh->prepare( $stmt ); + $rv = $sth->execute() or die $DBI::errstr; + + while( my @row = $sth->fetchrow_array() ) { + my $datasetId = (split /_DAT_/, $row[0]) [1]; + (my $GRIDName, my $NODEName) = (split /\./, $datasetId); + my %S = readNode($NODEName, "novsub"); + my %NODE = %{$S{$NODEName}}; + my $desc = $NODE{"$GRIDType.$GRIDName.DESCRIPTION"}; + + my $topicCategories = (split '_', $row[2])[0]; + my @topicCategories; + foreach(split('_,', $topicCategories)) { + my $category = (split(':', $_))[1]; + + #$category =~ s/(\r\n)//g; + push(@topicCategories, $category); + } + my %geometry = ( + type => JSON->new->utf8->decode($row[3])->{'type'}, + coordinates => JSON->new->utf8->decode($row[3])->{'coordinates'} + ); + my %spatialExtent = ( + type => "Feature", + properties => {}, + geometry => \%geometry, + ); + + # print JSON->new->utf8->decode($row[$#row-1])->{'type'}; + my %dataConstraint = ( + accessUseConstraint => "No conditions to access and use", + ); + + my %metadata = ( + title => decode("utf8", $row[1]), + datasetLineage => $row[4], + dataConstraint => \%dataConstraint, + topicCategories => \@topicCategories, + inspireTheme => (split '_inspireTheme:', $row[2])[1], + spatialExtent => \%spatialExtent, + ); + $metadata{'inspireTheme'} =~ s/(\r\n)//g; + $metadata{'description'} = $desc; + + my %dataset = ( + datasetId => $row[0], + ); + + # ---- extracting contacts data + + my $stmt2 = qq(SELECT * FROM contacts;); + my $sth2 = $dbh->prepare( $stmt2 ); + my $rv2 = $sth2->execute() or die $DBI::errstr; + + my @contacts; + while( my @row2 = $sth2->fetchrow_array() ) { + if ($row2[4] eq $dataset{'datasetId'}) { + + # ---- parsing contacts + my %contact = ( + firstName => decode("utf8", $row2[1]), + lastName => decode("utf8", $row2[2]), + email => $row2[0], + role => $row2[3], + ); + push(@contacts, \%contact); + } + } + + $metadata{'contacts'} = \@contacts; + $dataset{'metadata'} = \%metadata; + + my @ds_obs; + foreach(@observations) { + if (defined($_->{'observationId'})) { + my $obsId = (split /\./, $_->{'observationId'})[1]; + $obsId = (split /\_/, $obsId)[0]; + my $datId = (split /\./, $row[0])[1]; + if ($obsId eq $datId) { + push(@ds_obs, $_); + my $filename = decode_json encode_json $_->{'result'}->{'dataFile'}->{'name'}; + +# ---- adding the title dataset into $filename +# ---- first we open $filename while creating a new $filename where we will write the line we want to insert + open my $in, '<', "$tmpdir/$filename" or die "Can't read old file: $!"; + open my $out, '>', "$tmpdir/$filename.new" or die "Can't write new file: $!"; + my $title = decode("utf8", $row[1]); + while( <$in> ) { + s/Dataset_title;/Dataset_title;$title/; # ---- writing the dataset title in the right row + print $out $_; + } + close $in; + close $out; + rename "$tmpdir/$filename.new", "$tmpdir/$filename"; + } + } + } + + #print encode_json $ds_obs[0]; + $dataset{'observations'} = \@ds_obs; + + #print scalar(@{$dataset{'observations'}}), "\n"; + $empty = $dataset{'observations'} ? "yup" : "nope"; + + # ---- compressing observations files into OBSE_DAT_PROC.NODE.zip + if ($empty eq "yup") { + if (@{$dataset{'observations'}}) { + push(@datasets, \%dataset); + compressTxtFiles("$dataset{'datasetId'}", $tmpdir) + +#or die "$dataset{'datasetId'} needs to be associated with at least one observation !\n"; + } else { + print "$_ was discarded. There are no observations for this dataset!\n"; + } + } else { + compressTxtFiles("$dataset{'datasetId'}", $tmpdir) + or die "zip failed: $ZipError\n"; + } + } } #print encode_json \@datasets; @@ -396,15 +408,16 @@ sub compressTxtFiles { # ---- creating the final json object my %json = ( - producer => \%producer, - datasets => \@datasets, - version => "1.0", -); + producer => \%producer, + datasets => \@datasets, + version => "1.0", + ); $dbh->disconnect(); $filename = "$json{'producer'}{'producerId'}_en.json"; my $filepath = "$tmpdir/$filename"; + #print $cgi->header(-type=>'text/html', -charset=>'utf-8'); #print $filepath; #print encode_json $json{'datasets'}->[0]{'metadata'}{'contacts'}; @@ -426,27 +439,27 @@ sub compressTxtFiles { my $producerId = $producer{'producerId'}; my $zipfile = $producerId . "_THEIA.zip"; if ( $output =~ /success/ ) { - zip [ <$tmpdir/*DAT*.zip>, $filepath ] => "$theiadir/$zipfile", - FilterName => sub { s[^$tmpdir/][] } or die "zip failed: $ZipError\n"; - rmtree($tmpdir); + zip [ <$tmpdir/*DAT*.zip>, $filepath ] => "$theiadir/$zipfile", + FilterName => sub { s[^$tmpdir/][] } or die "zip failed: $ZipError\n"; + rmtree($tmpdir); } else { - print "The JSON metadata file is not valid :\n".$output; + print "The JSON metadata file is not valid :\n".$output; }; # ---- Send archive to Theia/OZCAR if ( $output =~ /success/ ) { - my $url = "https://in-situ.theia-land.fr/data/$producerId/new/"; - my $password = $WEBOBS{PASSWORD_THEIA}; - my $response = qx(curl -T "$theiadir/$zipfile" -u $producerId:$password -s -o /dev/null -w "%{http_code}" $url); - if ( rindex($response,"2", 0) eq 0 ) { - print "Data upload successful. Data are available at https://in-situ.theia-land.fr/data/OBSE/previous/", "\n"; - } - else { - print "Data upload failed: ", $response, "\n"; - die; - } + my $url = "https://in-situ.theia-land.fr/data/$producerId/new/"; + my $password = $WEBOBS{PASSWORD_THEIA}; + my $response = qx(curl -T "$theiadir/$zipfile" -u $producerId:$password -s -o /dev/null -w "%{http_code}" $url); + if ( rindex($response,"2", 0) eq 0 ) { + print "Data upload successful. Data are available at https://in-situ.theia-land.fr/data/OBSE/previous/", "\n"; + } + else { + print "Data upload failed: ", $response, "\n"; + die; + } } #print $observations[1]{'featureOfInterest'}{'samplingFeature'}{'geometry'}{'coordinates'}; diff --git a/CODE/perl/volcauto2mc.pl b/CODE/perl/volcauto2mc.pl index 815ac77c..64c938a9 100755 --- a/CODE/perl/volcauto2mc.pl +++ b/CODE/perl/volcauto2mc.pl @@ -25,11 +25,11 @@ use VolcAuto qw(create_mc3_lock remove_mc3_lock process_autovolc_csv); BEGIN { + # Suppress the default fatalsToBrowser from CGI::Carp $CGI::Carp::TO_BROWSER = 0; } - # ----------------------------------------------------------------------------- # Read script parameters # @@ -38,19 +38,19 @@ BEGIN my $mc3_name = $ARGV[0] || $WEBOBS{'MC3_DEFAULT_NAME'}; my $sefran_name = $ARGV[1] || $WEBOBS{'SEFRAN3_DEFAULT_NAME'}; - # ----------------------------------------------------------------------------- # Make sure the lock will be removed however the script is ended # END { + # Remove the lock (if we've created it ourself) remove_mc3_lock($mc3_name); } + # Handle Ctrl-c event (the END block will then be called) $SIG{'INT'} = sub { say STDERR "SIGINT caught, exiting."; exit(130); }; $SIG{'PIPE'} = sub { say STDERR "SIGPIPE caught, exiting."; exit(141); }; - # ----------------------------------------------------------------------------- # Main instructions diff --git a/CODE/perl/wiki2mmd.pl b/CODE/perl/wiki2mmd.pl index d861cbe5..a92bda4e 100755 --- a/CODE/perl/wiki2mmd.pl +++ b/CODE/perl/wiki2mmd.pl @@ -25,31 +25,30 @@ =head1 DESCRIPTION my $mmd = $WEBOBS{WIKI_MMD} // 'YES'; if ($mmd eq 'NO') { - print "Can't convert, configuration says WIKI_MMD|NO\n"; exit; + print "Can't convert, configuration says WIKI_MMD|NO\n"; exit; } - my $file = $ARGV[0] // ""; my $txt = ""; my $titre = ""; my @lines; if ($file ne "") { - if (!open(FILE, "<$file")) { print "Couldn't read $file\n"; exit; } - @lines = ; - close FILE; + if (!open(FILE, "<$file")) { print "Couldn't read $file\n"; exit; } + @lines = ; + close FILE; } else { print "No filename specified\n"; exit; } # convert if needed, print to stdout # $lines[0] =~ /^TITRE.*\n/ and $titre = $lines[0] and shift(@lines); ($txt, my @meta) = WebObs::Wiki::stripMDmetadata(join("",@lines)); -if (scalar(@meta) == 0) { - $txt = wiki2MMD($txt); - print($titre) if ($titre ne ""); - print "WebObs: converted with wiki2mmd.pl\n\n$txt\n"; -} else { - print "$file already MMD\n" -} +if (scalar(@meta) == 0) { + $txt = wiki2MMD($txt); + print($titre) if ($titre ne ""); + print "WebObs: converted with wiki2mmd.pl\n\n$txt\n"; +} else { + print "$file already MMD\n" +} exit; diff --git a/CODE/perl/woc.pl b/CODE/perl/woc.pl index 8450f020..9cf688ec 100755 --- a/CODE/perl/woc.pl +++ b/CODE/perl/woc.pl @@ -27,7 +27,7 @@ =head1 DESCRIPTION # ------------------------------------------------------------------------------ use strict; use FindBin; -use lib $FindBin::Bin; +use lib $FindBin::Bin; use Data::Dumper; use Term::ReadLine; use POSIX; @@ -44,8 +44,8 @@ =head1 DESCRIPTION use WebObs::Users; use WebObs::Form; our %SCHED; -if (defined($WEBOBS{CONF_SCHEDULER}) && -e $WEBOBS{CONF_SCHEDULER}) - { %SCHED = readCfg($WEBOBS{CONF_SCHEDULER}) } +if (defined($WEBOBS{CONF_SCHEDULER}) && -e $WEBOBS{CONF_SCHEDULER}) +{ %SCHED = readCfg($WEBOBS{CONF_SCHEDULER}) } #$SIG{'INT'} = 'hINT'; $SIG{__WARN__} = 'hWARN'; @@ -57,42 +57,43 @@ =head1 DESCRIPTION # WOC commands definitions/vectors --------------------------------------------- # ------------------------------------------------------------------------------ my %vectors = - ( - '%WEBOBS' => {'rtne' => \&dwebobs, 'seq' => 10, 'auth' => 'R' ,'help' => '%WEBOBS [key] : dump %WEBOBS key or all'}, - '-%WEBOBS' => {'rtne' => \&rwebobs, 'seq' => 20, 'auth' => 'R' ,'help' => '-%WEBOBS value : which %WEBOBS key(s) holds value'}, - '%OWNERS' => {'rtne' => \&downers, 'seq' => 30, 'auth' => 'R' ,'help' => '%OWNERS : dump all %OWNRS'}, - '%DISCP' => {'rtne' => \&ddiscp, 'seq' => 40, 'auth' => 'R' ,'help' => '%DISCP [discp] : dump %DISCP discp discipline or all'}, - '%USERS' => {'rtne' => \&dusers, 'seq' => 50, 'auth' => 'A' ,'help' => '%USERS [login] : dump %USERS login or all'}, - 'authres' => {'rtne' => \&authres, 'seq' => 55, 'auth' => 'A' ,'help' => 'authres : list all \'named\' auth resources'}, - 'user' => {'rtne' => \&dbuser, 'seq' => 60, 'auth' => 'A' ,'help' => 'user login : query DB USERS for login'}, - 'newuser' => {'rtne' => \&siuser, 'seq' => 70, 'auth' => 'A' ,'help' => 'newuser : add a user'}, - 'newgroup' => {'rtne' => \&sigroup, 'seq' => 75, 'auth' => 'A' ,'help' => 'newgroup : add a users group'}, - 'deluser' => {'rtne' => \&sruser, 'seq' => 80, 'auth' => 'A' ,'help' => 'deluser : delete a user'}, - 'delgroup' => {'rtne' => \&srgroup, 'seq' => 85, 'auth' => 'A' ,'help' => 'delgroup : delete a users group'}, - 'grant' => {'rtne' => \&siauth, 'seq' => 90, 'auth' => 'A' ,'help' => 'grant auth : grant access in auth table'}, - 'auth' => {'rtne' => \&duauth, 'seq' => 100, 'auth' => 'A' ,'help' => 'auth login : dump login authorizations'}, - '%NODES' => {'rtne' => \&dnodesc, 'seq' => 110, 'auth' => 'R' ,'help' => '%NODES [key] : dump %NODES key or all'}, - 'proc' => {'rtne' => \&dproc, 'seq' => 120, 'auth' => 'R' ,'help' => 'proc [proc] : dump PROC proc or all'}, - 'form' => {'rtne' => \&dform, 'seq' => 125, 'auth' => 'R' ,'help' => 'form [form] : dump FORM form or all'}, - 'view' => {'rtne' => \&dview, 'seq' => 130, 'auth' => 'R' ,'help' => 'view [view] : dump VIEW view or all'}, - 'node' => {'rtne' => \&dstatn, 'seq' => 140, 'auth' => 'R' ,'help' => 'node [node] : dump NODE node or list node names'}, - 'newnode' => {'rtne' => \&dnnode, 'seq' => 145, 'auth' => 'R' ,'help' => 'newnode node as other : define a new node as othernode'}, - 'delnode' => {'rtne' => \&drmnode, 'seq' => 146, 'auth' => 'R' ,'help' => 'delnode node : delete a node'}, - 'nodegrids' => {'rtne' => \&dstatg, 'seq' => 150, 'auth' => 'R' ,'help' => 'nodegrids [node] : list grids referencing node'}, - 'nodedev' => {'rtne' => \&ddev, 'seq' => 155, 'auth' => 'A' ,'help' => 'nodedev [node] : list features+devices for node (or all dev)' }, - 'statnodes' => {'rtne' => \&statnodes,'seq' => 157, 'auth' => 'R' ,'help' => 'statnodes : statistics on node+grids' }, - 'readcfg' => {'rtne' => \&rc, 'seq' => 190, 'auth' => 'R' ,'help' => 'readcfg file : readCfg file' }, - 'dbjobs' => {'rtne' => \&dbjobs, 'seq' => 195, 'auth' => 'A' ,'help' => 'dbjobs : list all jobs definitions' }, - 'newjob' => {'rtne' => \&sijob, 'seq' => 196, 'auth' => 'A' ,'help' => 'newjob : add a job definition' }, - 'dbruns' => {'rtne' => \&dbruns, 'seq' => 200, 'auth' => 'A' ,'help' => 'dbruns : list all jobs last run info' }, - 'sys' => {'rtne' => \&sys, 'seq' => 300, 'auth' => 'R' ,'help' => 'sys : print system information' }, + ( + '%WEBOBS' => {'rtne' => \&dwebobs, 'seq' => 10, 'auth' => 'R' ,'help' => '%WEBOBS [key] : dump %WEBOBS key or all'}, + '-%WEBOBS' => {'rtne' => \&rwebobs, 'seq' => 20, 'auth' => 'R' ,'help' => '-%WEBOBS value : which %WEBOBS key(s) holds value'}, + '%OWNERS' => {'rtne' => \&downers, 'seq' => 30, 'auth' => 'R' ,'help' => '%OWNERS : dump all %OWNRS'}, + '%DISCP' => {'rtne' => \&ddiscp, 'seq' => 40, 'auth' => 'R' ,'help' => '%DISCP [discp] : dump %DISCP discp discipline or all'}, + '%USERS' => {'rtne' => \&dusers, 'seq' => 50, 'auth' => 'A' ,'help' => '%USERS [login] : dump %USERS login or all'}, + 'authres' => {'rtne' => \&authres, 'seq' => 55, 'auth' => 'A' ,'help' => 'authres : list all \'named\' auth resources'}, + 'user' => {'rtne' => \&dbuser, 'seq' => 60, 'auth' => 'A' ,'help' => 'user login : query DB USERS for login'}, + 'newuser' => {'rtne' => \&siuser, 'seq' => 70, 'auth' => 'A' ,'help' => 'newuser : add a user'}, + 'newgroup' => {'rtne' => \&sigroup, 'seq' => 75, 'auth' => 'A' ,'help' => 'newgroup : add a users group'}, + 'deluser' => {'rtne' => \&sruser, 'seq' => 80, 'auth' => 'A' ,'help' => 'deluser : delete a user'}, + 'delgroup' => {'rtne' => \&srgroup, 'seq' => 85, 'auth' => 'A' ,'help' => 'delgroup : delete a users group'}, + 'grant' => {'rtne' => \&siauth, 'seq' => 90, 'auth' => 'A' ,'help' => 'grant auth : grant access in auth table'}, + 'auth' => {'rtne' => \&duauth, 'seq' => 100, 'auth' => 'A' ,'help' => 'auth login : dump login authorizations'}, + '%NODES' => {'rtne' => \&dnodesc, 'seq' => 110, 'auth' => 'R' ,'help' => '%NODES [key] : dump %NODES key or all'}, + 'proc' => {'rtne' => \&dproc, 'seq' => 120, 'auth' => 'R' ,'help' => 'proc [proc] : dump PROC proc or all'}, + 'form' => {'rtne' => \&dform, 'seq' => 125, 'auth' => 'R' ,'help' => 'form [form] : dump FORM form or all'}, + 'view' => {'rtne' => \&dview, 'seq' => 130, 'auth' => 'R' ,'help' => 'view [view] : dump VIEW view or all'}, + 'node' => {'rtne' => \&dstatn, 'seq' => 140, 'auth' => 'R' ,'help' => 'node [node] : dump NODE node or list node names'}, + 'newnode' => {'rtne' => \&dnnode, 'seq' => 145, 'auth' => 'R' ,'help' => 'newnode node as other : define a new node as othernode'}, + 'delnode' => {'rtne' => \&drmnode, 'seq' => 146, 'auth' => 'R' ,'help' => 'delnode node : delete a node'}, + 'nodegrids' => {'rtne' => \&dstatg, 'seq' => 150, 'auth' => 'R' ,'help' => 'nodegrids [node] : list grids referencing node'}, + 'nodedev' => {'rtne' => \&ddev, 'seq' => 155, 'auth' => 'A' ,'help' => 'nodedev [node] : list features+devices for node (or all dev)' }, + 'statnodes' => {'rtne' => \&statnodes,'seq' => 157, 'auth' => 'R' ,'help' => 'statnodes : statistics on node+grids' }, + 'readcfg' => {'rtne' => \&rc, 'seq' => 190, 'auth' => 'R' ,'help' => 'readcfg file : readCfg file' }, + 'dbjobs' => {'rtne' => \&dbjobs, 'seq' => 195, 'auth' => 'A' ,'help' => 'dbjobs : list all jobs definitions' }, + 'newjob' => {'rtne' => \&sijob, 'seq' => 196, 'auth' => 'A' ,'help' => 'newjob : add a job definition' }, + 'dbruns' => {'rtne' => \&dbruns, 'seq' => 200, 'auth' => 'A' ,'help' => 'dbruns : list all jobs last run info' }, + 'sys' => {'rtne' => \&sys, 'seq' => 300, 'auth' => 'R' ,'help' => 'sys : print system information' }, + # '!' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '! cmd : exec shell cmd (WebObs vars single-quoted for interpolation)' }, # '=' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '= expr : exec perl expr (interactive mode only)' }, - 'dd' => {'rtne' => \&dd, 'seq' => 320, 'auth' => 'A' ,'help' => 'dd : keys of main hashes and their occurence' }, - 'ddxref' => {'rtne' => \&ddx, 'seq' => 321, 'auth' => 'A' ,'help' => 'ddxref : keys of main hashes + their occurence + xref' }, - 'help' => {'rtne' => \&dhelp, 'seq' => 400, 'auth' => 'R' ,'help' => 'help : this help text !' }, - 'quit' => {'rtne' => \&bye, 'seq' => 410, 'auth' => 'R' ,'help' => 'quit : make a guess !' }, - ); + 'dd' => {'rtne' => \&dd, 'seq' => 320, 'auth' => 'A' ,'help' => 'dd : keys of main hashes and their occurence' }, + 'ddxref' => {'rtne' => \&ddx, 'seq' => 321, 'auth' => 'A' ,'help' => 'ddxref : keys of main hashes + their occurence + xref' }, + 'help' => {'rtne' => \&dhelp, 'seq' => 400, 'auth' => 'R' ,'help' => 'help : this help text !' }, + 'quit' => {'rtne' => \&bye, 'seq' => 410, 'auth' => 'R' ,'help' => 'quit : make a guess !' }, + ); # Get system/environment information ------------------------------------------- # ------------------------------------------------------------------------------ @@ -102,47 +103,47 @@ =head1 DESCRIPTION our $localeNum = setlocale(LC_NUMERIC); our @i18nSup = qx(ls $WEBOBS{ROOT_I18N}/locales); chomp(@i18nSup); our $WOCSYS = qx(uname -osrv); - $WOCSYS .= "\"WebObs-$WEBOBS{WEBOBS_ID}\" $WEBOBS{VERSION} [$WOLNK]\n"; - $WOCSYS .= "woc pid $$ started $^T by $WOCusr[0] ($) in ".qx(pwd)."\n"; - $WOCSYS .= "Perl \$^V = $^V \n"; - $WOCSYS .= "\$ENV{PATH} = $ENV{PATH}\n"; - $WOCSYS .= "\@INC : ".join(":",@INC)."\n"; - $WOCSYS .= "\$POSIX::VERSION = ".qq($POSIX::VERSION)."\n"; - $WOCSYS .= "POSIX::tzname = ".join(' ',POSIX::tzname())."\n"; - $WOCSYS .= "\$ENV{TZ} " . (defined($ENV{TZ}) ? "= $ENV{TZ}\n" : "undefined\n"); - $WOCSYS .= "/etc/localtime -> ".qx(tail -1 /etc/localtime); my $tnow = time; - $WOCSYS .= "local now: ".strftime("%Y-%m-%d %H:%M:%S %Z (%z) %s ",localtime($tnow))."($tnow)\n"; - $WOCSYS .= "UTC now: ".strftime("%Y-%m-%d %H:%M:%S %s ",gmtime($tnow))."\n"; - $WOCSYS .= "Environment LC_ALL:$ENV{LC_ALL}, LANGUAGE:$ENV{LANGUAGE}, LC_NUMERIC:$ENV{LC_NUMERIC}, LANG:$ENV{LANG}\n"; - $WOCSYS .= "Perl setlocale LC_ALL:$localeAll"; $WOCSYS .= ", LC_NUMERIC:$localeNum" unless ( $localeAll =~ /\QLC_NUMERIC/); $WOCSYS .= "\n"; - $WOCSYS .= "i18n Available/Installed: "; map {$WOCSYS .= (grep /\Q$_/ , @localeIns) ? "$_ = S/I; " : "$_ = S/?; "} @i18nSup ; $WOCSYS .= "\n"; - $WOCSYS .= sprintf("UMASK %03o\n",umask); - if (defined $ENV{GATEWAY_INTERFACE}) { - $WOCSYS .= "$ENV{REQUEST_URI}\n"; - $WOCSYS .= "HTTP Server = $ENV{SERVER_NAME} [$ENV{SERVER_ADDR}:$ENV{SERVER_PORT}]\n"; - $WOCSYS .= " CGI = $ENV{GATEWAY_INTERFACE}\n"; - $WOCSYS .= " $ENV{SERVER_PROTOCOL} - $ENV{SERVER_SOFTWARE}\n"; - $WOCSYS .= "HTTP User = $ENV{REMOTE_USER} - $ENV{REMOTE_HOST} [$ENV{REMOTE_ADDR}:$ENV{REMOTE_PORT}]\n"; - $WOCSYS .= " AuthType = $ENV{AUTH_TYPE}\n"; - $WOCSYS .= " UserAgent = $ENV{HTTP_USER_AGENT}\n"; - $WOCSYS .= "WEBOBS User = $CLIENT"; - } +$WOCSYS .= "\"WebObs-$WEBOBS{WEBOBS_ID}\" $WEBOBS{VERSION} [$WOLNK]\n"; +$WOCSYS .= "woc pid $$ started $^T by $WOCusr[0] ($) in ".qx(pwd)."\n"; +$WOCSYS .= "Perl \$^V = $^V \n"; +$WOCSYS .= "\$ENV{PATH} = $ENV{PATH}\n"; +$WOCSYS .= "\@INC : ".join(":",@INC)."\n"; +$WOCSYS .= "\$POSIX::VERSION = ".qq($POSIX::VERSION)."\n"; +$WOCSYS .= "POSIX::tzname = ".join(' ',POSIX::tzname())."\n"; +$WOCSYS .= "\$ENV{TZ} " . (defined($ENV{TZ}) ? "= $ENV{TZ}\n" : "undefined\n"); +$WOCSYS .= "/etc/localtime -> ".qx(tail -1 /etc/localtime); my $tnow = time; +$WOCSYS .= "local now: ".strftime("%Y-%m-%d %H:%M:%S %Z (%z) %s ",localtime($tnow))."($tnow)\n"; +$WOCSYS .= "UTC now: ".strftime("%Y-%m-%d %H:%M:%S %s ",gmtime($tnow))."\n"; +$WOCSYS .= "Environment LC_ALL:$ENV{LC_ALL}, LANGUAGE:$ENV{LANGUAGE}, LC_NUMERIC:$ENV{LC_NUMERIC}, LANG:$ENV{LANG}\n"; +$WOCSYS .= "Perl setlocale LC_ALL:$localeAll"; $WOCSYS .= ", LC_NUMERIC:$localeNum" unless ( $localeAll =~ /\QLC_NUMERIC/); $WOCSYS .= "\n"; +$WOCSYS .= "i18n Available/Installed: "; map {$WOCSYS .= (grep /\Q$_/ , @localeIns) ? "$_ = S/I; " : "$_ = S/?; "} @i18nSup ; $WOCSYS .= "\n"; +$WOCSYS .= sprintf("UMASK %03o\n",umask); +if (defined $ENV{GATEWAY_INTERFACE}) { + $WOCSYS .= "$ENV{REQUEST_URI}\n"; + $WOCSYS .= "HTTP Server = $ENV{SERVER_NAME} [$ENV{SERVER_ADDR}:$ENV{SERVER_PORT}]\n"; + $WOCSYS .= " CGI = $ENV{GATEWAY_INTERFACE}\n"; + $WOCSYS .= " $ENV{SERVER_PROTOCOL} - $ENV{SERVER_SOFTWARE}\n"; + $WOCSYS .= "HTTP User = $ENV{REMOTE_USER} - $ENV{REMOTE_HOST} [$ENV{REMOTE_ADDR}:$ENV{REMOTE_PORT}]\n"; + $WOCSYS .= " AuthType = $ENV{AUTH_TYPE}\n"; + $WOCSYS .= " UserAgent = $ENV{HTTP_USER_AGENT}\n"; + $WOCSYS .= "WEBOBS User = $CLIENT"; +} # WOC batch mode if arguments on command line ---------------------------------- # interpret/execute these args as a single woc command and quit # ------------------------------------------------------------------------------ #our @opt = @ARGV; -chomp(@ARGV); +chomp(@ARGV); our @opt = $#ARGV ? @ARGV : split(' ',$ARGV[0]); if (@opt) { - $mode = 'batch'; - ($op,@obj) = @opt; - exit if ($op eq '='); # ignore this one !! - if ( defined($vectors{$op}) ) { - eval { &{$vectors{$op}{rtne}} (@obj) }; - warn() if $@; - } - exit; + $mode = 'batch'; + ($op,@obj) = @opt; + exit if ($op eq '='); # ignore this one !! + if ( defined($vectors{$op}) ) { + eval { &{$vectors{$op}{rtne}} (@obj) }; + warn() if $@; + } + exit; } # WOC interactive mode system setups ------------------------------------------- @@ -154,29 +155,31 @@ =head1 DESCRIPTION our $WOCtmpprefx = glob("~/tmpwoc"); our $WOCwd = qx(pwd); chomp($WOCwd); our $term = new Term::ReadLine 'WebObs Console'; + #our $prompt = "\x1b[38;5;24m "; our $prompt = " "; our $OUT = $term->OUT || \*STDOUT; my $attribs = $term->Attribs; $attribs->{completion_function} = sub { - my ($text, $line, $start) = @_; - my @from = keys(%vectors); - if ($line =~ /^w /) {@from = keys(%WebObs::Config::WEBOBS)} - if ($line =~ /^d /) {@from = keys(%WebObs::Grids::DISCP)} - if ($line =~ /^u /) {@from = keys(%WebObs::Users::USERS)} - return grep(/^$text/, @from); -}; + my ($text, $line, $start) = @_; + my @from = keys(%vectors); + if ($line =~ /^w /) {@from = keys(%WebObs::Config::WEBOBS)} + if ($line =~ /^d /) {@from = keys(%WebObs::Grids::DISCP)} + if ($line =~ /^u /) {@from = keys(%WebObs::Users::USERS)} + return grep(/^$text/, @from); + }; # Signal Handlers -------------------------------------------------------------- # ------------------------------------------------------------------------------ sub hINT { print("Use q at prompt to quit!\n"); - return; + return; } sub hWARN { - my($signal) = @_; - $signal =~ s/\.\.\.caught at.*//g; + my($signal) = @_; + $signal =~ s/\.\.\.caught at.*//g; + #print("\x1b[38;5;88mWOC caught $signal"); print("*** WOC caught $signal"); } @@ -184,11 +187,11 @@ sub hWARN { # yes/no from user ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub yesno { - my $a = ""; - while ($a !~ m/[YN]$/) { - $a = $term->readline("Y/N ? "); - } - return $a; + my $a = ""; + while ($a !~ m/[YN]$/) { + $a = $term->readline("Y/N ? "); + } + return $a; } # ------------------------------------------------------------------------------ @@ -197,697 +200,710 @@ sub yesno { print "\033[2J\033[0;0H"; #clear the screen & jump to 0,0 print "WOC version 1.6, D.Lafon Apr2013\n"; print "At WOC prompt: command , 'help', or 'quit' \n\n"; + #print "\n$WOCSYS\n"; while ( defined ($cmd = $term->readline($prompt)) ) { - chomp($cmd); - $cmd =~ s/(\s)+/ /g; - $cmd =~ s/^[\s]+//g; - ($op,@obj) = split(' ',$cmd); - if (defined($vectors{$op}) ) { - if ($op eq '=') { # ignore vector for this one ! - my $obj = join(' ',@obj); - print "== $obj\n"; - $obj .= ";print '\n'"; # to flush expr output if any - eval $obj; - } - else { - eval { &{$vectors{$op}{rtne}} (@obj) }; - warn() if $@; - $term->addhistory($cmd) if /\S/; - } - } + chomp($cmd); + $cmd =~ s/(\s)+/ /g; + $cmd =~ s/^[\s]+//g; + ($op,@obj) = split(' ',$cmd); + if (defined($vectors{$op}) ) { + if ($op eq '=') { # ignore vector for this one ! + my $obj = join(' ',@obj); + print "== $obj\n"; + $obj .= ";print '\n'"; # to flush expr output if any + eval $obj; + } + else { + eval { &{$vectors{$op}{rtne}} (@obj) }; + warn() if $@; + $term->addhistory($cmd) if /\S/; + } + } } -# End Read-Evaluate-Process Woc Command ---------------------------------------- +# End Read-Evaluate-Process Woc Command ---------------------------------------- # ------------------------------------------------------------------------------ # help command : print from vectors # ------------------------------------------------------------------------------ sub dhelp { - for ( sort {$vectors{$a}->{seq} <=> $vectors{$b}->{seq}} keys %vectors ) { - my $l = $vectors{$_}; - printf( "%s\n", $l->{help} ); - } - print "\n"; + for ( sort {$vectors{$a}->{seq} <=> $vectors{$b}->{seq}} keys %vectors ) { + my $l = $vectors{$_}; + printf( "%s\n", $l->{help} ); + } + print "\n"; } # ------------------------------------------------------------------------------ # system information command: dump system string # ------------------------------------------------------------------------------ sub sys { - print "\n$WOCSYS\n"; + print "\n$WOCSYS\n"; } # ------------------------------------------------------------------------------ # WOC Out Of Date (ie. conf file changes occurred): I can restart myself # ------------------------------------------------------------------------------ sub ood { - if ( $mode eq 'interactive' ) { - print "WOC now out of date, Y to restart\n"; - if (yesno() == 'Y') { - exec( $^X, $WOCmyname, @WOCmyargs); - } - print "\n"; - } + if ( $mode eq 'interactive' ) { + print "WOC now out of date, Y to restart\n"; + if (yesno() == 'Y') { + exec( $^X, $WOCmyname, @WOCmyargs); + } + print "\n"; + } } # ------------------------------------------------------------------------------ # get out of here # ------------------------------------------------------------------------------ sub bye { - print "Bye.\n\n" ; - exit(0); + print "Bye.\n\n" ; + exit(0); } # ------------------------------------------------------------------------------ # execute a system command, with hash variable double-interpolation # ------------------------------------------------------------------------------ sub xsys { - my @obj = @_; - my $obj = join(' ',@obj); - $obj = eval qq!"$obj"!; - print "!= $obj\n"; - system($obj); - printf ("!rc= 0x%.2X\n",$?); + my @obj = @_; + my $obj = join(' ',@obj); + $obj = eval qq!"$obj"!; + print "!= $obj\n"; + system($obj); + printf ("!rc= 0x%.2X\n",$?); } # ------------------------------------------------------------------------------ # dump WEBOBS global ---------------------------------------------------------- # ------------------------------------------------------------------------------ sub dwebobs { - if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, (sort (keys(%WebObs::Config::WEBOBS)))) } - else {@L = (sort (keys(%WebObs::Config::WEBOBS))) } - for (@L) { print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" } - print "\n"; + if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, (sort (keys(%WebObs::Config::WEBOBS)))) } + else {@L = (sort (keys(%WebObs::Config::WEBOBS))) } + for (@L) { print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" } + print "\n"; } # ------------------------------------------------------------------------------ # 'reverse' dump WEBOBS global : which key holds a value ---------------------- # ------------------------------------------------------------------------------ -sub rwebobs { - if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} - my $re = $_[0]; - for (keys(%WebObs::Config::WEBOBS)) { - if ($WebObs::Config::WEBOBS{$_} =~ /$re/) { - print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" ; - } - } - print "\n"; +sub rwebobs { + if (defined($WebObs::Config::WEBOBS_LFN)) {print "[[ \%WEBOBS $WebObs::Config::WEBOBS_LFN ]]\n"} + my $re = $_[0]; + for (keys(%WebObs::Config::WEBOBS)) { + if ($WebObs::Config::WEBOBS{$_} =~ /$re/) { + print "\$WEBOBS\{$_\} => $WebObs::Config::WEBOBS{$_}\n" ; + } + } + print "\n"; } # ------------------------------------------------------------------------------ # raw dump of the hash generated by readCfg on a file ------------------------- # ------------------------------------------------------------------------------ sub rc { - no strict; - $_[0] =~ s/[\$](.*)[\{](.*?)[\}]/$$1{$2}/g; - use strict; - # try to figure out whether hash or array can be read - if (-e $_[0]) { - print "$_[0]\n"; - my @tag=qx(grep -P '^=key' $_[0]); - if ($tag[0]) { - my %F = readCfg($_[0]); - print Dumper(\%F) if (%F); - } else { - my @F = readCfg($_[0]); - print Dumper(\@F) if (@F); - } - } - print "\n"; + no strict; + $_[0] =~ s/[\$](.*)[\{](.*?)[\}]/$$1{$2}/g; + use strict; + + # try to figure out whether hash or array can be read + if (-e $_[0]) { + print "$_[0]\n"; + my @tag=qx(grep -P '^=key' $_[0]); + if ($tag[0]) { + my %F = readCfg($_[0]); + print Dumper(\%F) if (%F); + } else { + my @F = readCfg($_[0]); + print Dumper(\@F) if (@F); + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump %USERS global ---------------------------------------------------------- # ------------------------------------------------------------------------------ -sub dusers { - if (defined($WebObs::Users::USERS_LFN)) {print "[[ \%USERS $WebObs::Users::USERS_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Users::USERS))} - else {@L = keys(%WebObs::Users::USERS)} - for $l (@L) { - print "\$USERS\{$l\} => $WebObs::Users::USERS{$l}\n" ; - for ( keys(%{$WebObs::Users::USERS{$l}}) ) { - print " $_ ==> $WebObs::Users::USERS{$l}{$_}\n"; - } - } - print "\n" +sub dusers { + if (defined($WebObs::Users::USERS_LFN)) {print "[[ \%USERS $WebObs::Users::USERS_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Users::USERS))} + else {@L = keys(%WebObs::Users::USERS)} + for $l (@L) { + print "\$USERS\{$l\} => $WebObs::Users::USERS{$l}\n" ; + for ( keys(%{$WebObs::Users::USERS{$l}}) ) { + print " $_ ==> $WebObs::Users::USERS{$l}{$_}\n"; + } + } + print "\n" } # ------------------------------------------------------------------------------ # list a user's authorizations ------------------------------------------------ # ------------------------------------------------------------------------------ sub duauth { - if (defined($_[0])) { - my %A = WebObs::Users::userListAuth($_[0]); - for (keys(%A)) { print "$_ =>\n"; for ($A{$_}) { for (@$_) {print " @$_\n" } } }; - #print Dumper \%A; - } + if (defined($_[0])) { + my %A = WebObs::Users::userListAuth($_[0]); + for (keys(%A)) { print "$_ =>\n"; for ($A{$_}) { for (@$_) {print " @$_\n" } } }; + + #print Dumper \%A; + } } # ------------------------------------------------------------------------------ # dump %OWNRS global ---------------------------------------------------------- # ------------------------------------------------------------------------------ -sub downers { - if (defined($WebObs::Grids::OWNRS_LFN)) {print "[[ \%OWNRS $WebObs::Grids::OWNRS_LFN ]]\n"} - for (keys(%WebObs::Grids::OWNRS)) { print "\$OWNRS\{$_\} => $WebObs::Grids::OWNRS{$_}\n" } - print "\n"; +sub downers { + if (defined($WebObs::Grids::OWNRS_LFN)) {print "[[ \%OWNRS $WebObs::Grids::OWNRS_LFN ]]\n"} + for (keys(%WebObs::Grids::OWNRS)) { print "\$OWNRS\{$_\} => $WebObs::Grids::OWNRS{$_}\n" } + print "\n"; } # ------------------------------------------------------------------------------ # dump %DISCP global ---------------------------------------------------------- # ------------------------------------------------------------------------------ -sub ddiscp { - if (defined($WebObs::Grids::DISCP_LFN)) {print "[[ \%DISCP $WebObs::Grids::DISCP_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::DISCP))} - else {@L = keys(%WebObs::Grids::DISCP)} - for $l (@L) { - print "\$DISCP\{$l\} => $WebObs::Grids::DISCP{$l}\n" ; - for ( keys(%{$WebObs::Grids::DISCP{$l}})) { - print " $_ ==> $WebObs::Grids::DISCP{$l}{$_}\n"; - } - } - print "\n"; +sub ddiscp { + if (defined($WebObs::Grids::DISCP_LFN)) {print "[[ \%DISCP $WebObs::Grids::DISCP_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::DISCP))} + else {@L = keys(%WebObs::Grids::DISCP)} + for $l (@L) { + print "\$DISCP\{$l\} => $WebObs::Grids::DISCP{$l}\n" ; + for ( keys(%{$WebObs::Grids::DISCP{$l}})) { + print " $_ ==> $WebObs::Grids::DISCP{$l}{$_}\n"; + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump a PROC grid ------------------------------------------------------------ # ------------------------------------------------------------------------------ sub dproc { - my $net; - if (!defined($_[0])) { - my @net = WebObs::Grids::listProcNames(); - for (@net) { print "$_\n" } - } - else { - my %net = WebObs::Grids::readProc($_[0]); - for $l (keys(%net)) { - print "$l\n" ; - for ( keys(%{$net{$l}}) ) { - if (($_ eq 'NODESLIST')) { - my $addr = $net{$l}{$_}; my @w = @$addr; - print " $_ ==>\n"; - for (my $i=0;$i<$#w;$i+=3) { - print " $w[$i] $w[$i+1] $w[$i+2]\n"; - } - } else { - print " $_ ==> $net{$l}{$_}\n"; - } - } - } - } - print "\n"; + my $net; + if (!defined($_[0])) { + my @net = WebObs::Grids::listProcNames(); + for (@net) { print "$_\n" } + } + else { + my %net = WebObs::Grids::readProc($_[0]); + for $l (keys(%net)) { + print "$l\n" ; + for ( keys(%{$net{$l}}) ) { + if (($_ eq 'NODESLIST')) { + my $addr = $net{$l}{$_}; my @w = @$addr; + print " $_ ==>\n"; + for (my $i=0;$i<$#w;$i+=3) { + print " $w[$i] $w[$i+1] $w[$i+2]\n"; + } + } else { + print " $_ ==> $net{$l}{$_}\n"; + } + } + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump a FORM ----------------------------------------------------------------- # ------------------------------------------------------------------------------ sub dform { - if (!defined($_[0])) { - my @lf = qx(ls $WEBOBS{PATH_FORMS}); - chomp(@lf); - for (@lf) { print "$_\n" } - } - else { - my $F = new WebObs::Form($_[0]); - print $F->dump; - } - print "\n"; + if (!defined($_[0])) { + my @lf = qx(ls $WEBOBS{PATH_FORMS}); + chomp(@lf); + for (@lf) { print "$_\n" } + } + else { + my $F = new WebObs::Form($_[0]); + print $F->dump; + } + print "\n"; } # ------------------------------------------------------------------------------ # dump a VIEW grid ------------------------------------------------------------ # ------------------------------------------------------------------------------ sub dview { - my $net; - if (!defined($_[0])) { - my @net = WebObs::Grids::listViewNames(); - for (@net) { print "$_\n" } - } - else { - my %net = WebObs::Grids::readView($_[0]); - for $l (keys(%net)) { - print "$l\n" ; - for ( keys(%{$net{$l}}) ) { - if ($_ eq 'NODESLIST') { - my $addr = $net{$l}{$_}; my @w = @$addr; - print " $_ ==>\n"; - for (my $i=0;$i<$#w;$i+=3) { - print " $w[$i] $w[$i+1] $w[$i+2]\n"; - } - } else { - print " $_ ==> $net{$l}{$_}\n"; - } - } - } - } - print "\n"; + my $net; + if (!defined($_[0])) { + my @net = WebObs::Grids::listViewNames(); + for (@net) { print "$_\n" } + } + else { + my %net = WebObs::Grids::readView($_[0]); + for $l (keys(%net)) { + print "$l\n" ; + for ( keys(%{$net{$l}}) ) { + if ($_ eq 'NODESLIST') { + my $addr = $net{$l}{$_}; my @w = @$addr; + print " $_ ==>\n"; + for (my $i=0;$i<$#w;$i+=3) { + print " $w[$i] $w[$i+1] $w[$i+2]\n"; + } + } else { + print " $_ ==> $net{$l}{$_}\n"; + } + } + } + } + print "\n"; } # ------------------------------------------------------------------------------ # dump NODES configuration ------------------------------------------------ # ------------------------------------------------------------------------------ sub dnodesc { - if (defined($WebObs::Grids::NODES_LFN)) {print "[[ \%NODES $WebObs::Grids::NODES_LFN ]]\n"} - if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::NODES))} - else {@L = keys(%WebObs::Grids::NODES)} - for (@L) { print "\$NODES\{$_\} => $WebObs::Grids::NODES{$_}\n" } - print "\n"; + if (defined($WebObs::Grids::NODES_LFN)) {print "[[ \%NODES $WebObs::Grids::NODES_LFN ]]\n"} + if (defined($_[0])) {@L = grep(/$_[0]/, keys(%WebObs::Grids::NODES))} + else {@L = keys(%WebObs::Grids::NODES)} + for (@L) { print "\$NODES\{$_\} => $WebObs::Grids::NODES{$_}\n" } + print "\n"; } # ------------------------------------------------------------------------------ # dump a NODE ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub dstatn { - my $nodes; - if (!defined($_[0])) { - my @nodes = WebObs::Grids::listNodeNames(); - for (my $i=0; $i $node{$l}{$_}\n"; - } - } - } - print "\n"; + my $nodes; + if (!defined($_[0])) { + my @nodes = WebObs::Grids::listNodeNames(); + for (my $i=0; $i $node{$l}{$_}\n"; + } + } + } + print "\n"; } # ------------------------------------------------------------------------------ # list grids for node(s) --------------------------------------------------- # ------------------------------------------------------------------------------ sub dstatg { - my %s = WebObs::Grids::listNodeGrids(node=>$_[0]); - for (keys(%s)) { - print "$_ :\n"; - if (scalar(@{$s{$_}}) == 0) { print " not in any grid\n"} - else { - for (@{$s{$_}}) { print " $_\n" } - } - print "\n" - } + my %s = WebObs::Grids::listNodeGrids(node=>$_[0]); + for (keys(%s)) { + print "$_ :\n"; + if (scalar(@{$s{$_}}) == 0) { print " not in any grid\n"} + else { + for (@{$s{$_}}) { print " $_\n" } + } + print "\n" + } } # ------------------------------------------------------------------------------ # list all authorization 'named' resources ---------------------------------- # ------------------------------------------------------------------------------ sub authres { - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHPROCS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHPROCS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHVIEWS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHVIEWS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHFORMS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHFORMS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHWIKIS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHWIKIS} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHMISC} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHMISC} where RESOURCE != "*"'); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q,"\n" if (scalar(@q) >0); - - print "\n"; + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHPROCS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHPROCS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHVIEWS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHVIEWS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHFORMS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHFORMS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHWIKIS} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHWIKIS} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + my @q = qx(sqlite3 -separator '' $WEBOBS{SQL_DB_USERS} 'select "$WEBOBS{SQL_TABLE_AUTHMISC} / ",RESOURCE from $WEBOBS{SQL_TABLE_AUTHMISC} where RESOURCE != "*"'); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q,"\n" if (scalar(@q) >0); + + print "\n"; } # ------------------------------------------------------------------------------ # user info from sql ---------------------------------------------------------- # ------------------------------------------------------------------------------ sub dbuser { - my $u = $_[0] ? $_[0] : ''; - if ($u ne '' && defined($USERS{$u}{LOGIN})) { - my $v = $USERS{$u}{UID}; - my @q = qx(sqlite3 -list -separator ',' $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_USERS} where login = '$u' order by login"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - print "\n$WEBOBS{SQL_TABLE_AUTHPROCS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHPROCS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHVIEWS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHVIEWS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHFORMS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHFORMS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHWIKIS}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHWIKIS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_AUTHMISC}: "; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHMISC} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_GROUPS} :"; - my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_GROUPS} where uid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - print "\n$WEBOBS{SQL_TABLE_NOTIFICATIONS} :"; - my @q = qx(sqlite3 -list $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_NOTIFICATIONS} where mailid = '$v' order by 1"); - if ($?) { warn(($?>>8)." - @q"); return; } - if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; - } else { - my @q = qx(sqlite3 -column -header $WEBOBS{SQL_DB_USERS} "select LOGIN, UID from $WEBOBS{SQL_TABLE_USERS}"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - } + my $u = $_[0] ? $_[0] : ''; + if ($u ne '' && defined($USERS{$u}{LOGIN})) { + my $v = $USERS{$u}{UID}; + my @q = qx(sqlite3 -list -separator ',' $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_USERS} where login = '$u' order by login"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + print "\n$WEBOBS{SQL_TABLE_AUTHPROCS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHPROCS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHVIEWS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHVIEWS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHFORMS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHFORMS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHWIKIS}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHWIKIS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_AUTHMISC}: "; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_AUTHMISC} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_GROUPS} :"; + my @q = qx(sqlite3 -column $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_GROUPS} where uid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + print "\n$WEBOBS{SQL_TABLE_NOTIFICATIONS} :"; + my @q = qx(sqlite3 -list $WEBOBS{SQL_DB_USERS} "select * from $WEBOBS{SQL_TABLE_NOTIFICATIONS} where mailid = '$v' order by 1"); + if ($?) { warn(($?>>8)." - @q"); return; } + if (scalar(@q) >0 ) { print "\n@q" } else { print "None\n"}; + } else { + my @q = qx(sqlite3 -column -header $WEBOBS{SQL_DB_USERS} "select LOGIN, UID from $WEBOBS{SQL_TABLE_USERS}"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + } } # ------------------------------------------------------------------------------ # insert new user ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub siuser { - return if ( $mode eq 'batch' && $_[0] eq "" ) ; - dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_USERS},$_[0]); + return if ( $mode eq 'batch' && $_[0] eq "" ) ; + dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_USERS},$_[0]); } # ------------------------------------------------------------------------------ # insert new group ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub sigroup { - return if ( $mode eq 'batch' && $_[0] eq "" ) ; - dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_GROUPS},$_[0]); + return if ( $mode eq 'batch' && $_[0] eq "" ) ; + dbinsert($WEBOBS{SQL_DB_USERS}, $WEBOBS{SQL_TABLE_GROUPS},$_[0]); } # ------------------------------------------------------------------------------ # delete a user --------------------------------------------------------------- # ------------------------------------------------------------------------------ sub sruser { - if (defined($_[0]) && ($_[0] ne "")) { - my $q = "delete from $WEBOBS{SQL_TABLE_USERS} where login = $_[0]"; - print "= $q\n"; - if (yesno() eq 'Y') { - my @q = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "$q" 2>&1); - if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } - ood(); - } - - } + if (defined($_[0]) && ($_[0] ne "")) { + my $q = "delete from $WEBOBS{SQL_TABLE_USERS} where login = $_[0]"; + print "= $q\n"; + if (yesno() eq 'Y') { + my @q = qx(sqlite3 $WEBOBS{SQL_DB_USERS} "$q" 2>&1); + if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } + ood(); + } + + } } # ------------------------------------------------------------------------------ # delete a group --------------------------------------------------------------- # ------------------------------------------------------------------------------ sub srgroup { - if (defined($_[0]) && ($_[0] ne "")) { - my $q = "delete from $WEBOBS{SQL_TABLE_GROUPS} where gid = $_[0]"; - print "= $q\n"; - if (yesno() eq 'Y') { - my @q = qx(sqlite3 $WEBOBS{SQL_DB_GROUPS} "$q" 2>&1); - if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } - ood(); - } - - } + if (defined($_[0]) && ($_[0] ne "")) { + my $q = "delete from $WEBOBS{SQL_TABLE_GROUPS} where gid = $_[0]"; + print "= $q\n"; + if (yesno() eq 'Y') { + my @q = qx(sqlite3 $WEBOBS{SQL_DB_GROUPS} "$q" 2>&1); + if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } + ood(); + } + + } } # ------------------------------------------------------------------------------ # insert new authorization ---------------------------------------------------- # ------------------------------------------------------------------------------ sub siauth { - my ($table, $row) = @_; - return if ( $table eq '' ); - return if ( $mode eq 'batch' && $row eq "" ) ; - dbinsert($WEBOBS{SQL_DB_USERS}, $table, $row); + my ($table, $row) = @_; + return if ( $table eq '' ); + return if ( $mode eq 'batch' && $row eq "" ) ; + dbinsert($WEBOBS{SQL_DB_USERS}, $table, $row); } # ------------------------------------------------------------------------------ # jobs definitions from db --------------------------------------------------- # ------------------------------------------------------------------------------ sub dbjobs { - if ( defined($SCHED{SQL_DB_JOBS}) ) { - my @q = qx(sqlite3 -line $SCHED{SQL_DB_JOBS} "select JID,VALIDITY,XEQ1,XEQ2,XEQ3,RUNINTERVAL,MAXSYSLOAD,LOGPATH from JOBS ORDER by JID"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - } + if ( defined($SCHED{SQL_DB_JOBS}) ) { + my @q = qx(sqlite3 -line $SCHED{SQL_DB_JOBS} "select JID,VALIDITY,XEQ1,XEQ2,XEQ3,RUNINTERVAL,MAXSYSLOAD,LOGPATH from JOBS ORDER by JID"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + } } # ------------------------------------------------------------------------------ # insert new job ------------------------------------------------------------- # ------------------------------------------------------------------------------ sub sijob { - return if ( $mode eq 'batch' && $_[0] eq "" ) ; - dbinsert($SCHED{SQL_DB_JOBS}, "JOBS", $_[0]); + return if ( $mode eq 'batch' && $_[0] eq "" ) ; + dbinsert($SCHED{SQL_DB_JOBS}, "JOBS", $_[0]); } # ------------------------------------------------------------------------------ # jobs last run info from db ------------------------------------------------- # ------------------------------------------------------------------------------ sub dbruns { - if ( defined($SCHED{SQL_DB_JOBS}) ) { - my @q = qx(sqlite3 -column -column -header $SCHED{SQL_DB_JOBS} "select JID,datetime(STARTTS,'unixepoch') as STARTED,datetime(ENDTS,'unixepoch') as ENDED,round(ENDTS-STARTTS,3) as ELAPSED, CMD,STDPATH,RC,RCMSG from RUNS order by STARTTS,JID"); - if ($?) { warn(($?>>8)." - @q"); return; } - print @q; - } + if ( defined($SCHED{SQL_DB_JOBS}) ) { + my @q = qx(sqlite3 -column -column -header $SCHED{SQL_DB_JOBS} "select JID,datetime(STARTTS,'unixepoch') as STARTED,datetime(ENDTS,'unixepoch') as ENDED,round(ENDTS-STARTTS,3) as ELAPSED, CMD,STDPATH,RC,RCMSG from RUNS order by STARTTS,JID"); + if ($?) { warn(($?>>8)." - @q"); return; } + print @q; + } } # ------------------------------------------------------------------------------ # inspect DEVICES the way it is handled by showNODE----------------------------- # ------------------------------------------------------------------------------ sub ddev { - # legacy code to create %liste_liens_fiches : NODES links to other nodes - my @conf_liens_stations = readCfgFile("$NODES{FILE_NODES2NODES}"); - my %liste_liens_fiches; - my $station_parente_old = ""; - my $caracteristique_old = ""; - my $i = 0; - for (@conf_liens_stations) { - my ($station_parente,$caracteristique,$station_fille)=split(/\|/,$_); - if ( $station_parente."|".$caracteristique ne $station_parente_old."|".$caracteristique_old ) { - $i = 0; - } - my $nom_lien = $station_parente."|".$caracteristique; - $liste_liens_fiches{$nom_lien} .= ($i++==0?"":"|").$station_fille; - $station_parente_old = $station_parente; - $caracteristique_old = $caracteristique; - } - - if ($_[0]) { - - my $NODEName = $_[0]; - my $hits = 0; - - print "$NODEName occurences in $NODES{FILE_NODES2NODES} :\n"; - for ( sort keys(%liste_liens_fiches) ) { - my $temp = $_."==>".$liste_liens_fiches{$_}; - if ( $temp =~ m/$NODEName/g ) { print " $temp\n"; $hits++ } - } - if ($hits == 0) { print" NONE!\n"; } + + # legacy code to create %liste_liens_fiches : NODES links to other nodes + my @conf_liens_stations = readCfgFile("$NODES{FILE_NODES2NODES}"); + my %liste_liens_fiches; + my $station_parente_old = ""; + my $caracteristique_old = ""; + my $i = 0; + for (@conf_liens_stations) { + my ($station_parente,$caracteristique,$station_fille)=split(/\|/,$_); + if ( $station_parente."|".$caracteristique ne $station_parente_old."|".$caracteristique_old ) { + $i = 0; + } + my $nom_lien = $station_parente."|".$caracteristique; + $liste_liens_fiches{$nom_lien} .= ($i++==0?"":"|").$station_fille; + $station_parente_old = $station_parente; + $caracteristique_old = $caracteristique; + } + + if ($_[0]) { + + my $NODEName = $_[0]; + my $hits = 0; + + print "$NODEName occurences in $NODES{FILE_NODES2NODES} :\n"; + for ( sort keys(%liste_liens_fiches) ) { + my $temp = $_."==>".$liste_liens_fiches{$_}; + if ( $temp =~ m/$NODEName/g ) { print " $temp\n"; $hits++ } + } + if ($hits == 0) { print" NONE!\n"; } else { - $hits = 0; - # legacy showNODE code for 'parents' - print "$NODEName is a feature of other node in $NODES{FILE_NODES2NODES} :\n"; - my $liens_fiches_parentes = ""; - for my $nom_lien (keys %liste_liens_fiches) { - my @liste_fiches_filles = split(/\|/,$liste_liens_fiches{$nom_lien}); - for (@liste_fiches_filles) { - if ( $_ eq $NODEName ) { - my @data = split(/\|/,$nom_lien); - print " $data[1] of $data[0]\n"; - $hits++; - } - } - } - if ($hits == 0) { print" NONE!\n"; } - - my %NODE = readNode($NODEName); - my $editOK = 1; - # legacy showNODE code "other nodes from NODE's features" - my @listeCarFiles=split(/\|/,$NODE{$_[0]}{FILES_FEATURES}); - $hits = 0; - print "$NODEName has feature(s) in $NODEName.cnf :\n"; - for (@listeCarFiles) { print " '$_'" ; $hits++ } - if ($hits == 0) { print" NONE!"; } - print ("\n"); - - if ($hits > 0) { - my @listeFinaleCarFiles; - my $flag=0; - my %lienNode; - # for each defined features in NODEName.cnf ONLY: - for (@listeCarFiles) { - my $carFileName=$_; - my $carFile="$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; - my $nom_lien = $NODEName."|".$carFileName; - $lienNode{$carFileName} = ""; - my $lien_car = 0; - # if this feature appears in $NODES{FILE_NODES2NODES} ONLY: - # mark this feature as defined in $NODES{FILE_NODES2NODES} (lien_car = 1) - # enter all 'child' nodes definitions for this feature in %lienNode - if ( exists($liste_liens_fiches{$nom_lien}) ) { - my @liste_liens=split(/\|/,$liste_liens_fiches{$nom_lien}); - for (@liste_liens) { - if ( length($_) > 0 ) { - $lienNode{$carFileName} .= $_; - if ( getNodeString(node=>$_) eq "") { $lienNode{$carFileName} .= " (no NodeString) "} - else { $lienNode{$carFileName} .= " " } - # $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "\n").getNodeString(node=>$_); - } - } - #if ( $lienNode{$carFileName} ne "" ) { - # $lienNode{$carFileName} .= "\n\n"; - #} - $lien_car = 1; - } - printf (" %s %s $NODES{FILE_NODES2NODES} , %s\n",$carFileName,($lien_car==1)?"in ":"not in" ,(-e $carFile)?"has $carFile":"has no txt file"); - if ((-e $carFile && (-s $carFile || $editOK == 1)) || $lien_car == 1) { - push(@listeFinaleCarFiles,$carFileName); - } - print " + $lienNode{$carFileName}\n" if ($lienNode{$carFileName} ne ""); - } - printf ("%s feature(s) could show up in showNODE\n",$#listeFinaleCarFiles+1); - for (@listeFinaleCarFiles) { print " $_" } - } - } - } - print("\n"); + $hits = 0; + + # legacy showNODE code for 'parents' + print "$NODEName is a feature of other node in $NODES{FILE_NODES2NODES} :\n"; + my $liens_fiches_parentes = ""; + for my $nom_lien (keys %liste_liens_fiches) { + my @liste_fiches_filles = split(/\|/,$liste_liens_fiches{$nom_lien}); + for (@liste_fiches_filles) { + if ( $_ eq $NODEName ) { + my @data = split(/\|/,$nom_lien); + print " $data[1] of $data[0]\n"; + $hits++; + } + } + } + if ($hits == 0) { print" NONE!\n"; } + + my %NODE = readNode($NODEName); + my $editOK = 1; + + # legacy showNODE code "other nodes from NODE's features" + my @listeCarFiles=split(/\|/,$NODE{$_[0]}{FILES_FEATURES}); + $hits = 0; + print "$NODEName has feature(s) in $NODEName.cnf :\n"; + for (@listeCarFiles) { print " '$_'" ; $hits++ } + if ($hits == 0) { print" NONE!"; } + print ("\n"); + + if ($hits > 0) { + my @listeFinaleCarFiles; + my $flag=0; + my %lienNode; + + # for each defined features in NODEName.cnf ONLY: + for (@listeCarFiles) { + my $carFileName=$_; + my $carFile="$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_FEATURES}/$carFileName.txt"; + my $nom_lien = $NODEName."|".$carFileName; + $lienNode{$carFileName} = ""; + my $lien_car = 0; + + # if this feature appears in $NODES{FILE_NODES2NODES} ONLY: + # mark this feature as defined in $NODES{FILE_NODES2NODES} (lien_car = 1) + # enter all 'child' nodes definitions for this feature in %lienNode + if ( exists($liste_liens_fiches{$nom_lien}) ) { + my @liste_liens=split(/\|/,$liste_liens_fiches{$nom_lien}); + for (@liste_liens) { + if ( length($_) > 0 ) { + $lienNode{$carFileName} .= $_; + if ( getNodeString(node=>$_) eq "") { $lienNode{$carFileName} .= " (no NodeString) "} + else { $lienNode{$carFileName} .= " " } + +# $lienNode{$carFileName} .= ($lienNode{$carFileName} eq "" ? "" : "\n").getNodeString(node=>$_); + } + } + + #if ( $lienNode{$carFileName} ne "" ) { + # $lienNode{$carFileName} .= "\n\n"; + #} + $lien_car = 1; + } + printf (" %s %s $NODES{FILE_NODES2NODES} , %s\n",$carFileName,($lien_car==1)?"in ":"not in" ,(-e $carFile)?"has $carFile":"has no txt file"); + if ((-e $carFile && (-s $carFile || $editOK == 1)) || $lien_car == 1) { + push(@listeFinaleCarFiles,$carFileName); + } + print " + $lienNode{$carFileName}\n" if ($lienNode{$carFileName} ne ""); + } + printf ("%s feature(s) could show up in showNODE\n",$#listeFinaleCarFiles+1); + for (@listeFinaleCarFiles) { print " $_" } + } + } + } + print("\n"); } # ------------------------------------------------------------------------------ # data dictionary for main hashes, + occurences ----------------------------- # ------------------------------------------------------------------------------ sub dd { - my $oldDumperSortkeys = $Data::Dumper::Sortkeys; - my $oldDumperVarname = $Data::Dumper::Varname; - $Data::Dumper::Sortkeys = 1; + my $oldDumperSortkeys = $Data::Dumper::Sortkeys; + my $oldDumperVarname = $Data::Dumper::Varname; + $Data::Dumper::Sortkeys = 1; - my ($nV, %keysView) = ddcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView, "VIEWS"); - my ($nP, %keysProc) = ddcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); - my ($nN, %keysNode) = ddcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); + my ($nV, %keysView) = ddcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView, "VIEWS"); + my ($nP, %keysProc) = ddcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); + my ($nN, %keysNode) = ddcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); - $Data::Dumper::Sortkeys = $oldDumperSortkeys; - $Data::Dumper::Varname = $oldDumperVarname; - print("\n"); + $Data::Dumper::Sortkeys = $oldDumperSortkeys; + $Data::Dumper::Varname = $oldDumperVarname; + print("\n"); } # ------------------------------------------------------------------------------ # data dictionary XREF for main hashes ------------------------ # ------------------------------------------------------------------------------ sub ddx { - - my $oldDumperSortkeys = $Data::Dumper::Sortkeys; - my $oldDumperVarname = $Data::Dumper::Varname; - $Data::Dumper::Sortkeys = 1; - - my ($nV, %keysView) = ddxcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView,"VIEWS"); - ddxrevcore(\%keysView, "views"); - - my ($nV, %keysProc) = ddxcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); - ddxrevcore(\%keysProc, "procs"); - - my ($nV, %keysNode) = ddxcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); - ddxrevcore(\%keysNode, "nodes"); - - my %keysWO; - for my $i (keys(%WEBOBS)) { - if (!exists($keysWO{$i})) { $keysWO{$i}{cgibin} = join(" ",REKCGI($i)); - $keysWO{$i}{matlab} = join(" ",REKMAT($i)); - } - } - print "\n"; - $Data::Dumper::Varname = 'WEBOBS'; - print Dumper \%keysWO; - ddxrevcore(\%keysWO, "webobs"); - -# print"\n**************************************************************\n"; -# print"* xrefs might NOT be comprehensive lists. They are built *\n"; -# print"* using naming/coding conventions & also scan comments. *\n"; -# print"* cgi: 'key' looked for in {key} or {'key'} case insensitive.*\n"; -# print"* mat: 'key' looked for in xx.key, xx 1 or 2 uppercase alpha.*\n"; -# print"**************************************************************\n"; + + my $oldDumperSortkeys = $Data::Dumper::Sortkeys; + my $oldDumperVarname = $Data::Dumper::Varname; + $Data::Dumper::Sortkeys = 1; + + my ($nV, %keysView) = ddxcore(\&WebObs::Grids::listViewNames, \&WebObs::Grids::readView,"VIEWS"); + ddxrevcore(\%keysView, "views"); + + my ($nV, %keysProc) = ddxcore(\&WebObs::Grids::listProcNames, \&WebObs::Grids::readProc,"PROCS"); + ddxrevcore(\%keysProc, "procs"); + + my ($nV, %keysNode) = ddxcore(\&WebObs::Grids::listNodeNames, \&WebObs::Grids::readNode,"NODES"); + ddxrevcore(\%keysNode, "nodes"); + + my %keysWO; + for my $i (keys(%WEBOBS)) { + if (!exists($keysWO{$i})) { $keysWO{$i}{cgibin} = join(" ",REKCGI($i)); + $keysWO{$i}{matlab} = join(" ",REKMAT($i)); + } + } + print "\n"; + $Data::Dumper::Varname = 'WEBOBS'; + print Dumper \%keysWO; + ddxrevcore(\%keysWO, "webobs"); + + # print"\n**************************************************************\n"; + # print"* xrefs might NOT be comprehensive lists. They are built *\n"; + # print"* using naming/coding conventions & also scan comments. *\n"; + # print"* cgi: 'key' looked for in {key} or {'key'} case insensitive.*\n"; + # print"* mat: 'key' looked for in xx.key, xx 1 or 2 uppercase alpha.*\n"; + # print"**************************************************************\n"; } # woc internal helpers functions for dd* commands # ----------------------------------------------- # get number of hash keys and occurences of their keys sub ddcore { - my %GKs; - my ($a1, $a2, $txt) = @_; - my @L = &$a1(); - for my $i (@L) { - my %g = &$a2($i); - for (keys(%{$g{$i}})) { - if (exists($GKs{$_})) { $GKs{$_}++ } - else { $GKs{$_} = 1 } - } - } - print "\n"; - print scalar(@L)." $txt scanned:\n"; - $Data::Dumper::Varname = $txt; - print Dumper \%GKs; - return (scalar(@L), %GKs); + my %GKs; + my ($a1, $a2, $txt) = @_; + my @L = &$a1(); + for my $i (@L) { + my %g = &$a2($i); + for (keys(%{$g{$i}})) { + if (exists($GKs{$_})) { $GKs{$_}++ } + else { $GKs{$_} = 1 } + } + } + print "\n"; + print scalar(@L)." $txt scanned:\n"; + $Data::Dumper::Varname = $txt; + print Dumper \%GKs; + return (scalar(@L), %GKs); } + # get keys occurences in cgi-bins and matlab sub ddxcore { - my %GKs; - my ($a1, $a2, $txt) = @_; - my @L = &$a1(); - for my $i (@L) { - my %g = &$a2($i); - for (keys(%{$g{$i}})) { - if (!exists($GKs{$_})) { $GKs{$_}{cgibin} = join(" ",REKCGI($_)); - $GKs{$_}{matlab} = join(" ",REKMAT($_)); - } - } - } - print "\n"; - print scalar(@L)." $txt scanned:\n"; - $Data::Dumper::Varname = $txt; - print Dumper \%GKs; - return(scalar(@L), %GKs); + my %GKs; + my ($a1, $a2, $txt) = @_; + my @L = &$a1(); + for my $i (@L) { + my %g = &$a2($i); + for (keys(%{$g{$i}})) { + if (!exists($GKs{$_})) { $GKs{$_}{cgibin} = join(" ",REKCGI($_)); + $GKs{$_}{matlab} = join(" ",REKMAT($_)); + } + } + } + print "\n"; + print scalar(@L)." $txt scanned:\n"; + $Data::Dumper::Varname = $txt; + print Dumper \%GKs; + return(scalar(@L), %GKs); } + # get keys reverse xref sub ddxrevcore{ - my $addr = $_[0]; - my %cgi; my %mat; - for my $k (keys(%$addr)) { - for (split(/ /,$$addr{$k}{cgibin})) { - if ($cgi{$_}) {$cgi{$_} .= " ".$k} - else {$cgi{$_} = $k } - } - for (split(/ /,$$addr{$k}{matlab})) { - if ($mat{$_}) {$mat{$_} .= " ".$k} - else {$mat{$_} = $k } - } - } - print "\n"; - print scalar(keys(%cgi))." cgis referencing $_[1]:\n"; - $Data::Dumper::Sortkeys = 1; - $Data::Dumper::Varname = 'CGIs'; - print Dumper \%cgi; - print "\n"; - print scalar(keys(%mat))." matlabs referencing $_[1]:\n"; - $Data::Dumper::Sortkeys = 1; - $Data::Dumper::Varname = 'MATLABs'; - print Dumper \%mat; + my $addr = $_[0]; + my %cgi; my %mat; + for my $k (keys(%$addr)) { + for (split(/ /,$$addr{$k}{cgibin})) { + if ($cgi{$_}) {$cgi{$_} .= " ".$k} + else {$cgi{$_} = $k } + } + for (split(/ /,$$addr{$k}{matlab})) { + if ($mat{$_}) {$mat{$_} .= " ".$k} + else {$mat{$_} = $k } + } + } + print "\n"; + print scalar(keys(%cgi))." cgis referencing $_[1]:\n"; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Varname = 'CGIs'; + print Dumper \%cgi; + print "\n"; + print scalar(keys(%mat))." matlabs referencing $_[1]:\n"; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Varname = 'MATLABs'; + print Dumper \%mat; } + # internal helper to find 'Key' used in CGIs (*.p{l,m}) sub REKCGI { - my $r = '"\{[\'\"]*'; - $r .= $_[0]; - $r .= '[\'\"]*\}"' ; + my $r = '"\{[\'\"]*'; + $r .= $_[0]; + $r .= '[\'\"]*\}"' ; my @qr = qx(grep -P -i -r -l $r $WEBOBS{ROOT_CODE}/cgi-bin/* | grep -v -P "affic|traite|formul|\.svn|\/leg.*\/"); - map {s/$WEBOBS{ROOT_CODE}\/cgi-bin\///} @qr; - chomp(@qr); - return @qr; + map {s/$WEBOBS{ROOT_CODE}\/cgi-bin\///} @qr; + chomp(@qr); + return @qr; } # internal helper to find 'Key' used in matlab (*.m) sub REKMAT { - my $r = '"[A-Z\(\)]{1,2}\.'; - $r .= $_[0]; - $r .= '"' ; + my $r = '"[A-Z\(\)]{1,2}\.'; + $r .= $_[0]; + $r .= '"' ; my @qr = qx(grep -P -r -l $r $WEBOBS{ROOT_CODE}/matlab/*); - map {s/$WEBOBS{ROOT_CODE}\/matlab\///} @qr; - chomp(@qr); - return @qr; + map {s/$WEBOBS{ROOT_CODE}\/matlab\///} @qr; + chomp(@qr); + return @qr; } # ------------------------------------------------------------------------------ @@ -896,113 +912,114 @@ sub REKMAT { # what we look for ... we're after some kind of integrity checking) # ------------------------------------------------------------------------------ sub statnodes { - my @nodes_dir; - my @nodes_nogrid; - my @nodes_noview; - my @nodes_noproc; - opendir(DIR, $NODES{PATH_NODES}); - while (readdir DIR) { push(@nodes_dir, $_) if (substr($_,0,1) ne '.') } - closedir DIR; - foreach (@nodes_dir) { - my %HoA = WebObs::Grids::listNodeGrids(node=>$_); - push(@nodes_nogrid,$_) and next if ( (!%HoA) || scalar(@{$HoA{$_}})==0); - #push(@nodes_noproc,$_) if (! (/^PROC.*/ ~~ @{$HoA{$_}}) ); - push(@nodes_noproc,$_) if (! grep(/^PROC.*/, @{$HoA{$_}}) ); - push(@nodes_noview,$_) if (! grep(/^VIEW.*/, @{$HoA{$_}}) ); - } - printf (" %5u node directories\n",$#nodes_dir+1); - printf (" %5u node%s no grid\n",$#nodes_nogrid+1,($#nodes_nogrid+1>1)?"s have":" has"); - for (my $i=0; $i1)?"s have":" has"); - for (my $i=0; $i1)?"s have":" has"); - for (my $i=0; $i$_); + push(@nodes_nogrid,$_) and next if ( (!%HoA) || scalar(@{$HoA{$_}})==0); + + #push(@nodes_noproc,$_) if (! (/^PROC.*/ ~~ @{$HoA{$_}}) ); + push(@nodes_noproc,$_) if (! grep(/^PROC.*/, @{$HoA{$_}}) ); + push(@nodes_noview,$_) if (! grep(/^VIEW.*/, @{$HoA{$_}}) ); + } + printf (" %5u node directories\n",$#nodes_dir+1); + printf (" %5u node%s no grid\n",$#nodes_nogrid+1,($#nodes_nogrid+1>1)?"s have":" has"); + for (my $i=0; $i1)?"s have":" has"); + for (my $i=0; $i1)?"s have":" has"); + for (my $i=0; $i/dev/null); - if ( $? == 0 ) { - qx(cp $NODES{PATH_NODES}/$_[2]/$_[2].cnf $NODES{PATH_NODES}/$nn/$nn.cnf 2>/dev/null); - if ($? ne 0) { - qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/$gt.$gn.$nn); #rollback - qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback - } else { - qx(sed -i -e 's/\(^NAME.*|\|^ALIAS.*|\|^FDSN.*|\|TRANSMISSI.*|\).*/\1/' $NODES{PATH_NODES}/$nn/$nn.cnf); - } - } else { - qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback - } - } else { - print "couldn't mkdir $NODES{PATH_NODES}/$nn\n"; - } - } - } else { - print "need a 'from node' clause\n"; - } - } - } - else { print "need gridtype.gridname.nodename1 from nodename2\n" } - } + chomp @_; + if (defined($_[0]) && ($_[0] ne "")) { + my ($gt,$gn,$nn) = split(/\.|\//,$_[0]); + if ($nn ne "") { + if (-d "$NODES{PATH_NODES}/$nn") { + print "$nn already exists\n"; + } else { + if ( $_[1] =~ m/as|from/i && defined($_[2]) && $_[2] ne "") { + if ( ! -d "$NODES{PATH_NODES}/$_[2]" ) { + print "$_[2] does not exist\n"; + } else { + qx(mkdir $NODES{PATH_NODES}/$nn ); + if ( $? == 0) { + qx (ln -s $NODES{PATH_NODES}/$nn $WEBOBS{PATH_GRIDS2NODES}/$gt.$gn.$nn 2>/dev/null); + if ( $? == 0 ) { + qx(cp $NODES{PATH_NODES}/$_[2]/$_[2].cnf $NODES{PATH_NODES}/$nn/$nn.cnf 2>/dev/null); + if ($? ne 0) { + qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/$gt.$gn.$nn); #rollback + qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback + } else { + qx(sed -i -e 's/\(^NAME.*|\|^ALIAS.*|\|^FDSN.*|\|TRANSMISSI.*|\).*/\1/' $NODES{PATH_NODES}/$nn/$nn.cnf); + } + } else { + qx(rm -rf $NODES{PATH_NODES}/$nn); #rollback + } + } else { + print "couldn't mkdir $NODES{PATH_NODES}/$nn\n"; + } + } + } else { + print "need a 'from node' clause\n"; + } + } + } + else { print "need gridtype.gridname.nodename1 from nodename2\n" } + } } # ------------------------------------------------------------------------------ # drmnode delete a node ------------------------------------------- # ------------------------------------------------------------------------------ sub drmnode { - chomp @_; - if (defined($_[0]) && ($_[0] ne "")) { - if (-d "$NODES{PATH_NODES}/$_[0]") { - qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/*.*.$_[0]); - qx(rm -rf $NODES{PATH_NODES}/$_[0]); - } - } + chomp @_; + if (defined($_[0]) && ($_[0] ne "")) { + if (-d "$NODES{PATH_NODES}/$_[0]") { + qx(rm -f $WEBOBS{PATH_GRIDS2NODES}/*.*.$_[0]); + qx(rm -rf $NODES{PATH_NODES}/$_[0]); + } + } } # ------------------------------------------------------------------------------ # dbinsert insert a row into a table ------------------------------------------- # ------------------------------------------------------------------------------ sub dbinsert { - my $q; - my ($db, $table, $row) = @_; - my @q = qx(sqlite3 -noheader -list -separator ',' $db "PRAGMA table_info($table)"); - chomp(@q); - my @qt = @q; - foreach (@q) { s/^.*?\,(.*?)\,.*$/$1/g } - foreach (@qt) { s/^.*?\,.*?\,(.*?)\,.*$/$1/g } - for my $i (0..$#q) {if ($qt[$i] eq 'text') {$q[$i] = "'".$q[$i]."'";}} ; - if ($row eq '') { - if ($mode eq 'interactive') { - print "enter new row as: ".join(',',@q)."\n"; - $q = $term->readline("> "); - } - } else { - $q = $row; - } - $q = "insert into $table values($q)"; - print "= $q\n"; - if ($mode eq 'interactive') { - return if (yesno() ne 'Y') - } - @q = qx(sqlite3 $db "$q" 2>&1); - if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } - ood(); + my $q; + my ($db, $table, $row) = @_; + my @q = qx(sqlite3 -noheader -list -separator ',' $db "PRAGMA table_info($table)"); + chomp(@q); + my @qt = @q; + foreach (@q) { s/^.*?\,(.*?)\,.*$/$1/g } + foreach (@qt) { s/^.*?\,.*?\,(.*?)\,.*$/$1/g } + for my $i (0..$#q) {if ($qt[$i] eq 'text') {$q[$i] = "'".$q[$i]."'";}} ; + if ($row eq '') { + if ($mode eq 'interactive') { + print "enter new row as: ".join(',',@q)."\n"; + $q = $term->readline("> "); + } + } else { + $q = $row; + } + $q = "insert into $table values($q)"; + print "= $q\n"; + if ($mode eq 'interactive') { + return if (yesno() ne 'Y') + } + @q = qx(sqlite3 $db "$q" 2>&1); + if ($?) { warn(($?>>8)." - @q"); return } else {print Dumper @q } + ood(); } __END__ diff --git a/CODE/perl/wsudp.pl b/CODE/perl/wsudp.pl index a2695e4a..80d3d8c9 100755 --- a/CODE/perl/wsudp.pl +++ b/CODE/perl/wsudp.pl @@ -72,9 +72,8 @@ =head1 EXIT CODES use WebObs::Scheduler qw(scheduler_client); - sub usage { - print <<"_EOD_"; + print <<"_EOD_"; Usage: perl $0 'msg=>"COMMAND"' ['option=>value' ...] Send a message to a UDP server and print its reply to stdout. @@ -111,57 +110,57 @@ sub usage { } if (not @ARGV) { - usage(); - exit(1); + usage(); + exit(1); } # Options allowed on the command line as => # and the regexp the value must match. my %opts_regexp = ( - 'msg' => '[\w ]+', - 'host' => '[\w.-]+', - 'port' => '\d+', - 'timeout' => '\d+', - 'max_length' => '\d+', -); + 'msg' => '[\w ]+', + 'host' => '[\w.-]+', + 'port' => '\d+', + 'timeout' => '\d+', + 'max_length' => '\d+', + ); # Backward compatibility aliases for options my %compat_aliases = ( - 'to' => 'timeout', - 'll' => 'max_length', -); + 'to' => 'timeout', + 'll' => 'max_length', + ); my %opts = (); # Read and parse arguments from the command line as options foreach my $arg (@ARGV) { - # Read argument as "key => value" - my ($k, $v) = $arg =~ /^\s*([a-z]+)\s*=>\s*(?:'|")?(.+?)(?:'|")?\s*$/; - - if (not $k) { - print STDERR "Error: cannot read arguments, please check their format.\n"; - usage(); - exit(1); - } - - # Apply any option name alias - if ($compat_aliases{$k}) { - $k = $compat_aliases{$k}; - } - - # Make sure option exists and its value has a valid format - if (not $opts_regexp{$k} or $v !~ /$opts_regexp{$k}/) { - print STDERR "Error: invalid argument or format '$arg'\n"; - exit(1); - } - - # Explicitely reject duplicated options - if ($opts{$k}) { - print STDERR "Error: option '$k' defined more than once\n"; - exit(1); - } - $opts{$k} = $v; + # Read argument as "key => value" + my ($k, $v) = $arg =~ /^\s*([a-z]+)\s*=>\s*(?:'|")?(.+?)(?:'|")?\s*$/; + + if (not $k) { + print STDERR "Error: cannot read arguments, please check their format.\n"; + usage(); + exit(1); + } + + # Apply any option name alias + if ($compat_aliases{$k}) { + $k = $compat_aliases{$k}; + } + + # Make sure option exists and its value has a valid format + if (not $opts_regexp{$k} or $v !~ /$opts_regexp{$k}/) { + print STDERR "Error: invalid argument or format '$arg'\n"; + exit(1); + } + + # Explicitely reject duplicated options + if ($opts{$k}) { + print STDERR "Error: option '$k' defined more than once\n"; + exit(1); + } + $opts{$k} = $v; } # Submit the command and read the answer @@ -173,11 +172,11 @@ sub usage { # Use exit code of 1 in case of error, 0 otherwise my $exit_code; if ($error) { - (my $script_name = $0) =~ s|^.*/||; - print STDERR "$script_name error: $error\n"; - $exit_code = 1; + (my $script_name = $0) =~ s|^.*/||; + print STDERR "$script_name error: $error\n"; + $exit_code = 1; } else { - $exit_code = 0; + $exit_code = 0; } exit($exit_code); diff --git a/DOC/devtips/benchcfg.pl b/DOC/devtips/benchcfg.pl index 6640c16e..b311a096 100755 --- a/DOC/devtips/benchcfg.pl +++ b/DOC/devtips/benchcfg.pl @@ -8,21 +8,21 @@ # -10 =approx. 10 seconds cmpthese( -10, { - 'base' => \&cfg, - 'WO' => \&cfg1, - 'WO comp' => \&cfg2, + 'base' => \&cfg, + 'WO' => \&cfg1, + 'WO comp' => \&cfg2, }); sub cfg { - my %X = WebObs::Config::readCfg('/home/didier/wobs/CONF/WEBOBS.rc'); - my %Y = WebObs::Config::readCfg('/home/didier/wobs/CONF/NODES.rc'); + my %X = WebObs::Config::readCfg('/home/didier/wobs/CONF/WEBOBS.rc'); + my %Y = WebObs::Config::readCfg('/home/didier/wobs/CONF/NODES.rc'); } sub cfg1 { - my %X = WebObs::Config::readCfg1('/home/didier/wobs/CONF/WEBOBS.rc'); - my %Y = WebObs::Config::readCfg1('/home/didier/wobs/CONF/NODES.rc'); + my %X = WebObs::Config::readCfg1('/home/didier/wobs/CONF/WEBOBS.rc'); + my %Y = WebObs::Config::readCfg1('/home/didier/wobs/CONF/NODES.rc'); } sub cfg2 { - my %X = WebObs::Config::readCfg2('/home/didier/wobs/CONF/WEBOBS.rc'); - my %Y = WebObs::Config::readCfg2('/home/didier/wobs/CONF/NODES.rc'); + my %X = WebObs::Config::readCfg2('/home/didier/wobs/CONF/WEBOBS.rc'); + my %Y = WebObs::Config::readCfg2('/home/didier/wobs/CONF/NODES.rc'); } diff --git a/DOC/devtips/benchdate.pl b/DOC/devtips/benchdate.pl index 7aae4e6b..d1b1f577 100755 --- a/DOC/devtips/benchdate.pl +++ b/DOC/devtips/benchdate.pl @@ -4,18 +4,18 @@ use Benchmark qw(:all); use POSIX qw(strftime mktime); - # -3 =approx. 3 seconds cmpthese( -3, { - 'date' => \&qxdate, - 'strftime' => \&strf, + 'date' => \&qxdate, + 'strftime' => \&strf, }); sub qxdate { - my $d = qx(date -d "2012-01-01" +"\%B \%Y"); chomp($d); + my $d = qx(date -d "2012-01-01" +"\%B \%Y"); chomp($d); } sub strf { - # mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) - my $t = mktime( 0, 0, 0, 1, 0, 112 ); my $d = strftime("%B %Y", localtime($t)) + + # mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) + my $t = mktime( 0, 0, 0, 1, 0, 112 ); my $d = strftime("%B %Y", localtime($t)) } diff --git a/DOC/devtips/benchfile.pl b/DOC/devtips/benchfile.pl index 97365e65..cf646ecd 100755 --- a/DOC/devtips/benchfile.pl +++ b/DOC/devtips/benchfile.pl @@ -13,68 +13,73 @@ $scalar = slurp( $file ); cmpthese( 1000, { - 'Chas.' => \&chas, - 'Schwern' => \&schwern, - 'brian' => \&brian, - 'Chas. modified' => \&chas_modified, - 'Chas. sane' => \&chas_sane, - 'drewk' => \&drewk, - 'drewk2' => \&drewk2, + 'Chas.' => \&chas, + 'Schwern' => \&schwern, + 'brian' => \&brian, + 'Chas. modified' => \&chas_modified, + 'Chas. sane' => \&chas_sane, + 'drewk' => \&drewk, + 'drewk2' => \&drewk2, }); sub drewk { - my @arr = split(/\n/, $scalar); - my @found; - for(my $i=0; $i<=$#arr; $i+=10){ - # print "drewk[$i] $arr[$i]\n"; - push @found, $arr[$i]; + my @arr = split(/\n/, $scalar); + my @found; + for(my $i=0; $i<=$#arr; $i+=10){ + + # print "drewk[$i] $arr[$i]\n"; + push @found, $arr[$i]; } } sub drewk2 { - my $i=0; - my @found; - foreach(split(/\n/, $scalar)) { - next if $i++ % 10; -# print "drewk2[$i] $_\n"; - push @found, $_; - } + my $i=0; + my @found; + foreach(split(/\n/, $scalar)) { + next if $i++ % 10; + + # print "drewk2[$i] $_\n"; + push @found, $_; + } } sub schwern { my $count = 0; my @found; while($scalar =~ /\G(.*)\n/g) { next if $count++ % 10 != 0; -# print "schwern[$count] $1\n"; + + # print "schwern[$count] $1\n"; push @found, $1; - } } +} sub chas { open my $fh, "<", \$scalar; tie my @lines, "Tie::File", $fh - or die "could not tie in-memory file: $!"; + or die "could not tie in-memory file: $!"; my $i = 0; my @found = (); while (defined $lines[$i]) { + # print "chas[$i]: $lines[$i]\n"; push @found, $lines[$i]; - } continue { - $i += 10; - } + } continue { + $i += 10; } +} sub chas_modified { open my $fh, "<", \$scalar; tie my @lines, "Tie::File", $fh - or die "could not tie in-memory file: $!"; + or die "could not tie in-memory file: $!"; my $highest_multiple = int( $#lines / 10 ) ; - my @found = @lines[ map { $_ * 10 - ($_?1:0) } 0 .. $highest_multiple ]; + my @found = @lines[ map { $_ * 10 - ($_?1:0) } 0 .. $highest_multiple ]; + #print join "\n", @found; - } +} sub chas_sane { open my $fh, "<", \$scalar; @@ -82,18 +87,20 @@ sub chas_sane { my @found; while (my $line = <$fh>) { if ($. == 1 or not $. % 10) { + #print "chas_sane[$.] $line"; push @found, $_; - } } } +} sub brian { open my $fh, '<', \$scalar; my @found = scalar <$fh>; while( <$fh> ) { next if $. % 10; + #print "brian[$.] $_"; push @found, $_; - } } +} diff --git a/DOC/devtips/checkIP.pm b/DOC/devtips/checkIP.pm index 470155a0..ff8e9d15 100755 --- a/DOC/devtips/checkIP.pm +++ b/DOC/devtips/checkIP.pm @@ -5,32 +5,38 @@ use File::Basename; sub checkIP { - my $remoteIP = $_[0]; - my ($id1,$id2,$id3,$id4) = split (/\./,$remoteIP); - my $rangeIP=$id1.".".$id2.".".$id3; - if ( - ( - # Martinique - $rangeIP eq "195.83.190" - || ( - # Guadeloupe - $rangeIP eq "195.83.189" - # sans DHCP ou CDSA - && ($id4 < 150 || $id4 > 230) - ) - ) - # Local - || ($rangeIP eq "127.0.0") - ) { - # Adresse IP interne : OK - return 0 - } else { - # Adresse IP externe : accès refusé ou lecture seule - #return 1 - - # NOUVEAU: checkIP renvoie toujours 0 depuis l'identification par login - return 0 - } + my $remoteIP = $_[0]; + my ($id1,$id2,$id3,$id4) = split (/\./,$remoteIP); + my $rangeIP=$id1.".".$id2.".".$id3; + if ( + ( + + # Martinique + $rangeIP eq "195.83.190" + || ( + + # Guadeloupe + $rangeIP eq "195.83.189" + + # sans DHCP ou CDSA + && ($id4 < 150 || $id4 > 230) + ) + ) + + # Local + || ($rangeIP eq "127.0.0") + ) { + + # Adresse IP interne : OK + return 0 + } else { + + # Adresse IP externe : accès refusé ou lecture seule + #return 1 + + # NOUVEAU: checkIP renvoie toujours 0 depuis l'identification par login + return 0 + } } diff --git a/DOC/devtips/sfork.pl b/DOC/devtips/sfork.pl index c8f6daf6..5c1bcc8e 100755 --- a/DOC/devtips/sfork.pl +++ b/DOC/devtips/sfork.pl @@ -5,7 +5,6 @@ use Time::HiRes qw/time gettimeofday tv_interval usleep/; use POSIX qw/strftime :signal_h :errno_h :sys_wait_h/; - my $kidcmd; my $dcd; my $dcdRC; my $dcdmsg; my $drc; my $redir = ">"; open (MYLOG, '>>/home/lafon/sandbox/sfork.log'); @@ -21,40 +20,42 @@ #$kidcmd="matlab -nodisplay -r 'quit'"; $kidcmd="matlab -nodisplay <<< 'disp(datestr(now));exit(16)'"; -my $kid = fork(); -if (!defined($kid)) { - print MYLOG "$$ couldn't fork [ $kidcmd ] !\n"; +my $kid = fork(); +if (!defined($kid)) { + print MYLOG "$$ couldn't fork [ $kidcmd ] !\n"; } if ($kid == 0) { # kid's code - $drc = qx(lsof -a -p $$ -d0,1,2); - print MYLOG "$drc\n"; - #open STDOUT, $redir, "/home/lafon/sandbox/sfork.out"; - #open STDERR, $redir, "/home/lafon/sandbox/sfork.err"; - open(STDOUT, $redir, "/home/lafon/sandbox/sfork.out") or die "Can't redirect STDOUT: $!"; - open(STDERR, $redir, "/home/lafon/sandbox/sfork.err") or die "Can't redirect STDERR: $!"; - exec "$kidcmd" or logit("$$ couldn't exec [ $kidcmd ]: $!"); -} else { # parent's code continued - print MYLOG "forked $kid [ $kidcmd ]\n"; - my $done=0; - while (!$done) { - usleep(int(300000)); - my $t0 = [gettimeofday]; - while (($dcd = waitpid(-1, &WNOHANG)) > 0) { - my $dcdRC = $?; # default, see below each case - my $dcdmsg = ''; - if ($? == -1) { $dcdmsg = sprintf (" failed to execute: $!"); } - elsif ($? & 127) { - $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); - } - else { - $dcdRC = $? >> 8; - $dcdmsg = sprintf (" %s %d","$dcd exited with ", $dcdRC); - } - #print "reaper: kid($dcd) ?=$?, dcdRC=$dcdRC\n" ; - $done=1; - } - } - print MYLOG "reaper done.\n"; + $drc = qx(lsof -a -p $$ -d0,1,2); + print MYLOG "$drc\n"; + + #open STDOUT, $redir, "/home/lafon/sandbox/sfork.out"; + #open STDERR, $redir, "/home/lafon/sandbox/sfork.err"; + open(STDOUT, $redir, "/home/lafon/sandbox/sfork.out") or die "Can't redirect STDOUT: $!"; + open(STDERR, $redir, "/home/lafon/sandbox/sfork.err") or die "Can't redirect STDERR: $!"; + exec "$kidcmd" or logit("$$ couldn't exec [ $kidcmd ]: $!"); +} else { # parent's code continued + print MYLOG "forked $kid [ $kidcmd ]\n"; + my $done=0; + while (!$done) { + usleep(int(300000)); + my $t0 = [gettimeofday]; + while (($dcd = waitpid(-1, &WNOHANG)) > 0) { + my $dcdRC = $?; # default, see below each case + my $dcdmsg = ''; + if ($? == -1) { $dcdmsg = sprintf (" failed to execute: $!"); } + elsif ($? & 127) { + $dcdmsg = sprintf (" %s %d %s coredump","$dcd died with signal",($? & 127),($? & 128) ? '' : 'no'); + } + else { + $dcdRC = $? >> 8; + $dcdmsg = sprintf (" %s %d","$dcd exited with ", $dcdRC); + } + + #print "reaper: kid($dcd) ?=$?, dcdRC=$dcdRC\n" ; + $done=1; + } + } + print MYLOG "reaper done.\n"; } close MYLOG; diff --git a/SETUP/IMP.pm b/SETUP/IMP.pm index 908a4927..605c6960 100644 --- a/SETUP/IMP.pm +++ b/SETUP/IMP.pm @@ -37,534 +37,542 @@ print " FROM 'reseaux' : $LEG_RESEAUX\n"; print " FROM NODES : $LEG_NODES\n"; print "now logging to console AND IMP.stdout\n\n"; -open (STDOUT, "| tee -ai IMP.stdout"); +open (STDOUT, "| tee -ai IMP.stdout"); print( strftime("\n%F %R ",localtime(time())).$sep."\n"); printf ("dryrun now %s\n",($dry==1)?"ON":"OFF - at your own risk"); # call this to toggle 'dry-run' mode # sub dryrun { - $dry ^= 1; - print( "\n".strftime("%F %R ",localtime(time()))); - printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); + $dry ^= 1; + print( "\n".strftime("%F %R ",localtime(time()))); + printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); } # guess what ... -sub IMPORT0 { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> IMP::MIGRATE0\n"; - $t0 = time; - my (@liste, $i); - $graphFile = $LEG_RESEAUX; - printf("%+6d IMP.0 from %s\n", time-$t0, $graphFile); - - open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; - while() { push(@infoGenerales,$_); } - close(FILE); - - chomp(@infoGenerales); - @infoGenerales = grep(!/^#/, @infoGenerales); - @infoGenerales = grep(!/^$/, @infoGenerales); - - # "DISCIPLINE" --> DISCIPLINES.conf - # - printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); - my @listeMrkD = getTag("DISCIPLINE","mrk"); - my @listeCodesD = getTag("DISCIPLINE","cod"); - my @listeKeyD = getTag("DISCIPLINE","key"); - my @listeOrdD = getTag("DISCIPLINE","ord"); - my @listeNomsD = getTag("DISCIPLINE","nom"); - - my @tlcodes = @listeCodesD; - for $i (0..scalar(@tlcodes)) { - if (exists($DISCP{$tlcodes[$i]})) { - print "imported discipline $tlcodes[$i] already exists...ignored\n"; - splice(@listeCodesD, $i, 1); - } - } - - if (!$dry) { - open(WRT, ">>$FILE_DISCIPLINES"); - $i = 0; - for (@listeCodesD) { - printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); - $i += 1; - } - close(WRT); - } else { print "would update $FILE_DISCIPLINES with codes @listeCodesD\n" }; - - # "OBSERVATOIRE" --> OWNERS.conf - # - printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); - my @listeCodesO = getTag("OBSERVATOIRE","cod"); - my @listeNomsO = getTag("OBSERVATOIRE","nom"); - - my @tlcodes = @listeCodesO; - for $i (0..scalar(@tlcodes)) { - if (exists($OWNRS{$tlcodes[$i]})) { - print "imported owner $tlcodes[$i] already exists...ignored\n"; - splice(@listeCodesO, $i, 1); - } - } - if (!$dry) { - open(WRT, ">>$FILE_OWNERS"); - $i = 0; - for (@listeCodesO) { - printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); - $i += 1; - } - close(WRT); - } else { print "would update $FILE_OWNERS with codes @listeCodesO\n" }; - - # For the migration process, each FORM is identified by an existing - # "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. - # Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and - # a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to - # this FORM. - # Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and - # PROCS definitions of their 'frm' attribute - # +sub IMPORT0 { + print( "\n".strftime("%F %R ",localtime(time()))); + print "> IMP::MIGRATE0\n"; + $t0 = time; + my (@liste, $i); + $graphFile = $LEG_RESEAUX; + printf("%+6d IMP.0 from %s\n", time-$t0, $graphFile); + + open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; + while() { push(@infoGenerales,$_); } + close(FILE); + + chomp(@infoGenerales); + @infoGenerales = grep(!/^#/, @infoGenerales); + @infoGenerales = grep(!/^$/, @infoGenerales); + + # "DISCIPLINE" --> DISCIPLINES.conf + # + printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); + my @listeMrkD = getTag("DISCIPLINE","mrk"); + my @listeCodesD = getTag("DISCIPLINE","cod"); + my @listeKeyD = getTag("DISCIPLINE","key"); + my @listeOrdD = getTag("DISCIPLINE","ord"); + my @listeNomsD = getTag("DISCIPLINE","nom"); + + my @tlcodes = @listeCodesD; + for $i (0..scalar(@tlcodes)) { + if (exists($DISCP{$tlcodes[$i]})) { + print "imported discipline $tlcodes[$i] already exists...ignored\n"; + splice(@listeCodesD, $i, 1); + } + } + + if (!$dry) { + open(WRT, ">>$FILE_DISCIPLINES"); + $i = 0; + for (@listeCodesD) { + printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); + $i += 1; + } + close(WRT); + } else { print "would update $FILE_DISCIPLINES with codes @listeCodesD\n" }; + + # "OBSERVATOIRE" --> OWNERS.conf + # + printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); + my @listeCodesO = getTag("OBSERVATOIRE","cod"); + my @listeNomsO = getTag("OBSERVATOIRE","nom"); + + my @tlcodes = @listeCodesO; + for $i (0..scalar(@tlcodes)) { + if (exists($OWNRS{$tlcodes[$i]})) { + print "imported owner $tlcodes[$i] already exists...ignored\n"; + splice(@listeCodesO, $i, 1); + } + } + if (!$dry) { + open(WRT, ">>$FILE_OWNERS"); + $i = 0; + for (@listeCodesO) { + printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); + $i += 1; + } + close(WRT); + } else { print "would update $FILE_OWNERS with codes @listeCodesO\n" }; + +# For the migration process, each FORM is identified by an existing +# "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. +# Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and +# a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to +# this FORM. +# Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and +# PROCS definitions of their 'frm' attribute +# my %F; - my @formsconfs = qx(ls $LEG_PATH/reseaux*.conf); - for my $f (@formsconfs) { - chomp($f); - # following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) - #my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); - my $ucf = uc($f); - $ucf =~ s!$LEG_PATH/reseaux(.*).conf!$1!gi; - - # ID3 => FORM hash - open(RDR, "<$f") or die "open $f failed: $!\n"; - while() { - chomp; - if (! /^#/) { $F{$_} = $ucf; } - } - close(RDR); - - # FORMNAME directory - printf("%+6d creating %s\n", time-$t0, "$WEBOBS{PATH_FORMS}/$ucf"); - if ($dry) {print "would mkdir -p $WEBOBS{PATH_FORMS}/$ucf\n"} else { qx(mkdir -p $WEBOBS{PATH_FORMS}/$ucf) }; - # build the FORMNAME.conf from WEBOBS.conf related statements - my $pgrep = " \"^$ucf"."_|_"."$ucf\" $LEG_PATH/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; - qx(grep -P $pgrep); - # move the FORM associated files to the brand new FORM/FORMNAME directory - $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $LEG_PATH/WEBOBS.conf"; - my @l = qx(grep -P $pgrep); - for (@l) { - chomp; - s/(^.*\|)//g; - if ($dry) {print "would mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/\n"} else { qx(mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/) }; - } - } - - # NETWORKS --> VIEWS/xxx and PROCS/xxx - # - for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { - my ($res,$code,$value) = split (/\|/,$_); - $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### - $G{$res}{$code} = $value; - } - printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); - for $g (keys (%G)) { - # - # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined - # - if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2 ) { - my @Existing = WebObs::Grids::listProcNames; - if ( ! ($g ~~ @Existing)) { - my $r; - if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; - my $path = "$PATH_PROCS/$g/$g.conf"; - printf("%+6d created %s \n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"NAME|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"RAWDATA|$G{$g}{ftp}\n"); - push(@out,"TZ|$G{$g}{utc}\n"); - push(@out,"TIMESCALELIST|$G{$g}{ext}\n"); - push(@out,"DECIMATELIST|$G{$g}{dec}\n"); - push(@out,"CUMULATELIST|$G{$g}{cum}\n"); - push(@out,"DATESTRLIST|$G{$g}{fmt}\n"); - push(@out,"MARKERSIZELIST|$G{$g}{mks}\n"); - push(@out,"THUMBNAIL|$G{$g}{ico}\n"); - $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); - push(@out,"cro|TBD\n"); - push(@out,"URL|$G{$g}{lnk}\n"); - push(@out,"ddb|$G{$g}{ddb}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - foreach my $k (keys %F) { - if ($o.$c eq $k) { - $formslist .= $F{$k}." " ; - if ($dry) { print "would ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}\n"} else { qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}) }; - } - } - migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); - } - } - } - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"FORM|$formslist\n");} - if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - } - # - # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' - # - if (defined($G{$g}{net}) and $G{$g}{net} != 0) { - my @Existing = WebObs::Grids::lisViewNames; - if ( ! ($g ~~ @Existing)) { - if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { - print "No ID3 (missing obs and/or cod) for $g "; - # my $in = ; - # chomp($in); - # if (length($in) != 3) { - print " - $g skipped, NOT migrated\n"; - next; - # } - # $G{$g}{obs} = substr($in,0,1); - # $G{$g}{cod} = substr($in,1,2); - } - if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; - my $path = "$PATH_VIEWS/$g/$g.conf"; - printf("%+6d created %s\n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"NAME|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"OWNCODE|$G{$g}{obs}\n"); - push(@out,"NODENAME|$G{$g}{snm}\n"); - push(@out,"NODESIZE|$G{$g}{ssz}\n"); - push(@out,"NODERGB|$G{$g}{rvb}\n"); - push(@out,"MAPLIST|$G{$g}{map}\n"); - push(@out,"URL|$G{$g}{htm}\n"); - push(@out,"DISPLAY|$G{$g}{web}\n"); - push(@out,"TYPE|$G{$g}{typ}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # + handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - #foreach my $k (keys %F) { - # if ($o.$c eq $k) { - # $formslist .= $F{$k}." "; - # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); - # } - #} - migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); - } - } - } - my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"FORM|$formslist\n");} - if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - } - } # end for $g (keys (%G)) - - printf("\n\n%+6d M2G.0 summary:\n", time-$t0); - printf(" ------------------\n"); - if (!$dry) { - printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); - printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); - printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); - printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); - print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); - print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); - print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); - for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; - for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; - print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; - } - - printf("\n%+6d M2G.0 done.\n", time-$t0); - #close(STDOUT); - -} + my @formsconfs = qx(ls $LEG_PATH/reseaux*.conf); + for my $f (@formsconfs) { + chomp($f); + +# following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) +#my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); + my $ucf = uc($f); + $ucf =~ s!$LEG_PATH/reseaux(.*).conf!$1!gi; + + # ID3 => FORM hash + open(RDR, "<$f") or die "open $f failed: $!\n"; + while() { + chomp; + if (! /^#/) { $F{$_} = $ucf; } + } + close(RDR); + + # FORMNAME directory + printf("%+6d creating %s\n", time-$t0, "$WEBOBS{PATH_FORMS}/$ucf"); + if ($dry) {print "would mkdir -p $WEBOBS{PATH_FORMS}/$ucf\n"} else { qx(mkdir -p $WEBOBS{PATH_FORMS}/$ucf) }; + + # build the FORMNAME.conf from WEBOBS.conf related statements + my $pgrep = " \"^$ucf"."_|_"."$ucf\" $LEG_PATH/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; + qx(grep -P $pgrep); + + # move the FORM associated files to the brand new FORM/FORMNAME directory + $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $LEG_PATH/WEBOBS.conf"; + my @l = qx(grep -P $pgrep); + for (@l) { + chomp; + s/(^.*\|)//g; + if ($dry) {print "would mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/\n"} else { qx(mv $LEG_PATH/$_ $WEBOBS{PATH_FORMS}/$ucf/) }; + } + } + + # NETWORKS --> VIEWS/xxx and PROCS/xxx + # + for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { + my ($res,$code,$value) = split (/\|/,$_); + $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### + $G{$res}{$code} = $value; + } + printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); + for $g (keys (%G)) { + # + # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined + # + if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2 ) { + my @Existing = WebObs::Grids::listProcNames; + if ( ! ($g ~~ @Existing)) { + my $r; + if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; + my $path = "$PATH_PROCS/$g/$g.conf"; + printf("%+6d created %s \n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"NAME|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"RAWDATA|$G{$g}{ftp}\n"); + push(@out,"TZ|$G{$g}{utc}\n"); + push(@out,"TIMESCALELIST|$G{$g}{ext}\n"); + push(@out,"DECIMATELIST|$G{$g}{dec}\n"); + push(@out,"CUMULATELIST|$G{$g}{cum}\n"); + push(@out,"DATESTRLIST|$G{$g}{fmt}\n"); + push(@out,"MARKERSIZELIST|$G{$g}{mks}\n"); + push(@out,"THUMBNAIL|$G{$g}{ico}\n"); + $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); + push(@out,"cro|TBD\n"); + push(@out,"URL|$G{$g}{lnk}\n"); + push(@out,"ddb|$G{$g}{ddb}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + foreach my $k (keys %F) { + if ($o.$c eq $k) { + $formslist .= $F{$k}." " ; + if ($dry) { print "would ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}\n"} else { qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GRIDS2FORMS}/PROC.$g.$F{$k}) }; + } + } + migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); + } + } + } + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"FORM|$formslist\n");} + if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + } + # + # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' + # + if (defined($G{$g}{net}) and $G{$g}{net} != 0) { + my @Existing = WebObs::Grids::lisViewNames; + if ( ! ($g ~~ @Existing)) { + if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { + print "No ID3 (missing obs and/or cod) for $g "; + + # my $in = ; + # chomp($in); + # if (length($in) != 3) { + print " - $g skipped, NOT migrated\n"; + next; + + # } + # $G{$g}{obs} = substr($in,0,1); + # $G{$g}{cod} = substr($in,1,2); + } + if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; + my $path = "$PATH_VIEWS/$g/$g.conf"; + printf("%+6d created %s\n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"NAME|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"OWNCODE|$G{$g}{obs}\n"); + push(@out,"NODENAME|$G{$g}{snm}\n"); + push(@out,"NODESIZE|$G{$g}{ssz}\n"); + push(@out,"NODERGB|$G{$g}{rvb}\n"); + push(@out,"MAPLIST|$G{$g}{map}\n"); + push(@out,"URL|$G{$g}{htm}\n"); + push(@out,"DISPLAY|$G{$g}{web}\n"); + push(@out,"TYPE|$G{$g}{typ}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # + handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + + #foreach my $k (keys %F) { + # if ($o.$c eq $k) { + # $formslist .= $F{$k}." "; + # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); + # } + #} + migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); + } + } + } + my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"REQUEST|$r\n"); + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"FORM|$formslist\n");} + if ($dislist ne "") { push(@out,"DOMAIN|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + } + } # end for $g (keys (%G)) + + printf("\n\n%+6d M2G.0 summary:\n", time-$t0); + printf(" ------------------\n"); + if (!$dry) { + printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); + printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); + printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); + printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); + print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); + print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); + print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); + for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; + for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; + print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; + } + + printf("\n%+6d M2G.0 done.\n", time-$t0); + + #close(STDOUT); + +} sub MIGRATE_1_NODESXLATE { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_NODESXLATE\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^NOM\|/NAME|/; - s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; - s/^VALIDE\|/VALID\|/; - # next 3 to change | to \| except first one - s/^(.*?)\|/$1¤/; - s/\|/\\\|/g; - s/^(.*?)¤/$1\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_NODESXLATE\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^NOM\|/NAME|/; + s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; + s/^VALIDE\|/VALID\|/; + + # next 3 to change | to \| except first one + s/^(.*?)\|/$1¤/; + s/\|/\\\|/g; + s/^(.*?)¤/$1\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_1_FORMSCONF { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_FORMSCONF\n"; - $t0 = time; - my (@liste, $i); - my @lsd = qx(ls -d $PATH_FORMS/*); - chomp(@lsd); - foreach (@lsd) { - s/.*FORMS\///g; - my $form = $_; - my $prefix = $form."_"; - open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; - my @f = ; - close RDR; - for (@f) { - s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; - s/$prefix//; - } - unshift(@f, "=key|value\n"); # add the new readCfg format-specification - if (!$dry) { - open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; - for (@f) { - print WRT $_; - } - close WRT; - } else { print "would set [\n @f \n] "} - print "$PATH_FORMS/$form/$form.conf done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_FORMSCONF\n"; + $t0 = time; + my (@liste, $i); + my @lsd = qx(ls -d $PATH_FORMS/*); + chomp(@lsd); + foreach (@lsd) { + s/.*FORMS\///g; + my $form = $_; + my $prefix = $form."_"; + open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; + my @f = ; + close RDR; + for (@f) { + s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; + s/$prefix//; + } + unshift(@f, "=key|value\n"); # add the new readCfg format-specification + if (!$dry) { + open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; + for (@f) { + print WRT $_; + } + close WRT; + } else { print "would set [\n @f \n] "} + print "$PATH_FORMS/$form/$form.conf done\n"; + } } sub MIGRATE_2_NODESFEATURES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_2_NODESFEATURES\n"; - $t0 = time; - my @nodes = <$PATH_NODES/*>; - chomp(@nodes); - for my $n (@nodes) { - if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} - die "Couldn't create $n/FEATURES; $!" if ($?); - my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); - die "Couldn't find txt's; $!" if ($?); - chomp(@files); - for my $f (@files) { - if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv $f $n/FEATURES/);} - die "Couldn't move $f to $n/FEATURES; $? " if ($?); - } - print "$n done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_2_NODESFEATURES\n"; + $t0 = time; + my @nodes = <$PATH_NODES/*>; + chomp(@nodes); + for my $n (@nodes) { + if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} + die "Couldn't create $n/FEATURES; $!" if ($?); + my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); + die "Couldn't find txt's; $!" if ($?); + chomp(@files); + for my $f (@files) { + if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv $f $n/FEATURES/);} + die "Couldn't move $f to $n/FEATURES; $? " if ($?); + } + print "$n done\n"; + } } sub MIGRATE_3_FORMSNET2GRIDS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; - my @forms= <$PATH_FORMS/*> ; - foreach (@forms) { - if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } - else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$_.conf") } - my @file = <$_/reseaux*.conf> ; - for my $fn (@file) { - open RDR, "<$fn" or die "Couldn't open $fn : $!"; - my @f = ; - close RDR; - for (@f) { - next if m/^#/ ; - next if m/^$/; - chomp(); - my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); - if (scalar(@res) > 0) { - $res[0] = basename($res[0]); - $res[0] =~ s/\.conf//; - $res[0] =~ s/:.*$//g; - chomp($res[0]); - if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } - else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } - } - } - print "$fn done.\n"; - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; + my @forms= <$PATH_FORMS/*> ; + foreach (@forms) { + if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } + else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$_.conf") } + my @file = <$_/reseaux*.conf> ; + for my $fn (@file) { + open RDR, "<$fn" or die "Couldn't open $fn : $!"; + my @f = ; + close RDR; + for (@f) { + next if m/^#/ ; + next if m/^$/; + chomp(); + my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); + if (scalar(@res) > 0) { + $res[0] = basename($res[0]); + $res[0] =~ s/\.conf//; + $res[0] =~ s/:.*$//g; + chomp($res[0]); + if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } + else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } + } + } + print "$fn done.\n"; + } + } } sub MIGRATE_3_NORMNODES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_NORMNODES\n"; - print "> NOP\n"; + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_NORMNODES\n"; + print "> NOP\n"; } sub MIGRATE_4_ALIASDASH { + # late request: NODEs having their 'ALIAS' or 'DATA_FILE' set to '-' should NOT be included in PROC(s) - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_4_ALIASDASH\n"; - $t0 = time; - my @files = <$PATH_NODES/*/*.cnf>; #/ - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { - my $p = ''; - for (@f) { if (/PROC\|/) { $p = $_ } } ; - chomp($p); - if ($dry) { - print "would sed -ie \'/PROC|/d\' $_" ; - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; - } - else { - qx( sed -ie \'/PROC|/d\' $_ ); - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); - } - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_4_ALIASDASH\n"; + $t0 = time; + my @files = <$PATH_NODES/*/*.cnf>; #/ + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { + my $p = ''; + for (@f) { if (/PROC\|/) { $p = $_ } } ; + chomp($p); + if ($dry) { + print "would sed -ie \'/PROC|/d\' $_" ; + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; + } + else { + qx( sed -ie \'/PROC|/d\' $_ ); + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); + } + } + } } sub MIGRATE_5_FID { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_5_FID\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^DATA_FILE\|/FID|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_5_FID\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^DATA_FILE\|/FID|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } - - # helper function to extract DISCIPLINE & OBSERVATOIRE definitions # sub getTag { - my($stanza, $tag) = @_; - my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); - $l[0] =~ s/^\w\*|\w*\|//gi; - $l[0] =~ s/\'|{|}//gi; - return split(/,/,$l[0]); + my($stanza, $tag) = @_; + my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); + $l[0] =~ s/^\w\*|\w*\|//gi; + $l[0] =~ s/\'|{|}//gi; + return split(/,/,$l[0]); } - # STATIONS (called from main process, for each grid/proc, for which # stations are identified by the 3 digits legacy code 'obs+cod' # 3 arguments: PROC or VIEW ($type) # name of PROC or VIEW ($name) # id 3 digits to identify stations ($id3) sub migID3Stations { - my ($type, $name, $id3, $s1, $s2) = @_; - opendir(DIR, $$WEBOBS{PATH_NODES}) or die "couldn't opendir $WEBOBS{PATH_NODES} : $!"; - my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); - closedir(DIR); - my ($dir, $o); - for $dir (@dirs) { - if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { - if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { - printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "=key|value\n"); - print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - while () { # use all existing lines, replacing ... - s/\s/\|/; # ... 1st blank with | delimiter - print(WRT $_); # - } - print(WRT "$type|$name\n"); # new link to PROC or GRID line - print(WRT "$s1\n"); - if (defined($s2)) { print(WRT "$s2\n") }; - close(WRT); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - } else { - printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - my $typefound=0; - do { - local $^I='~'; - local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); - while(<>){ - chomp; - if (/^($type)\|(.*)/) { - $_ = "$type|$2,$name\n"; - $typefound++; - } - $_ .= "\n"; - print; - } - }; - if ($typefound == 0) { - if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "$type|$name\n"); - close(WRT); - } - } - qx(rm $PATH_NODES/$dir/$dir.cnf~); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - close(RDR); - } - } + my ($type, $name, $id3, $s1, $s2) = @_; + opendir(DIR, $$WEBOBS{PATH_NODES}) or die "couldn't opendir $WEBOBS{PATH_NODES} : $!"; + my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); + closedir(DIR); + my ($dir, $o); + for $dir (@dirs) { + if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { + if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { + printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "=key|value\n"); + print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + while () { # use all existing lines, replacing ... + s/\s/\|/; # ... 1st blank with | delimiter + print(WRT $_); # + } + print(WRT "$type|$name\n"); # new link to PROC or GRID line + print(WRT "$s1\n"); + if (defined($s2)) { print(WRT "$s2\n") }; + close(WRT); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + } else { + printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + my $typefound=0; + do { + local $^I='~'; + local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); + while(<>){ + chomp; + if (/^($type)\|(.*)/) { + $_ = "$type|$2,$name\n"; + $typefound++; + } + $_ .= "\n"; + print; + } + }; + if ($typefound == 0) { + if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "$type|$name\n"); + close(WRT); + } + } + qx(rm $PATH_NODES/$dir/$dir.cnf~); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + close(RDR); + } + } } 1; diff --git a/SETUP/M2G.pm b/SETUP/M2G.pm index e010fedb..ac7a42d6 100644 --- a/SETUP/M2G.pm +++ b/SETUP/M2G.pm @@ -199,25 +199,25 @@ our (@ol, @cl); # batch if arguments on command line --------------------------------------- if (@ARGV) { - my ($op1,$op2) = @ARGV; - $dry = 1; - if ($op1 eq 'do') { $op1 = $op2; $dry = 0 } - my %act = (REAPER => \&REAPER, - MIGRATE0 => \&MIGRATE0, - MIGRATE_1_FORMSCONF => \&MIGRATE_1_FORMSCONF, - MIGRATE_1_NODESXLATE => \&MIGRATE_1_NODESXLATE, - MIGRATE_2_NODESFEATURES => \&MIGRATE_2_NODESFEATURES, - MIGRATE_3_FORMSNET2GRIDS => \&MIGRATE_3_FORMSNET2GRIDS, - MIGRATE_4_ALIASDASH => \&MIGRATE_4_ALIASDASH, - MIGRATE_5_FID => \&MIGRATE_5_FID, - MIGRATE_6_PROCKEYS => \&MIGRATE_6_PROCKEYS, - MIGRATE_6_VIEWKEYS => \&MIGRATE_6_VIEWKEYS); - if ( defined($act{$op1}) ) { - print "dry = $dry , command = $op1\n"; - $act{$op1}->(); - warn() if $@; - } - exit; + my ($op1,$op2) = @ARGV; + $dry = 1; + if ($op1 eq 'do') { $op1 = $op2; $dry = 0 } + my %act = (REAPER => \&REAPER, + MIGRATE0 => \&MIGRATE0, + MIGRATE_1_FORMSCONF => \&MIGRATE_1_FORMSCONF, + MIGRATE_1_NODESXLATE => \&MIGRATE_1_NODESXLATE, + MIGRATE_2_NODESFEATURES => \&MIGRATE_2_NODESFEATURES, + MIGRATE_3_FORMSNET2GRIDS => \&MIGRATE_3_FORMSNET2GRIDS, + MIGRATE_4_ALIASDASH => \&MIGRATE_4_ALIASDASH, + MIGRATE_5_FID => \&MIGRATE_5_FID, + MIGRATE_6_PROCKEYS => \&MIGRATE_6_PROCKEYS, + MIGRATE_6_VIEWKEYS => \&MIGRATE_6_VIEWKEYS); + if ( defined($act{$op1}) ) { + print "dry = $dry , command = $op1\n"; + $act{$op1}->(); + warn() if $@; + } + exit; } # woc interactive, system setups ----------------------------------------------- @@ -247,622 +247,632 @@ print " TO 'new' FORMS : $PATH_FORMS\n"; print " FROM/TO DATA : $PATH_NODES\n"; print "now logging to console AND $confpath/M2G.stdout\n\n"; -open (STDOUT, "| tee -ai $confpath/M2G.stdout"); +open (STDOUT, "| tee -ai $confpath/M2G.stdout"); print( strftime("\n%F %R ",localtime(time())).$sep."\n"); printf ("dryrun now %s\n",($dry==1)?"ON":"OFF - at your own risk"); # call this to toggle 'dry-run' mode # sub dryrun { - $dry ^= 1; - print( "\n".strftime("%F %R ",localtime(time()))); - printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); + $dry ^= 1; + print( "\n".strftime("%F %R ",localtime(time()))); + printf ("dryrun now %s\n\n",($dry==1)?"ON":"OFF - at your own risk"); } # cleanup previous M2G generated files if any. # This DOES NOT ERASE the FORMS directory and its contents sub REAPER { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::REAPER\n"; - my $cmd="rm -rf "; - print "purging VIEWS/ PROCS/ GRIDS2*/ ...\n"; - print $dry?"would $cmd $PATH_VIEWS\n":qx($cmd $PATH_VIEWS); - print $dry?"would $cmd $PATH_PROCS\n":qx($cmd $PATH_PROCS); - #print qx($cmd $WEBOBS{PATH_FORMS}); #cannot easily be undone - print $dry?"would $cmd $PATH_GRIDS2NODES\n":qx($cmd $PATH_GRIDS2NODES); - print $dry?"would $cmd $PATH_GRIDS2FORMS\n":qx($cmd $PATH_GRIDS2FORMS); - print "purging NODES *.cnf* ...\n"; - print $dry?"would $cmd $PATH_NODES/*/*.cnf\n":qx($cmd $PATH_NODES/*/*.cnf); - print $dry?"would $cmd $PATH_NODES/*/*.cnf~\n":qx($cmd $PATH_NODES/*/*.cnf~); - print "Reaper done.\n"; + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::REAPER\n"; + my $cmd="rm -rf "; + print "purging VIEWS/ PROCS/ GRIDS2*/ ...\n"; + print $dry?"would $cmd $PATH_VIEWS\n":qx($cmd $PATH_VIEWS); + print $dry?"would $cmd $PATH_PROCS\n":qx($cmd $PATH_PROCS); + + #print qx($cmd $WEBOBS{PATH_FORMS}); #cannot easily be undone + print $dry?"would $cmd $PATH_GRIDS2NODES\n":qx($cmd $PATH_GRIDS2NODES); + print $dry?"would $cmd $PATH_GRIDS2FORMS\n":qx($cmd $PATH_GRIDS2FORMS); + print "purging NODES *.cnf* ...\n"; + print $dry?"would $cmd $PATH_NODES/*/*.cnf\n":qx($cmd $PATH_NODES/*/*.cnf); + print $dry?"would $cmd $PATH_NODES/*/*.cnf~\n":qx($cmd $PATH_NODES/*/*.cnf~); + print "Reaper done.\n"; } # guess what ... -sub MIGRATE0 { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE0\n"; - $t0 = time; - my (@liste, $i); - $graphFile = $LEG_RESEAUX; - printf("%+6d M2G.0 from %s\n", time-$t0, $graphFile); - - open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; - while() { push(@infoGenerales,$_); } - close(FILE); - - chomp(@infoGenerales); - @infoGenerales = grep(!/^#/, @infoGenerales); - @infoGenerales = grep(!/^$/, @infoGenerales); - - print $dry?"would mkdir -p $PATH_VIEWS\n":qx(mkdir -p $PATH_VIEWS); - print $dry?"would mkdir -p $PATH_PROCS\n":qx(mkdir -p $PATH_PROCS); - print $dry?"would mkdir -p $PATH_FORMS\n":qx(mkdir -p $PATH_FORMS); - print $dry?"would mkdir -p $PATH_GRIDS2NODES\n":qx(mkdir -p $PATH_GRIDS2NODES); - print $dry?"would mkdir -p $PATH_GRIDS2FORMS\n":qx(mkdir -p $PATH_GRIDS2FORMS); - - # "DISCIPLINE" --> DISCIPLINES.conf - # - printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); - my @listeMrkD = getTag("DISCIPLINE","mrk"); - my @listeCodesD = getTag("DISCIPLINE","cod"); - my @listeKeyD = getTag("DISCIPLINE","key"); - my @listeOrdD = getTag("DISCIPLINE","ord"); - my @listeNomsD = getTag("DISCIPLINE","nom"); - - if (!$dry) { - open(WRT, ">$FILE_DISCIPLINES"); - printf(WRT "%s\n","=key|ord|keyword|name|marker"); - printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); - $i = 0; - for (@listeCodesD) { - printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); - $i += 1; - } - close(WRT); - } else { print "would build $FILE_DISCIPLINES with codes @listeCodesD\n" }; - - # "OBSERVATOIRE" --> OWNERS.conf - # - printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); - my @listeCodesO = getTag("OBSERVATOIRE","cod"); - my @listeNomsO = getTag("OBSERVATOIRE","nom"); - - if (!$dry) { - open(WRT, ">$FILE_OWNERS"); - printf(WRT "%s\n","=key|value"); - printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); - $i = 0; - for (@listeCodesO) { - printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); - $i += 1; - } - close(WRT); - } else { print "would build $FILE_OWNERS with codes @listeCodesO\n" }; - - # For the migration process, each FORM is identified by an existing - # "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. - # Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and - # a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to - # this FORM. - # Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and - # PROCS definitions of their 'frm' attribute - # +sub MIGRATE0 { + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE0\n"; + $t0 = time; + my (@liste, $i); + $graphFile = $LEG_RESEAUX; + printf("%+6d M2G.0 from %s\n", time-$t0, $graphFile); + + open(FILE, "<$graphFile") or die "open $graphFile failed: $!\n"; + while() { push(@infoGenerales,$_); } + close(FILE); + + chomp(@infoGenerales); + @infoGenerales = grep(!/^#/, @infoGenerales); + @infoGenerales = grep(!/^$/, @infoGenerales); + + print $dry?"would mkdir -p $PATH_VIEWS\n":qx(mkdir -p $PATH_VIEWS); + print $dry?"would mkdir -p $PATH_PROCS\n":qx(mkdir -p $PATH_PROCS); + print $dry?"would mkdir -p $PATH_FORMS\n":qx(mkdir -p $PATH_FORMS); + print $dry?"would mkdir -p $PATH_GRIDS2NODES\n":qx(mkdir -p $PATH_GRIDS2NODES); + print $dry?"would mkdir -p $PATH_GRIDS2FORMS\n":qx(mkdir -p $PATH_GRIDS2FORMS); + + # "DISCIPLINE" --> DISCIPLINES.conf + # + printf("%+6d DISCIPLINES -> %s\n", time-$t0, $FILE_DISCIPLINES); + my @listeMrkD = getTag("DISCIPLINE","mrk"); + my @listeCodesD = getTag("DISCIPLINE","cod"); + my @listeKeyD = getTag("DISCIPLINE","key"); + my @listeOrdD = getTag("DISCIPLINE","ord"); + my @listeNomsD = getTag("DISCIPLINE","nom"); + + if (!$dry) { + open(WRT, ">$FILE_DISCIPLINES"); + printf(WRT "%s\n","=key|ord|keyword|name|marker"); + printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); + $i = 0; + for (@listeCodesD) { + printf(WRT "%s|%s|%s|%s|%s\n",$listeCodesD[$i],$listeOrdD[$i],$listeKeyD[$i],$listeNomsD[$i],$listeMrkD[$i]); + $i += 1; + } + close(WRT); + } else { print "would build $FILE_DISCIPLINES with codes @listeCodesD\n" }; + + # "OBSERVATOIRE" --> OWNERS.conf + # + printf("%+6d OBSERVATOIRES -> %s\n", time-$t0, $FILE_OWNERS); + my @listeCodesO = getTag("OBSERVATOIRE","cod"); + my @listeNomsO = getTag("OBSERVATOIRE","nom"); + + if (!$dry) { + open(WRT, ">$FILE_OWNERS"); + printf(WRT "%s\n","=key|value"); + printf(WRT "# M2G.0 from %s on %s\n\n",$graphFile,strftime("%Y-%m-%d %H:%M:%S %z",localtime)); + $i = 0; + for (@listeCodesO) { + printf(WRT "%s|%s\n",$listeCodesO[$i],$listeNomsO[$i]); + $i += 1; + } + close(WRT); + } else { print "would build $FILE_OWNERS with codes @listeCodesO\n" }; + +# For the migration process, each FORM is identified by an existing +# "reseaux.conf" file (eg. reseauxGaz.conf) that points to ID3 'networks'. +# Create a subdirectory FORMNAME for each FORM, in $WEBOBS{PATH_FORMS} and +# a FORMNAME.conf file in it, built from the legacy WEBOBS.conf statements related to +# this FORM. +# Then hash (%F) all the ID3 => FORMname relationships, to be later used in VIEWS and +# PROCS definitions of their 'frm' attribute +# my %F; - my @formsconfs = qx(ls $confpath/reseaux*.conf); - for my $f (@formsconfs) { - chomp($f); - # following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) - #my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); - my $ucf = uc($f); - $ucf =~ s!$confpath/reseaux(.*).conf!$1!gi; - - # ID3 => FORM hash - open(RDR, "<$f") or die "open $f failed: $!\n"; - while() { - chomp; - if (! /^#/) { $F{$_} = $ucf; } - } - close(RDR); - - # FORMNAME directory - printf("%+6d creating %s\n", time-$t0, "$PATH_FORMS/$ucf"); - if ($dry) {print "would mkdir -p $PATH_FORMS/$ucf\n"} else { qx(mkdir -p $PATH_FORMS/$ucf) }; - # build the FORMNAME.conf from WEBOBS.conf related statements - my $pgrep = " \"^$ucf"."_|_"."$ucf\" $confpath/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; - qx(grep -P $pgrep); - # move the FORM associated files to the brand new FORM/FORMNAME directory - $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $confpath/WEBOBS.conf"; - my @l = qx(grep -P $pgrep); - for (@l) { - chomp; - s/(^.*\|)//g; - if ($dry) {print "would mv $confpath/$_ $PATH_FORMS/$ucf/\n"} else { qx(mv $confpath/$_ $PATH_FORMS/$ucf/) }; - } - } - - # NETWORKS --> VIEWS/xxx and PROCS/xxx - # - for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { - my ($res,$code,$value) = split (/\|/,$_); - $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### - $G{$res}{$code} = $value; - } - printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); - for $g (keys (%G)) { - # - # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined - # - if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2) { - my $r; - if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; - my $path = "$PATH_PROCS/$g/$g.conf"; - printf("%+6d created %s \n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"nom|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"ftp|$G{$g}{ftp}\n"); - push(@out,"utc|$G{$g}{utc}\n"); - push(@out,"ext|$G{$g}{ext}\n"); - push(@out,"dec|$G{$g}{dec}\n"); - push(@out,"cum|$G{$g}{cum}\n"); - push(@out,"fmt|$G{$g}{fmt}\n"); - push(@out,"mks|$G{$g}{mks}\n"); - push(@out,"ico|$G{$g}{ico}\n"); - $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); - push(@out,"cro|TBD\n"); - push(@out,"lnk|$G{$g}{lnk}\n"); - push(@out,"ddb|$G{$g}{ddb}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - foreach my $k (keys %F) { - if ($o.$c eq $k) { - $formslist .= $F{$k}." " ; - if ($dry) { print "would ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}\n"} else { qx(ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}) }; - } - } - migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); - } - } - } - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"frm|$formslist\n");} - if ($dislist ne "") { push(@out,"dis|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - # - # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' - # - if (defined($G{$g}{net}) and $G{$g}{net} != 0) { - if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { - print "No ID3 (missing obs and/or cod) for $g "; - # my $in = ; - # chomp($in); - # if (length($in) != 3) { - print " - $g skipped, NOT migrated\n"; - next; - # } - # $G{$g}{obs} = substr($in,0,1); - # $G{$g}{cod} = substr($in,1,2); - } - if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; - my $path = "$PATH_VIEWS/$g/$g.conf"; - printf("%+6d created %s\n", time-$t0, $path); - my @out; - no warnings "uninitialized"; - push(@out,"=key|value\n"); - push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - push(@out,"nom|$G{$g}{nom}\n"); - push(@out,"net|$G{$g}{net}\n"); - push(@out,"own|$G{$g}{obs}\n"); - push(@out,"snm|$G{$g}{snm}\n"); - push(@out,"ssz|$G{$g}{ssz}\n"); - push(@out,"rvb|$G{$g}{rvb}\n"); - push(@out,"map|$G{$g}{map}\n"); - push(@out,"htm|$G{$g}{htm}\n"); - push(@out,"web|$G{$g}{web}\n"); - push(@out,"typ|$G{$g}{typ}\n"); - my $legacyID3 = ""; - my $dislist=""; - my $formslist=""; - # + handle {obs} and {cod} that are arrays ! - @ol = split(',',$G{$g}{obs}); - @cl = split(',',$G{$g}{cod}); - for my $o (@ol) { - for my $c (@cl) { - if (length($o.$c) == 3) { - $legacyID3 .= $o.$c." "; - $dislist .= substr($c,0,1)." "; - #foreach my $k (keys %F) { - # if ($o.$c eq $k) { - # $formslist .= $F{$k}." "; - # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); - # } - #} - migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); - } - } - } - my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); - if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} - if ($formslist ne "") { push(@out,"frm|$formslist\n");} - if ($dislist ne "") { push(@out,"dis|$dislist\n");} - if (!$dry) { - open(WRT, ">$path"); - print WRT @out ; - close(WRT); - } - } - } # end for $g (keys (%G)) - - printf("\n\n%+6d M2G.0 summary:\n", time-$t0); - printf(" ------------------\n"); - if (!$dry) { - printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); - printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); - printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); - printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); - print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); - print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); - print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); - for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; - for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; - print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; - } - - printf("\n%+6d M2G.0 done.\n", time-$t0); - #close(STDOUT); - -} + my @formsconfs = qx(ls $confpath/reseaux*.conf); + for my $f (@formsconfs) { + chomp($f); + +# following $ucf assignment only under perl 5.14 ('r' modifier = non-destructive) +#my $ucf = uc($f =~ s!$confpath/reseaux(.*).conf!$1!gr); + my $ucf = uc($f); + $ucf =~ s!$confpath/reseaux(.*).conf!$1!gi; + + # ID3 => FORM hash + open(RDR, "<$f") or die "open $f failed: $!\n"; + while() { + chomp; + if (! /^#/) { $F{$_} = $ucf; } + } + close(RDR); + + # FORMNAME directory + printf("%+6d creating %s\n", time-$t0, "$PATH_FORMS/$ucf"); + if ($dry) {print "would mkdir -p $PATH_FORMS/$ucf\n"} else { qx(mkdir -p $PATH_FORMS/$ucf) }; + + # build the FORMNAME.conf from WEBOBS.conf related statements + my $pgrep = " \"^$ucf"."_|_"."$ucf\" $confpath/WEBOBS.conf >$PATH_FORMS/$ucf/$ucf.conf"; + qx(grep -P $pgrep); + + # move the FORM associated files to the brand new FORM/FORMNAME directory + $pgrep = " \"^$ucf"."_FILE_.*\\\|.*.conf\" $confpath/WEBOBS.conf"; + my @l = qx(grep -P $pgrep); + for (@l) { + chomp; + s/(^.*\|)//g; + if ($dry) {print "would mv $confpath/$_ $PATH_FORMS/$ucf/\n"} else { qx(mv $confpath/$_ $PATH_FORMS/$ucf/) }; + } + } + + # NETWORKS --> VIEWS/xxx and PROCS/xxx + # + for (grep(!/^OBSERVATOIRE|^DISCIPLINE|^TYPERESEAU/,@infoGenerales)) { + my ($res,$code,$value) = split (/\|/,$_); + $value =~ s/[\[\]{}']//g; ### the quotes & brackets blind reaper ### + $G{$res}{$code} = $value; + } + printf("%+6d Start processing %d 'networks'\n", time-$t0, scalar(keys %G)); + for $g (keys (%G)) { + # + # PROCS: legacy-network $g ==> PROCS/$g if it has 'ext' defined + # + if (defined($G{$g}{ext}) and length($G{$g}{ext}) > 2) { + my $r; + if ($dry) {print "would mkdir -p $PATH_PROCS/$g\n"} else { qx(mkdir -p $PATH_PROCS/$g) }; + my $path = "$PATH_PROCS/$g/$g.conf"; + printf("%+6d created %s \n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"nom|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"ftp|$G{$g}{ftp}\n"); + push(@out,"utc|$G{$g}{utc}\n"); + push(@out,"ext|$G{$g}{ext}\n"); + push(@out,"dec|$G{$g}{dec}\n"); + push(@out,"cum|$G{$g}{cum}\n"); + push(@out,"fmt|$G{$g}{fmt}\n"); + push(@out,"mks|$G{$g}{mks}\n"); + push(@out,"ico|$G{$g}{ico}\n"); + $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); + push(@out,"cro|TBD\n"); + push(@out,"lnk|$G{$g}{lnk}\n"); + push(@out,"ddb|$G{$g}{ddb}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + foreach my $k (keys %F) { + if ($o.$c eq $k) { + $formslist .= $F{$k}." " ; + if ($dry) { print "would ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}\n"} else { qx(ln -s $PATH_FORMS/$F{$k} $PATH_GRIDS2FORMS/PROC.$g.$F{$k}) }; + } + } + migID3Stations('PROC', $g, $o.$c, 'UTC_DATA|'.$G{$g}{utc}); + } + } + } + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"frm|$formslist\n");} + if ($dislist ne "") { push(@out,"dis|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + # + # VIEWS: legacy-network $g ==> VIEWS/$g if it has a non-zero 'net' + # + if (defined($G{$g}{net}) and $G{$g}{net} != 0) { + if (!defined($G{$g}{cod}) or !defined($G{$g}{obs})) { + print "No ID3 (missing obs and/or cod) for $g "; + + # my $in = ; + # chomp($in); + # if (length($in) != 3) { + print " - $g skipped, NOT migrated\n"; + next; + + # } + # $G{$g}{obs} = substr($in,0,1); + # $G{$g}{cod} = substr($in,1,2); + } + if ($dry) {print "would mkdir -p $PATH_VIEWS/$g\n"} else { qx(mkdir -p $PATH_VIEWS/$g) }; + my $path = "$PATH_VIEWS/$g/$g.conf"; + printf("%+6d created %s\n", time-$t0, $path); + my @out; + no warnings "uninitialized"; + push(@out,"=key|value\n"); + push(@out,"# M2G.0 from $graphFile on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + push(@out,"nom|$G{$g}{nom}\n"); + push(@out,"net|$G{$g}{net}\n"); + push(@out,"own|$G{$g}{obs}\n"); + push(@out,"snm|$G{$g}{snm}\n"); + push(@out,"ssz|$G{$g}{ssz}\n"); + push(@out,"rvb|$G{$g}{rvb}\n"); + push(@out,"map|$G{$g}{map}\n"); + push(@out,"htm|$G{$g}{htm}\n"); + push(@out,"web|$G{$g}{web}\n"); + push(@out,"typ|$G{$g}{typ}\n"); + my $legacyID3 = ""; + my $dislist=""; + my $formslist=""; + + # + handle {obs} and {cod} that are arrays ! + @ol = split(',',$G{$g}{obs}); + @cl = split(',',$G{$g}{cod}); + for my $o (@ol) { + for my $c (@cl) { + if (length($o.$c) == 3) { + $legacyID3 .= $o.$c." "; + $dislist .= substr($c,0,1)." "; + + #foreach my $k (keys %F) { + # if ($o.$c eq $k) { + # $formslist .= $F{$k}." "; + # qx(ln -s $WEBOBS{PATH_FORMS}/$F{$k} $WEBOBS{PATH_GP2FORMS}/VIEW.$g.$F{$k}); + # } + #} + migID3Stations('VIEW', $g, $o.$c, 'ACQ_RATE|'.$G{$g}{acq}, 'LAST_DELAY|'.$G{$g}{lst}); + } + } + } + my $r = index($G{$g}{ext},'xxx')!=-1 ? 1 : 0; push(@out,"req|$r\n"); + if ($legacyID3 ne "") { push(@out,"id3|$legacyID3\n");} + if ($formslist ne "") { push(@out,"frm|$formslist\n");} + if ($dislist ne "") { push(@out,"dis|$dislist\n");} + if (!$dry) { + open(WRT, ">$path"); + print WRT @out ; + close(WRT); + } + } + } # end for $g (keys (%G)) + + printf("\n\n%+6d M2G.0 summary:\n", time-$t0); + printf(" ------------------\n"); + if (!$dry) { + printf("%+8d forms\n",qx(ls -1 $PATH_FORMS | wc -l)); + printf("%+8d procs\n",qx(ls -1 $PATH_PROCS | wc -l)); + printf("%+8d views\n",qx(ls -1 $PATH_VIEWS | wc -l)); + printf("%+8d nodes\n",qx(ls -1 $PATH_NODES/*/*.cnf | wc -l)); + print qx(echo '\n\n---------------'$confpath/FORMS && ls $PATH_FORMS); + print qx(echo '\n\n---------------'$confpath/PROCS && ls $PATH_PROCS); + print qx(echo '\n\n---------------'$confpath/VIEWS && ls $PATH_VIEWS); + for (qx(ls -1 $confpath/PROCS)) { chomp; print "----$PATH_PROCS/$_/$_.conf\n"; print qx(cat $PATH_PROCS/$_/$_.conf); print "\n"}; + for (qx(ls -1 $confpath/VIEWS)) { chomp; print "----$PATH_VIEWS/$_/$_.conf\n"; print qx(cat $PATH_VIEWS/$_/$_.conf); print "\n"}; + print "--------- FORMS\n\n"; for (qx(ls -1 $PATH_FORMS/*)) { print "$_"; }; + } + + printf("\n%+6d M2G.0 done.\n", time-$t0); + + #close(STDOUT); + +} sub MIGRATE_1_NODESXLATE { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_NODESXLATE\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^NOM\|/NAME|/; - s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; - s/^VALIDE\|/VALID\|/; - # next 3 to change | to \| except first one - s/^(.*?)\|/$1¤/; - s/\|/\\\|/g; - s/^(.*?)¤/$1\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_NODESXLATE\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^NOM\|/NAME|/; + s/^FILES_CARACTERISTIQUES\|/FILES_FEATURES\|/; + s/^VALIDE\|/VALID\|/; + + # next 3 to change | to \| except first one + s/^(.*?)\|/$1¤/; + s/\|/\\\|/g; + s/^(.*?)¤/$1\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_1_FORMSCONF { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_1_FORMSCONF\n"; - $t0 = time; - my (@liste, $i); - my @lsd = qx(ls -d $PATH_FORMS/*); - chomp(@lsd); - foreach (@lsd) { - s/.*FORMS\///g; - my $form = $_; - my $prefix = $form."_"; - open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; - my @f = ; - close RDR; - for (@f) { - s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; - s/$prefix//; - } - unshift(@f, "=key|value\n"); # add the new readCfg format-specification - if (!$dry) { - open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; - for (@f) { - print WRT $_; - } - close WRT; - } else { print "would set [\n @f \n] "} - print "$PATH_FORMS/$form/$form.conf done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_1_FORMSCONF\n"; + $t0 = time; + my (@liste, $i); + my @lsd = qx(ls -d $PATH_FORMS/*); + chomp(@lsd); + foreach (@lsd) { + s/.*FORMS\///g; + my $form = $_; + my $prefix = $form."_"; + open RDR, "<$PATH_FORMS/$form/$form.conf" or die "Couldn't open in $PATH_FORMS/$form/$form.conf : $!"; + my @f = ; + close RDR; + for (@f) { + s/^CGI_AFFICHE_.*\|/CGI_SHOW|/; + s/$prefix//; + } + unshift(@f, "=key|value\n"); # add the new readCfg format-specification + if (!$dry) { + open WRT, ">$PATH_FORMS/$form/$form.conf" or die "Couldn't open out $PATH_FORMS/$form/$form.conf : $!"; + for (@f) { + print WRT $_; + } + close WRT; + } else { print "would set [\n @f \n] "} + print "$PATH_FORMS/$form/$form.conf done\n"; + } } sub MIGRATE_2_NODESFEATURES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_2_NODESFEATURES\n"; - $t0 = time; - my @nodes = <$PATH_NODES/*>; - chomp(@nodes); - for my $n (@nodes) { - if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} - if ($?) { print "Couldn't create $n/FEATURES; $!" ; next } - my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); - die "Couldn't find txt's; $!" if ($?); - chomp(@files); - for my $f (@files) { - if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv "$f" "$n/FEATURES/");} - die "Couldn't move $f to $n/FEATURES; $? " if ($?); - } - print "$n done\n"; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_2_NODESFEATURES\n"; + $t0 = time; + my @nodes = <$PATH_NODES/*>; + chomp(@nodes); + for my $n (@nodes) { + if ($dry) { print "would mkdir -p $n/FEATURES\n"} else { qx(mkdir -p $n/FEATURES);} + if ($?) { print "Couldn't create $n/FEATURES; $!" ; next } + my @files = qx(find $n -maxdepth 1 -not -name 'info.txt*' -not -name 'installation.txt*' -not -name 'type.txt*' -not -name 'acces.txt*' -name '*.txt*'); + die "Couldn't find txt's; $!" if ($?); + chomp(@files); + for my $f (@files) { + if ($dry) { print "would mv $f $n/FEATURES/\n" } else { qx(mv "$f" "$n/FEATURES/");} + die "Couldn't move $f to $n/FEATURES; $? " if ($?); + } + print "$n done\n"; + } } sub MIGRATE_3_FORMSNET2GRIDS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; - my @forms= <$PATH_FORMS/*> ; - foreach (@forms) { - my $formname = basename($_); - if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } - else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$formname.conf) } - my @file = <$_/reseaux*.conf> ; - for my $fn (@file) { - open RDR, "<$fn" or die "Couldn't open $fn : $!"; - my @f = ; - close RDR; - for (@f) { - next if m/^#/ ; - next if m/^$/; - chomp(); - my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); - if (scalar(@res) > 0) { - $res[0] = basename($res[0]); - $res[0] =~ s/\.conf//; - $res[0] =~ s/:.*$//g; - chomp($res[0]); - if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } - else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } - } - } - print "$fn done.\n"; - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_FORMSNET2GRIDS\n"; + my @forms= <$PATH_FORMS/*> ; + foreach (@forms) { + my $formname = basename($_); + if ($dry) { print "would sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/".basename($_).".conf\n" } + else { qx(sed -ie 's/FILE_RESEAUX|/FILE_PROCS|/' $_/$formname.conf) } + my @file = <$_/reseaux*.conf> ; + for my $fn (@file) { + open RDR, "<$fn" or die "Couldn't open $fn : $!"; + my @f = ; + close RDR; + for (@f) { + next if m/^#/ ; + next if m/^$/; + chomp(); + my @res = qx(grep "id3\|$_" $PATH_PROCS/*/*.conf); + if (scalar(@res) > 0) { + $res[0] = basename($res[0]); + $res[0] =~ s/\.conf//; + $res[0] =~ s/:.*$//g; + chomp($res[0]); + if ($dry) { print "would sed -ie \'s/$_/$res[0]/\' $fn\n" } + else { qx(sed -ie \'s/$_/$res[0]/\' $fn) } + } + } + print "$fn done.\n"; + } + } } sub MIGRATE_3_NORMNODES { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_3_NORMNODES\n"; - print "> NOP\n"; + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_3_NORMNODES\n"; + print "> NOP\n"; } sub MIGRATE_4_ALIASDASH { + # late request: NODEs having their 'ALIAS' or 'DATA_FILE' set to '-' should NOT be included in PROC(s) - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_4_ALIASDASH\n"; - $t0 = time; - my @files = <$PATH_NODES/*/*.cnf>; #/ - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { - my $p = ''; - for (@f) { if (/PROC\|/) { $p = $_ } } ; - chomp($p); - if ($dry) { - print "would sed -ie \'/PROC|/d\' $_" ; - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; - } - else { - qx( sed -ie \'/PROC|/d\' $_ ); - s/$PATH_NODES\/.*\///g; - s/\.cnf//g; - qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); - } - } - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_4_ALIASDASH\n"; + $t0 = time; + my @files = <$PATH_NODES/*/*.cnf>; #/ + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + if (grep(/ALIAS\|-|DATA_FILE\|-/,@f) && grep(/PROC\|/,@f) ) { + my $p = ''; + for (@f) { if (/PROC\|/) { $p = $_ } } ; + chomp($p); + if ($dry) { + print "would sed -ie \'/PROC|/d\' $_" ; + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + print " + rm $PATH_GRIDS2NODES/PROC.*.$_\n" ; + } + else { + qx( sed -ie \'/PROC|/d\' $_ ); + s/$PATH_NODES\/.*\///g; + s/\.cnf//g; + qx( rm $PATH_GRIDS2NODES/PROC.*.$_ ); + } + } + } } sub MIGRATE_5_FID { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_5_FID\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_NODES/*/*.cnf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^DATA_FILE\|/FID|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_5_FID\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_NODES/*/*.cnf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^DATA_FILE\|/FID|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_6_PROCKEYS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_6_PROCKEYS\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_PROCS/*/*.conf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - my $ixd=0; $ixd++ until($f[$ixd] =~ /^cro/); splice(@f, $ixd, 1); - for (@f) { - s/^cum\|/CUMULATELIST\|/; - s/^dec\|/DECIMATELIST\|/; - s/^dis\|/DOMAIN|/; - s/^ext\|/TIMESCALELIST|/; - s/^fmt\|/DATESTRLIST\|/; - s/^frm\|/FORM\|/; - s/^ftp\|/RAWDATA\|/; - s/^ico\|/THUMBNAIL\|/; - s/^lnk\|/URL\|/; - s/^mks\|/MARKERSIZELIST\|/; - s/^nom\|/NAME\|/; - s/^req\|/REQUEST\|/; - s/^utc\|/TZ\|/; - s/^STA\|/NODESLIST\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_6_PROCKEYS\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_PROCS/*/*.conf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + my $ixd=0; $ixd++ until($f[$ixd] =~ /^cro/); splice(@f, $ixd, 1); + for (@f) { + s/^cum\|/CUMULATELIST\|/; + s/^dec\|/DECIMATELIST\|/; + s/^dis\|/DOMAIN|/; + s/^ext\|/TIMESCALELIST|/; + s/^fmt\|/DATESTRLIST\|/; + s/^frm\|/FORM\|/; + s/^ftp\|/RAWDATA\|/; + s/^ico\|/THUMBNAIL\|/; + s/^lnk\|/URL\|/; + s/^mks\|/MARKERSIZELIST\|/; + s/^nom\|/NAME\|/; + s/^req\|/REQUEST\|/; + s/^utc\|/TZ\|/; + s/^STA\|/NODESLIST\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } sub MIGRATE_6_VIEWKEYS { - print( "\n".strftime("%F %R ",localtime(time()))); - print "> M2G::MIGRATE_6_VIEWKEYS\n"; - $t0 = time; - my $i = 0; - my @files = <$PATH_VIEWS/*/*.conf>; - for (@files) { - open RDR, "<$_" or die "Couldn't open in '$_': $!"; - my @f = ; - close RDR; - for (@f) { - s/^dis\|/DOMAIN|/; - s/^htm\|/URL|/; - s/^map\|/MAPLIST\|/; - s/^nom\|/NAME\|/; - s/^own\|/OWNCODE\|/; - s/^req\|/REQUEST\|/; - s/^rvb\|/NODERGB\|/; - s/^snm\|/NODENAME\|/; - s/^ssz\|/NODESIZE\|/; - s/^typ\|/TYPE\|/; - s/^web\|/DISPLAY\|/; - s/^STA\|/NODESLIST\|/; - } - if ( $dry && ($i == 0 || $i == $#files) ) { - print "Sample update for $_ :\n [\n @f \n]\n"; - } - if (!$dry) { - open WRT, ">$_" or die "Couldn't open out '$_': $!"; - for (@f) { - print WRT $_; - } - close WRT; - } - print "$_ done\n"; - $i++; - } + print( "\n".strftime("%F %R ",localtime(time()))); + print "> M2G::MIGRATE_6_VIEWKEYS\n"; + $t0 = time; + my $i = 0; + my @files = <$PATH_VIEWS/*/*.conf>; + for (@files) { + open RDR, "<$_" or die "Couldn't open in '$_': $!"; + my @f = ; + close RDR; + for (@f) { + s/^dis\|/DOMAIN|/; + s/^htm\|/URL|/; + s/^map\|/MAPLIST\|/; + s/^nom\|/NAME\|/; + s/^own\|/OWNCODE\|/; + s/^req\|/REQUEST\|/; + s/^rvb\|/NODERGB\|/; + s/^snm\|/NODENAME\|/; + s/^ssz\|/NODESIZE\|/; + s/^typ\|/TYPE\|/; + s/^web\|/DISPLAY\|/; + s/^STA\|/NODESLIST\|/; + } + if ( $dry && ($i == 0 || $i == $#files) ) { + print "Sample update for $_ :\n [\n @f \n]\n"; + } + if (!$dry) { + open WRT, ">$_" or die "Couldn't open out '$_': $!"; + for (@f) { + print WRT $_; + } + close WRT; + } + print "$_ done\n"; + $i++; + } } - # helper function to extract DISCIPLINE & OBSERVATOIRE definitions # sub getTag { - my($stanza, $tag) = @_; - my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); - $l[0] =~ s/^\w\*|\w*\|//gi; - $l[0] =~ s/\'|{|}//gi; - return split(/,/,$l[0]); + my($stanza, $tag) = @_; + my @l = grep (/^($stanza)\|($tag)\|/, @infoGenerales); + $l[0] =~ s/^\w\*|\w*\|//gi; + $l[0] =~ s/\'|{|}//gi; + return split(/,/,$l[0]); } - # STATIONS (called from main process, for each grid/proc, for which # stations are identified by the 3 digits legacy code 'obs+cod' # 3 arguments: PROC or VIEW ($type) # name of PROC or VIEW ($name) # id 3 digits to identify stations ($id3) sub migID3Stations { - my ($type, $name, $id3, $s1, $s2) = @_; - opendir(DIR, $PATH_NODES) or die "couldn't opendir $PATH_NODES : $!"; - my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); - closedir(DIR); - my ($dir, $o); - for $dir (@dirs) { - if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { - if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { - printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "=key|value\n"); - print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); - while () { # use all existing lines, replacing ... - s/\s/\|/; # ... 1st blank with | delimiter - print(WRT $_); # - } - print(WRT "$type|$name\n"); # new link to PROC or GRID line - print(WRT "$s1\n"); - if (defined($s2)) { print(WRT "$s2\n") }; - close(WRT); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - } else { - printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); - if (!$dry) { - my $typefound=0; - do { - local $^I='~'; - local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); - while(<>){ - chomp; - if (/^($type)\|(.*)/) { - $_ = "$type|$2,$name\n"; - $typefound++; - } - $_ .= "\n"; - print; - } - }; - if ($typefound == 0) { - if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { - print(WRT "$type|$name\n"); - close(WRT); - } - } - qx(rm $PATH_NODES/$dir/$dir.cnf~); - qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); - } - } - close(RDR); - } - } + my ($type, $name, $id3, $s1, $s2) = @_; + opendir(DIR, $PATH_NODES) or die "couldn't opendir $PATH_NODES : $!"; + my @dirs = grep {/^($id3)/ && -d $PATH_NODES."/".$_} readdir(DIR); + closedir(DIR); + my ($dir, $o); + for $dir (@dirs) { + if (open RDR, "<", $PATH_NODES."/".$dir."/".$dir.".conf") { + if (!-e $PATH_NODES."/".$dir."/".$dir.".cnf") { + printf("%+6d new $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + if (open WRT, ">", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "=key|value\n"); + print(WRT "# M2G created on ".strftime("%Y-%m-%d %H:%M:%S %z",localtime)."\n\n"); + while () { # use all existing lines, replacing ... + s/\s/\|/; # ... 1st blank with | delimiter + print(WRT $_); # + } + print(WRT "$type|$name\n"); # new link to PROC or GRID line + print(WRT "$s1\n"); + if (defined($s2)) { print(WRT "$s2\n") }; + close(WRT); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + } else { + printf("%+6d upd $PATH_NODES/$dir/$dir.cnf [%s]\n", time-$t0, $type); + if (!$dry) { + my $typefound=0; + do { + local $^I='~'; + local @ARGV=($PATH_NODES."/".$dir."/".$dir.".cnf"); + while(<>){ + chomp; + if (/^($type)\|(.*)/) { + $_ = "$type|$2,$name\n"; + $typefound++; + } + $_ .= "\n"; + print; + } + }; + if ($typefound == 0) { + if (open WRT, ">>", $PATH_NODES."/".$dir."/".$dir.".cnf") { + print(WRT "$type|$name\n"); + close(WRT); + } + } + qx(rm $PATH_NODES/$dir/$dir.cnf~); + qx(ln -s $PATH_NODES/$dir $PATH_GRIDS2NODES/$type.$name.$dir); + } + } + close(RDR); + } + } } 1; diff --git a/SETUP/ddump.pm b/SETUP/ddump.pm index f0cd809c..64a99b6b 100755 --- a/SETUP/ddump.pm +++ b/SETUP/ddump.pm @@ -1,33 +1,32 @@ #!/usr/bin/perl sub ddumpSyms { - foreach my $entry ( keys %main:: ) { - print "Name: $entry\n"; - print "\t"; - print "scalar ".\${$entry}." ${$entry}" if defined ${$entry}; - print ",array " if defined @{$entry}; - print ",hash " if defined %{$entry}; - print ",sub " if defined &{$entry}; - print "\n"; - } + foreach my $entry ( keys %main:: ) { + print "Name: $entry\n"; + print "\t"; + print "scalar ".\${$entry}." ${$entry}" if defined ${$entry}; + print ",array " if defined @{$entry}; + print ",hash " if defined %{$entry}; + print ",sub " if defined &{$entry}; + print "\n"; + } } sub Syms { - my ($pkgName) = @_; - *stash = *{"${pkgName}::"}; - foreach my $entry ( keys %stash ) { - print "Name: $entry\n"; - print "\t".\${$entry}." \n" if defined ${$entry}; - print "\t".\@{$entry}." \n" if defined @{$entry}; - print "\t".\%{$entry}." \n" if defined %{$entry}; - print "\t".\&{$entry}." \n" if defined &{$entry}; - $entry =~ s/^_ Date: Wed, 5 Feb 2025 12:21:37 +0100 Subject: [PATCH 07/68] fix mailB3.pl --- CODE/cgi-bin/mailB3.pl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODE/cgi-bin/mailB3.pl b/CODE/cgi-bin/mailB3.pl index 4dcf7819..7ed456ee 100755 --- a/CODE/cgi-bin/mailB3.pl +++ b/CODE/cgi-bin/mailB3.pl @@ -193,7 +193,7 @@ sub print_form { ."Magnitude: $evt_magnitude\n" ."Department: $evt_department\n" ."Region: $evt_region\n" - ."Agency: $trigger_agency\n"; + ."Agency: $evt_agency\n"; if (-e "$b3.msg") { my @msg = readFile("$b3.msg"); @@ -294,7 +294,7 @@ sub print_form {
              -
              +
              From f1da86e4df494580ce46df05045c317b2d1de2b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Wed, 5 Feb 2025 12:31:32 +0100 Subject: [PATCH 08/68] Fix JSON typo in tremblemaps.m --- CODE/matlab/superprocs/tremblemaps.m | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/tremblemaps.m b/CODE/matlab/superprocs/tremblemaps.m index a843d3ac..d72dcd22 100644 --- a/CODE/matlab/superprocs/tremblemaps.m +++ b/CODE/matlab/superprocs/tremblemaps.m @@ -60,7 +60,7 @@ % % Authors: F. Beauducel and J.M. Saurel / WEBOBS, IPGP % Created: 2005-01-12, Guadeloupe, French West Indies -% Updated: 2025-02-04 +% Updated: 2025-02-05 WO = readcfg; @@ -618,7 +618,7 @@ fprintf(fid,' "longitude": "%1.4f",\n',d(n,2)); fprintf(fid,' "depth": "%1.1f",\n',d(n,3)); fprintf(fid,' "magnitude": "%1.1f",\n',d(n,4)); - fprintf(fid,' "region": "%s (%s)"\n',upper(varsub('$azimuth de $city',E)),upper(E.region)); + fprintf(fid,' "region": "%s (%s)",\n',upper(varsub('$azimuth de $city',E)),upper(E.region)); fprintf(fid,' "department": "%s",\n',P.TRIGGER_DEPARTMENT); fprintf(fid,' "agency": "%s",\n',P.TRIGGER_AGENCY); fprintf(fid,'}\n'); From 6e2a02916790eea9ab96c1c75926b58f5b0a1953 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Wed, 5 Feb 2025 12:41:26 +0100 Subject: [PATCH 09/68] Fix JSON (again) in tremblemaps.m --- CODE/matlab/superprocs/tremblemaps.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/tremblemaps.m b/CODE/matlab/superprocs/tremblemaps.m index d72dcd22..dbd31240 100644 --- a/CODE/matlab/superprocs/tremblemaps.m +++ b/CODE/matlab/superprocs/tremblemaps.m @@ -620,7 +620,7 @@ fprintf(fid,' "magnitude": "%1.1f",\n',d(n,4)); fprintf(fid,' "region": "%s (%s)",\n',upper(varsub('$azimuth de $city',E)),upper(E.region)); fprintf(fid,' "department": "%s",\n',P.TRIGGER_DEPARTMENT); - fprintf(fid,' "agency": "%s",\n',P.TRIGGER_AGENCY); + fprintf(fid,' "agency": "%s"\n',P.TRIGGER_AGENCY); fprintf(fid,'}\n'); fclose(fid); fprintf(' done.\n'); From 6b9ab26f3b654dd41171b65bf5921d23ae0fdf4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Wed, 5 Feb 2025 13:38:00 +0100 Subject: [PATCH 10/68] Renamed PROC.TREMBLEMAPS_en to PROC.TREMBLEMAPS (setup update compatibility) --- CODE/tplates/{PROC.TREMBLEMAPS_en => PROC.TREMBLEMAPS} | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) rename CODE/tplates/{PROC.TREMBLEMAPS_en => PROC.TREMBLEMAPS} (99%) diff --git a/CODE/tplates/PROC.TREMBLEMAPS_en b/CODE/tplates/PROC.TREMBLEMAPS similarity index 99% rename from CODE/tplates/PROC.TREMBLEMAPS_en rename to CODE/tplates/PROC.TREMBLEMAPS index a0bce57e..fb6b1cba 100644 --- a/CODE/tplates/PROC.TREMBLEMAPS_en +++ b/CODE/tplates/PROC.TREMBLEMAPS @@ -8,7 +8,7 @@ NAME|Earthquake Felt Report # description of what the proc does -DESCRIPTION|B3 Earthquake Felt Report (EN) +DESCRIPTION|B3 Earthquake Felt Report # proc TYPE and OWNER code (see OWNERS.conf for OWNCODEs) RAWFORMAT|quakes From 90b0ad98c8fd0c824c5823a9d8d356a1985e93fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Wed, 5 Feb 2025 15:30:20 +0100 Subject: [PATCH 11/68] update index.md for release 2.7.3 --- index.md | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/index.md b/index.md index 64c8bd01..6f889c5c 100644 --- a/index.md +++ b/index.md @@ -12,9 +12,9 @@ WebObs is presently fully functional and used in a dozen observatories (see the ## Download the latest release -- [WebObs-2.7.2.tar.gz](https://github.com/IPGP/webobs/releases/download/v2.7.2/WebObs-2.7.2.tar.gz) (103 Mb) updated January 24, 2024 -- [Release notes](https://github.com/IPGP/webobs/blob/v2.7.2/release-notes.md) (see also the [What's new?](#whatsnew) section below) -- [User manual](https://github.com/IPGP/webobs/releases/download/v2.7.2/WebObs_Manual.pdf) (in progress) +- [WebObs-2.7.3.tar.gz](https://github.com/IPGP/webobs/releases/download/v2.7.3/WebObs-2.7.3.tar.gz) (103 Mb) updated February 5, 2025 +- [Release notes](https://github.com/IPGP/webobs/blob/v2.7.3/release-notes.md) (see also the [What's new?](#whatsnew) section below) +- [User manual](https://github.com/IPGP/webobs/releases/download/v2.7.3/WebObs_Manual.pdf) (in progress) - And, for a first install: - Mandatory (license free): **Matlab runtime** for [Linux 64bit](http://www.ipgp.fr/~beaudu/webobs/MCR_Runtime/MCR_R2011b_glnxa64_installer.zip) (386 Mb) or [Linux 32bit](http://www.ipgp.fr/~beaudu/webobs/MCR_Runtime/MCR_R2011b_glnx86_installer.zip) (389 Mb) - Recommanded: **ETOPO1** (see [below](#srtm1) for download and install) @@ -149,6 +149,7 @@ ETOPO_COPYRIGHT|DEM: ETOPO1 NGDC/NOOA - new interface for publishing B3 reports; - finalization of the interface between WebObs and the Theia\|OZCAR data portal; - new format for calibration files; +- new GNSS raw data formats; - some minor to moderate fixes and other minor improvements. ### What's new in the 2.6? From ce5eb11c836e754cd3d66839533afa52667650fe Mon Sep 17 00:00:00 2001 From: jtouvier Date: Wed, 5 Feb 2025 15:59:46 +0100 Subject: [PATCH 12/68] replace other tabs --- CODE/cgi-bin/Gazette.pl | 82 +- CODE/cgi-bin/OSM.pl | 328 +++---- CODE/cgi-bin/Welcome.pl | 60 +- CODE/cgi-bin/cedit.pl | 50 +- CODE/cgi-bin/cgiwoc.pl | 8 +- CODE/cgi-bin/editMC3.pl | 38 +- CODE/cgi-bin/fedit.pl | 92 +- CODE/cgi-bin/formBOJAP.pl | 102 +- CODE/cgi-bin/formCLB.pl | 134 +-- CODE/cgi-bin/formDISTANCE.pl | 122 +-- CODE/cgi-bin/formEAUX.pl | 16 +- CODE/cgi-bin/formEXTENSO.pl | 272 +++--- CODE/cgi-bin/formGAZ.pl | 84 +- CODE/cgi-bin/formGENFORM.pl | 36 +- CODE/cgi-bin/formGRID.pl | 68 +- CODE/cgi-bin/formGRIDMAPS.pl | 80 +- CODE/cgi-bin/formNODE.pl | 934 +++++++++---------- CODE/cgi-bin/formNOVAC.pl | 20 +- CODE/cgi-bin/formPLUVIO.pl | 176 ++-- CODE/cgi-bin/formRAINWATER.pl | 36 +- CODE/cgi-bin/formREQ.pl | 266 +++--- CODE/cgi-bin/formRIVERS.pl | 116 +-- CODE/cgi-bin/formSOILSOLUTION.pl | 28 +- CODE/cgi-bin/formUPLOAD.pl | 122 +-- CODE/cgi-bin/formVEHICLES.pl | 56 +- CODE/cgi-bin/gedit.pl | 42 +- CODE/cgi-bin/gridsMgr.pl | 310 +++--- CODE/cgi-bin/gvTransit.pl | 2 +- CODE/cgi-bin/index.pl | 70 +- CODE/cgi-bin/listGRIDS.pl | 2 +- CODE/cgi-bin/mailInfo_OVPF.pl | 36 +- CODE/cgi-bin/mailInfo_REVOSIMA.pl | 14 +- CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl | 100 +- CODE/cgi-bin/mc3.pl | 184 ++-- CODE/cgi-bin/nedit.pl | 40 +- CODE/cgi-bin/nloc.pl | 56 +- CODE/cgi-bin/nsearch.pl | 36 +- CODE/cgi-bin/postGRIDMAPS.pl | 64 +- CODE/cgi-bin/postNODE.pl | 16 +- CODE/cgi-bin/postREQ.pl | 86 +- CODE/cgi-bin/postUPLOAD.pl | 22 +- CODE/cgi-bin/register.pl | 244 ++--- CODE/cgi-bin/relayMgr.pl | 72 +- CODE/cgi-bin/schedulerLogs.pl | 8 +- CODE/cgi-bin/schedulerMgr.pl | 132 +-- CODE/cgi-bin/schedulerRuns.pl | 110 +-- CODE/cgi-bin/sefran3.pl | 138 +-- CODE/cgi-bin/showDISTANCE.pl | 12 +- CODE/cgi-bin/showEAUX.pl | 6 +- CODE/cgi-bin/showEXTENSO.pl | 94 +- CODE/cgi-bin/showFISSURO.pl | 94 +- CODE/cgi-bin/showGAZ.pl | 6 +- CODE/cgi-bin/showGENFORM.pl | 22 +- CODE/cgi-bin/showGRID.pl | 8 +- CODE/cgi-bin/showNODE.pl | 22 +- CODE/cgi-bin/showNODES.pl | 16 +- CODE/cgi-bin/showNOVAC.pl | 4 +- CODE/cgi-bin/showOUTG.pl | 28 +- CODE/cgi-bin/showPLUVIO.pl | 6 +- CODE/cgi-bin/showQRcode.pl | 4 +- CODE/cgi-bin/showRAINWATER.pl | 32 +- CODE/cgi-bin/showREQ.pl | 16 +- CODE/cgi-bin/showRIVERS.pl | 10 +- CODE/cgi-bin/showSISMOBUL.pl | 54 +- CODE/cgi-bin/showSOILSOLUTION.pl | 32 +- CODE/cgi-bin/showTHEIA.pl | 96 +- CODE/cgi-bin/showVEHICLES.pl | 6 +- CODE/cgi-bin/usersMgr.pl | 538 +++++------ CODE/cgi-bin/vedit.pl | 178 ++-- CODE/cgi-bin/vsearch.pl | 16 +- CODE/cgi-bin/wdir.pl | 6 +- CODE/cgi-bin/wedit.pl | 48 +- CODE/cgi-bin/wow.pl | 114 +-- CODE/cgi-bin/wpage.pl | 20 +- CODE/cgi-bin/xedit.pl | 28 +- CODE/perl/exposerc.pl | 16 +- CODE/perl/lib/Config.pm | 62 +- CODE/perl/lib/DBForm.pm | 162 ++-- CODE/perl/lib/Dates.pm | 10 +- CODE/perl/lib/Events.pm | 136 +-- CODE/perl/lib/Form.pm | 52 +- CODE/perl/lib/GML.pm | 6 +- CODE/perl/lib/Gazette.pm | 74 +- CODE/perl/lib/Grids.pm | 2 +- CODE/perl/lib/Mapping.pm | 72 +- CODE/perl/lib/Scheduler.pm | 4 +- CODE/perl/lib/Search.pm | 2 +- CODE/perl/lib/Users.pm | 34 +- CODE/perl/lib/Utils.pm | 22 +- CODE/perl/lib/Wiki.pm | 32 +- CODE/perl/navrc2html.pl | 4 +- CODE/perl/postboard.pl | 62 +- CODE/perl/scheduler.pl | 180 ++-- CODE/perl/woc.pl | 302 +++--- CODE/perl/wsudp.pl | 38 +- 95 files changed, 3949 insertions(+), 3949 deletions(-) diff --git a/CODE/cgi-bin/Gazette.pl b/CODE/cgi-bin/Gazette.pl index 665feeca..dce682af 100755 --- a/CODE/cgi-bin/Gazette.pl +++ b/CODE/cgi-bin/Gazette.pl @@ -20,10 +20,10 @@ =head1 Query string parameters Query String's select/display arguments (match the Display Options Form's fields) gview= [ calendar | datelist | categorylist | iCalendar ] - calendar: display week(s) calendar - dateList: display as a list of dates - categoryList: display as a list of categories - iCalendar: display as iCal + calendar: display week(s) calendar + dateList: display as a list of dates + categoryList: display as a list of categories + iCalendar: display as iCal gdate= date selection, single day or range, compatible with wodp format (YYYY-MM-DD[,YYYY-MM-DD]) @@ -33,29 +33,29 @@ =head1 Query string parameters wodpdesc= optional description of how the date was selected by user with wodp (see wodp.js) : [ day | range | init | year | month | week ] - wodpdesc will be used to format a title for the gazette's page + wodpdesc will be used to format a title for the gazette's page Query String's management arguments (optional) getid= specifies an article's id whose DB row will be returned as a json object. No select/display performed (g* arguments above are ignored). - See Gazette.js + See Gazette.js setid= specifies an article's id whose DB row will be updated with a posted json object (all row's columns) before processing select/display. - See Gazette.js + See Gazette.js delid= specifies an article's id whose DB row will be deleted before processing select/display. - See Gazette.js + See Gazette.js getical= specifies an ical file name (as previously built/saved with a gview=ical) to be downloaded create=yes automatically enters the article creation process, displaying the "create new article" form popup; can be used with other view-related arguments. Primarily used in 'menunav' direct links to creation. - Note: the creation form keeps popping up once processed, allowing successive creations, until - user explicitly dismiss the form (ie. choose its 'cancel' button) + Note: the creation form keeps popping up once processed, allowing successive creations, until + user explicitly dismiss the form (ie. choose its 'cancel' button) =head1 LOCALIZATION @@ -63,13 +63,13 @@ =head1 LOCALIZATION Holidays are defined in $WEBOBS{FILE_DAYSOFF} file, as a collection of - date-expression | name + date-expression | name - date-expression := [ $Y-MM-DD | $P | $P n ] - name := string, name of holiday - $Y := current year - $PQ := Easter Sunday - $PQ n := n days from Easter Sunday + date-expression := [ $Y-MM-DD | $P | $P n ] + name := string, name of holiday + $Y := current year + $PQ := Easter Sunday + $PQ n := n days from Easter Sunday =cut @@ -117,11 +117,11 @@ =head1 LOCALIZATION $setmsg = delId($QryParm->{'delid'}) if ($QryParm->{'delid'} ne ""); ### ---- if no select/display parms, special requests return DB update message only ##if (!defined($QryParm->{'gview'})) { -## if ($setmsg ne "") { -## print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); -## print "Gazette update returned: $setmsg \n"; -## exit; -## } +## if ($setmsg ne "") { +## print $cgi->header(-type=>'text/plain', -charset=>'utf-8'); +## print "Gazette update returned: $setmsg \n"; +## exit; +## } ##} $setmsg = "".$today->strftime('%Y-%m-%d %H:%M:%S')." $__{'last DB update'}: $setmsg" if ($setmsg ne ""); @@ -278,28 +278,28 @@ =head1 LOCALIZATION # form print <<"FIN"; - - -

              $__{'Edit Gazette'}

              - -
              + + +

              $__{'Edit Gazette'}

              + +
              - -
              + +
              -
              +
              - -
              + +
              -
              -
              +
              +
              -

              -   - -

              - +

              +   + +

              + FIN # ---- JavaScript inits @@ -318,9 +318,9 @@ =head1 LOCALIZATION var gazette_remove_text = '$__{"Remove"}'; var gazette_create_text = '$__{"Create Article"}'; \$(document).ready(function() { - \$('div.thepage').css('margin-bottom', '400px'); // room for form-popup near end of page - set_wodp($wodp_d2, $wodp_m, $wodp_holidays, $mindate, $maxdate); - $clickcreate + \$('div.thepage').css('margin-bottom', '400px'); // room for form-popup near end of page + set_wodp($wodp_d2, $wodp_m, $wodp_holidays, $mindate, $maxdate); + $clickcreate }); FIN diff --git a/CODE/cgi-bin/OSM.pl b/CODE/cgi-bin/OSM.pl index 5fadb2aa..aa7130fc 100755 --- a/CODE/cgi-bin/OSM.pl +++ b/CODE/cgi-bin/OSM.pl @@ -114,182 +114,182 @@ END
              FIN diff --git a/CODE/cgi-bin/cedit.pl b/CODE/cgi-bin/cedit.pl index 57e4f2cd..18ce4ee9 100755 --- a/CODE/cgi-bin/cedit.pl +++ b/CODE/cgi-bin/cedit.pl @@ -18,23 +18,23 @@ =head1 Query string parameters =item fs={ wokey | wokey(indkey) } - wokey is a WEBOBS.rc key, that points to the full-path-filename to be edited. - wokey(indkey) is a 1-level indirection, where wokey points to someind file key that points to the full-path-filename to be edited + wokey is a WEBOBS.rc key, that points to the full-path-filename to be edited. + wokey(indkey) is a 1-level indirection, where wokey points to someind file key that points to the full-path-filename to be edited - target full-path-filename must reside in $WEBOBS{CONF_NODES} - authorization resource is authmisc.subpath/filename (see Users.pm for path-like resource names) + target full-path-filename must reside in $WEBOBS{CONF_NODES} + authorization resource is authmisc.subpath/filename (see Users.pm for path-like resource names) - eg. : fs=CONF_NODES - will browse/edit the file pointed to by $WEBOBS{CONF_NODES} + eg. : fs=CONF_NODES + will browse/edit the file pointed to by $WEBOBS{CONF_NODES} - eg. : fs=CONF_NODES(FILE_NODES2NODES) - will browse/edit the file pointed to by FILE_NODES2NODES in the file pointed to by $WEBOBS{CONF_NODES} + eg. : fs=CONF_NODES(FILE_NODES2NODES) + will browse/edit the file pointed to by FILE_NODES2NODES in the file pointed to by $WEBOBS{CONF_NODES} =item action={save | edit} - 'edit' (default when action is not specified) to display edit html-form edit - 'save' internaly used to save the file after html-form edition - (other parameters are used along with 'save': ts0, txt) + 'edit' (default when action is not specified) to display edit html-form edit + 'save' internaly used to save the file after html-form edition + (other parameters are used along with 'save': ts0, txt) =back @@ -141,14 +141,14 @@ =head1 Query string parameters Text edit form @@ -156,18 +156,18 @@ =head1 Query string parameters function verif_formulaire() { \$.post(\"$me\", \$(\"#theform\").serialize(), function(data) { - if (data != '') alert(data); - //location.href = document.referrer; - history.go(-1); - }); + if (data != '') alert(data); + //location.href = document.referrer; + history.go(-1); + }); } diff --git a/CODE/cgi-bin/cgiwoc.pl b/CODE/cgi-bin/cgiwoc.pl index 16268b57..331cced1 100755 --- a/CODE/cgi-bin/cgiwoc.pl +++ b/CODE/cgi-bin/cgiwoc.pl @@ -17,10 +17,10 @@ =head1 DESCRIPTION cgiwoc.pl is part of the html-based woc execution/display page, ie.: - 1) html/cgiwoc.html to start html-base woc, setting up page with - 2) css/cgiwoc.css - 3) js/cgiwoc.js to call (ajax load) cgiwoc.pl and add output DIV to page, - taking care of scrolling + 1) html/cgiwoc.html to start html-base woc, setting up page with + 2) css/cgiwoc.css + 3) js/cgiwoc.js to call (ajax load) cgiwoc.pl and add output DIV to page, + taking care of scrolling =cut diff --git a/CODE/cgi-bin/editMC3.pl b/CODE/cgi-bin/editMC3.pl index b970a3da..9fe5b89a 100755 --- a/CODE/cgi-bin/editMC3.pl +++ b/CODE/cgi-bin/editMC3.pl @@ -323,25 +323,25 @@ =head1 Query string parameters print "

              Creating a new SC3 ID...

              "; $newQML = " - - - $MC3{WO2SC3_MOD_ID} - $MC3{WO2SC3_MOD_TYPE} - - - $mc3/$anneeEvnt$moisEvnt/$id_evt - $anneeEvnt/$moisEvnt/$jourEvnt - - $staEvnt - $netEvnt - $dureeEvnt - $smoinsp - $amplitudeEvnt - $operator - $typeEvnt - $comment - - "; + + + $MC3{WO2SC3_MOD_ID} + $MC3{WO2SC3_MOD_TYPE} + + + $mc3/$anneeEvnt$moisEvnt/$id_evt + $anneeEvnt/$moisEvnt/$jourEvnt + + $staEvnt + $netEvnt + $dureeEvnt + $smoinsp + $amplitudeEvnt + $operator + $typeEvnt + $comment + + "; } # Prepare the text for print diff --git a/CODE/cgi-bin/fedit.pl b/CODE/cgi-bin/fedit.pl index 39a7a918..559b7246 100755 --- a/CODE/cgi-bin/fedit.pl +++ b/CODE/cgi-bin/fedit.pl @@ -20,16 +20,16 @@ =head1 Query string parameters =item fname=fname - where fname should be unique. + where fname should be unique. =item action={save|edit} - 'edit' (default when action is not specified) to display edit html-form edit - 'save' internaly used to save the file after html-form edition + 'edit' (default when action is not specified) to display edit html-form edit + 'save' internaly used to save the file after html-form edition =item tpl=tpl - where tpl is the template selected to create the new form + where tpl is the template selected to create the new form =head1 EDITOR @@ -127,18 +127,18 @@ sub count_inputs { my $editOK = 0; # 1 if the user is allowed to edit the form my $admOK = 0; # 1 if the user is allowed to create new form my @rawfile; # raw content of the configuration file -my $FORMName; # name of the form +my $FORMName; # name of the form my $text; -my $action; # new|edit|save -my $newF; # 1 if we are creating a new form -my $delete; # 1 to delete form -my $inputs; # number which indicates how many inputs we are storing in this form -my $template; # name of template wanted by user +my $action; # new|edit|save +my $newF; # 1 if we are creating a new form +my $delete; # 1 to delete form +my $inputs; # number which indicates how many inputs we are storing in this form +my $template; # name of template wanted by user # Read and check CGI parameters $FORMName = $cgi->param('fname'); $action = checkParam($cgi->param('action'), qr/(edit|save)/, 'action') // "edit"; -$text = $cgi->param('text') // ''; # used only in print FILE $text; +$text = $cgi->param('text') // ''; # used only in print FILE $text; $TS0 = checkParam($cgi->param('ts0'), qr/^[0-9]*$/, "TS0") // 0; $delete = checkParam($cgi->param('delete'), qr/^\d?$/, "delete") // 0; $template = $cgi->param('tpl') // ""; @@ -165,7 +165,7 @@ sub count_inputs { $admOK = WebObs::Users::clientHasAdm(type => "authforms", name => "*"); if ( $editOK == 0 ) { die "$__{'Not authorized'}" } -my $formdir = "$WEBOBS{PATH_FORMS}/$FORMName/"; # path to the form configuration file we are creating, editing or deleting +my $formdir = "$WEBOBS{PATH_FORMS}/$FORMName/"; # path to the form configuration file we are creating, editing or deleting $formConfFile = "$formdir$FORMName.conf"; my @db_columns0 = ("id integer PRIMARY KEY AUTOINCREMENT", "trash boolean DEFAULT FALSE", "node text NOT NULL", @@ -197,13 +197,13 @@ sub count_inputs { my $dbh = connectDbForms(); # --- checking if the table we want to edit exists - my $tbl = lc($FORMName); + my $tbl = lc($FORMName); my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); my $sth = $dbh->prepare( $stmt ); my $rv = $sth->execute() or die $DBI::errstr; - if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB + if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB # --- creation of the DB table my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); @@ -248,13 +248,13 @@ sub count_inputs { my $dbh = connectDbForms(); # --- checking if the table we want to edit exists - my $tbl = lc($FORMName); + my $tbl = lc($FORMName); my $stmt = qq(select exists (select name from sqlite_master where type='table' and name='$tbl');); my $sth = $dbh->prepare( $stmt ); my $rv = $sth->execute() or die $DBI::errstr; - if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB + if ($sth->fetchrow_array() == 0) { # if $sth->fetchrow_array() == 0, it means $tbl doe snot exists in the DB # --- creation of the DB table my @inputs = grep {/(INPUT[0-9]{2,3}_NAME)/} split(/\n/, $text); @@ -321,13 +321,13 @@ sub count_inputs { # ---- action is 'edit' (default) # -if ( -e "$formConfFile" ) { # looking if the FORM already exists +if ( -e "$formConfFile" ) { # looking if the FORM already exists if ($editOK) { @rawfile = readFile($formConfFile); $TS0 = (stat($formConfFile))[9] ; } } -else { # we are creating a new FORM +else { # we are creating a new FORM if ($admOK) { $formConfFile = "$WEBOBS{ROOT_CODE}/tplates/$template"; @rawfile = readFile($formConfFile); @@ -377,13 +377,13 @@ sub count_inputs { @@ -391,25 +391,25 @@ sub count_inputs { @@ -477,11 +477,11 @@ sub count_inputs { # Vim mode checkbox print <<_EOD_; -
              - - -
              - +
              + + +
              + _EOD_ # Form buttons diff --git a/CODE/cgi-bin/formBOJAP.pl b/CODE/cgi-bin/formBOJAP.pl index a0060e8d..0f5997b6 100755 --- a/CODE/cgi-bin/formBOJAP.pl +++ b/CODE/cgi-bin/formBOJAP.pl @@ -121,59 +121,59 @@ =head1 Query string parameter @@ -217,129 +217,129 @@ =head1 Query string parameter function verif_formulaire() { - var i; - if(document.formulaire.hr.value == '') { - alert('Veuillez indiquer une heure!'); - document.formulaire.hr.focus(); - return false; - } - if(document.formulaire.mn.value == '') { - alert('Veuillez indiquer les minutes!'); - document.formulaire.mn.focus(); - return false; - } - if(document.formulaire.oper.value == '') { - alert('Veuillez choisir au moins 1 opérateur dans la liste!'); - document.formulaire.oper.focus(); - return false; - } - if(document.formulaire.site.value == '') { - alert('Veuillez spécifier le site de mesure!'); - document.formulaire.site.focus(); - return false; - } - if(document.formulaire.ruban.value == '') { - alert('Veuillez indiquer une valeur de ruban!'); - document.formulaire.ruban.focus(); - return false; - } - if (document.formulaire.ruban.value/25 % 1 != 0) { - alert('La valeur du ruban doit etre multiple de 25 mm!'); - document.formulaire.ruban.focus(); - return false; - } - if(document.formulaire.moy.value == 0) { - alert('Veuillez indiquer au moins une mesure!'); - document.formulaire.f1.focus(); - return false; - } - - for (i=1;i<=9;i++) { - //djl missing c:if (eval('document.formulaire.c' + i.toFixed(0) + '.value') >= 1) { - //djl missing c: alert('La valeur du cadran #' + i.toFixed(0) + ' doit etre inferieure a 1 !'); - //djl missing c: eval('document.formulaire.c' + i.toFixed(0) + '.focus()'); - //djl missing c: return false; - //djl missing c:} - if (eval('document.formulaire.f' + i.toFixed(0) + '.value') != '' && eval('document.formulaire.v' + i.toFixed(0) + '.value') == '') { - alert('Veuillez indiquer la force du vent pour la mesure #' + i.toFixed(0) + ' !'); - eval('document.formulaire.v' + i.toFixed(0) + '.focus()'); - return false; - } - } + var i; + if(document.formulaire.hr.value == '') { + alert('Veuillez indiquer une heure!'); + document.formulaire.hr.focus(); + return false; + } + if(document.formulaire.mn.value == '') { + alert('Veuillez indiquer les minutes!'); + document.formulaire.mn.focus(); + return false; + } + if(document.formulaire.oper.value == '') { + alert('Veuillez choisir au moins 1 opérateur dans la liste!'); + document.formulaire.oper.focus(); + return false; + } + if(document.formulaire.site.value == '') { + alert('Veuillez spécifier le site de mesure!'); + document.formulaire.site.focus(); + return false; + } + if(document.formulaire.ruban.value == '') { + alert('Veuillez indiquer une valeur de ruban!'); + document.formulaire.ruban.focus(); + return false; + } + if (document.formulaire.ruban.value/25 % 1 != 0) { + alert('La valeur du ruban doit etre multiple de 25 mm!'); + document.formulaire.ruban.focus(); + return false; + } + if(document.formulaire.moy.value == 0) { + alert('Veuillez indiquer au moins une mesure!'); + document.formulaire.f1.focus(); + return false; + } + + for (i=1;i<=9;i++) { + //djl missing c:if (eval('document.formulaire.c' + i.toFixed(0) + '.value') >= 1) { + //djl missing c: alert('La valeur du cadran #' + i.toFixed(0) + ' doit etre inferieure a 1 !'); + //djl missing c: eval('document.formulaire.c' + i.toFixed(0) + '.focus()'); + //djl missing c: return false; + //djl missing c:} + if (eval('document.formulaire.f' + i.toFixed(0) + '.value') != '' && eval('document.formulaire.v' + i.toFixed(0) + '.value') == '') { + alert('Veuillez indiquer la force du vent pour la mesure #' + i.toFixed(0) + ' !'); + eval('document.formulaire.v' + i.toFixed(0) + '.focus()'); + return false; + } + } \$.post(\"/cgi-bin/".$FORM->conf('CGI_POST')."\", \$(\"#theform\").serialize(), function(data) { - //var contents = \$( data ).find( '#contents' ).text(); - alert(data); - document.location=\"/cgi-bin/".$FORM->conf('CGI_SHOW')."\"; - } - ); + //var contents = \$( data ).find( '#contents' ).text(); + alert(data); + document.location=\"/cgi-bin/".$FORM->conf('CGI_SHOW')."\"; + } + ); } function calc() { - var moy = 0; - var sig = 0; - var n = 0; - var v = 0; - var i; - var ns = ''; - var rouge = '#FF0000'; - var orange = '#FFD800'; - var vert = '#66FF66'; - var blanc = '#FFFFFF'; - - for (i=0;i 1) { - formulaire.sig.style.background = orange; - } - if (sig > 2) { - formulaire.sig.style.background = rouge; - } + var moy = 0; + var sig = 0; + var n = 0; + var v = 0; + var i; + var ns = ''; + var rouge = '#FF0000'; + var orange = '#FFD800'; + var vert = '#66FF66'; + var blanc = '#FFFFFF'; + + for (i=0;i 1) { + formulaire.sig.style.background = orange; + } + if (sig > 2) { + formulaire.sig.style.background = rouge; + } } function propagate_wind() { - var vv = ''; - for (i=1;i<=$nbData;i++) { - if (vv == '' && formulaire['v' + i].value != '') { vv = formulaire['v' + i].value; } - } - if (vv != '') { - for (i=1;i<=$nbData;i++) { - if (formulaire['v' + i].value == '') { formulaire['v' + i].value = vv; } - } - } - + var vv = ''; + for (i=1;i<=$nbData;i++) { + if (vv == '' && formulaire['v' + i].value != '') { vv = formulaire['v' + i].value; } + } + if (vv != '') { + for (i=1;i<=$nbData;i++) { + if (formulaire['v' + i].value == '') { formulaire['v' + i].value = vv; } + } + } + } function derniere_mesure() { - formulaire.prevmes.value = eval('formulaire.' + formulaire.site.value + '.value'); + formulaire.prevmes.value = eval('formulaire.' + formulaire.site.value + '.value'); } window.captureEvents(Event.KEYDOWN); window.onkeydown = calc(); @@ -357,9 +357,9 @@ =head1 Query string parameter print "
            "; print "\n"; print ""; print < - const checked = document.getElementById("theiaChecked"); - const auth = $theiaAuth; - - if (auth == 1) { - // console.log(theia); - checked.style.display = "block"; - } else { - checked.style.display = "none"; - } - - var map = L.map('map', mapOptions); - var popup = L.popup(); - map.on('click', onMapClick); - - document.getElementById("auto-loc").addEventListener('click', getLocation); - // let suivi = navigator.geolocation.getCurrentPosition(getCurrent, error); - - if ( document.form.latwgs84.value !== "" || document.form.lonwgs84.value !== "" ) { - var lat = document.form.latwgs84.value*(1-2*(document.form.latwgs84n.value == 'S')); - var lon = document.form.lonwgs84.value*(1-2*(document.form.lonwgs84e.value == 'W')); - - map.setView([lat, lon]); - map.flyTo([lat, lon], 14, { - animate: false, - //animate: true, - //duration: 1 - }); - - var marker = L.marker([lat, lon]).addTo(map); - marker.bindPopup(\"$text\").openPopup(); - L.control.scale().addTo(map); - } - - var layerControl = L.control.layers(basemaps, overlays).addTo(map); - - if (typeof(\"$geojsonFile\") !== 'undefined') { - var shpfile = createShp($json); - shpfile.addTo(map); - - var geometry = JSON.stringify(getGeometry($json)); - document.form.outWKT.value = geometry; - } - + FIN print "
            -
            Date, site et opérateurs -

            - Date: "; for (@anneeListe) { if ($_ == $sel_annee) { print ""; } else { print ""; } } @@ -390,7 +390,7 @@ =head1 Query string parameter } print "
            "; print "Site: \n"; + onMouseOut=\"nd()\" onmouseover=\"overlib('Select names of people involved; (hold CTRL key for multiple selection)')\">\n"; my %ku; for (keys(%USERS)) { $ku{$USERS{$_}{FULLNAME}} = $_; } for (sort(keys(%ku))) { @@ -410,21 +410,21 @@ =head1 Query string parameter } #FB-was: for my $ulogin (sort keys(%USERS)) { -#FB-was: my $sel = ""; -#FB-was: if ($USERS{$ulogin}{UID} ~~ @sel_oper) { $sel = ' selected '} -#FB-was: print "\n"; +#FB-was: my $sel = ""; +#FB-was: if ($USERS{$ulogin}{UID} ~~ @sel_oper) { $sel = ' selected '} +#FB-was: print "\n"; #FB-was:} print ""; #djl-del: print "

            "; +#djl-del: readonly cols=\"20\" rows=\"10\" name=\"nomselect\" value=\"\">

            "; # currently read or selected people print "

            \n"; + onMouseOut=\"nd()\" onmouseover=\"overlib('currently selected people')\">\n"; print "

            \n"; print "
            Météo et Observations\n -

            "; +

            Description météo:
            "; #print "
            Description météo:

            \n"; print "

            Température de l'air (en °C) =
            \n -

            \n"; +

            \n"; print "

            - Observations:
            - Information de saisie: $val -

            "; + Observations:
            + Information de saisie: $val +

            "; print "
            		 -
            Mesures de distance (mm)\n"; +
            Mesures de distance (mm)\n"; print "

            - Offset extensomètre (en mm)
            \n - Ruban: (en mm)
            \n - Mesures: (mm)
            "; + Offset extensomètre (en mm)
            \n + Ruban: (en mm)
            \n + Mesures: (mm)
            "; for my $ix (@donneeListe) { #djl-was: print "$_. \n"; print "

            Moyenne (mm) = - 2 × Écart-type (mm) =

            \n"; + 2 × Écart-type (mm) =

            \n"; print "

            Dernière mesure du site =

            \n"; # Hidden variables diff --git a/CODE/cgi-bin/formGAZ.pl b/CODE/cgi-bin/formGAZ.pl index 6d03eb47..c044bb3a 100755 --- a/CODE/cgi-bin/formGAZ.pl +++ b/CODE/cgi-bin/formGAZ.pl @@ -122,39 +122,39 @@ =head1 Query string parameter function suppress(level) { - var str = '@{[ $FORM->conf('TITLE') ]} ?'; - if (level > 1) { - if (!confirm('$__{'WARNING: do you want PERMANENTLY remove this record from '}' + str)) { - return false; - } - } else { - if (document.formulaire.id.value > 0) { - if (!confirm('$__{'Do you want to remove this record from '}' + str)) { - return false; - } - } else { - if (!confirm('$__{'Do you want to restore this record in '}' + str)) { - return false; - } - } - } - document.formulaire.delete.value = level; - submit(); + var str = '@{[ $FORM->conf('TITLE') ]} ?'; + if (level > 1) { + if (!confirm('$__{'WARNING: do you want PERMANENTLY remove this record from '}' + str)) { + return false; + } + } else { + if (document.formulaire.id.value > 0) { + if (!confirm('$__{'Do you want to remove this record from '}' + str)) { + return false; + } + } else { + if (!confirm('$__{'Do you want to restore this record in '}' + str)) { + return false; + } + } + } + document.formulaire.delete.value = level; + submit(); } function verif_formulaire() { - if(document.formulaire.site.value == "") { - alert("Veuillez spécifier le site de prélèvement!"); - document.formulaire.site.focus(); - return false; - } - if(document.formulaire.type.value == "") { - alert("Veuillez entrer un type d'ampoule!"); - document.formulaire.type.focus(); - return false; - } - submit(); + if(document.formulaire.site.value == "") { + alert("Veuillez spécifier le site de prélèvement!"); + document.formulaire.site.focus(); + return false; + } + if(document.formulaire.type.value == "") { + alert("Veuillez entrer un type d'ampoule!"); + document.formulaire.type.focus(); + return false; + } + submit(); } function calc() @@ -163,12 +163,12 @@ =head1 Query string parameter function submit() { - \$.post("/cgi-bin/@{[ $FORM->conf('CGI_POST') ]}", \$("#theform").serialize(), function(data) { - //var contents = \$( data ).find( '#contents' ).text(); - alert(data); - document.location="/cgi-bin/@{[ $FORM->conf('CGI_SHOW') ]}"; - } - ); + \$.post("/cgi-bin/@{[ $FORM->conf('CGI_POST') ]}", \$("#theform").serialize(), function(data) { + //var contents = \$( data ).find( '#contents' ).text(); + alert(data); + document.location="/cgi-bin/@{[ $FORM->conf('CGI_SHOW') ]}"; + } + ); } //window.captureEvents(Event.KEYDOWN); @@ -248,7 +248,7 @@ =head1 Query string parameter print "{id}\">"; if ($val ne "") { print "

            Information de saisie: $val -

            "; +

            "; } print ""; if (clientHasAdm(type=>"authforms", name=>"GAZ")) { @@ -262,9 +262,9 @@ =head1 Query string parameter print ""; print ""; print " +
            + + +
            + _EOD_ # Form buttons diff --git a/CODE/cgi-bin/formGRIDMAPS.pl b/CODE/cgi-bin/formGRIDMAPS.pl index 68f01fd7..6a07136d 100755 --- a/CODE/cgi-bin/formGRIDMAPS.pl +++ b/CODE/cgi-bin/formGRIDMAPS.pl @@ -21,9 +21,9 @@ =head1 DESCRIPTION A submitted B will have its results (output maps) files grouped into the OUTR directory, under a subdirectory whose name uniquely identifies the Request: - OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID - REQUEST.rc - GRIDMAPS/{exports,maps}/ + OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID + REQUEST.rc + GRIDMAPS/{exports,maps}/ See postGRIDMAPS.pl documentation for further Gridmaps Request's execution/parameters description. @@ -35,20 +35,20 @@ =head1 RELATED GRID CONFIGURATION PARAMETERS a chance to overwrite corresponding values for request execution. Such parameters will be appended to the REQUEST.rc file as 'GRID.gridname.originalKey|user's value' - Example: - REQUEST_GRID_KEYLIST|NODE_SIZE,NODE_RGB,NODE_FONTSIZE,NODE_MARKER - will appear in REQUEST.rc as: - GRID.THISGRID.NODE_SIZE|15 - GRID.THISGRID.NODE_RGB|1,0,0 - GRID.THISGRID.NODE_FONTSIZE|0 - GRID.THIDGRID.NODE_MARKER|o + Example: + REQUEST_GRID_KEYLIST|NODE_SIZE,NODE_RGB,NODE_FONTSIZE,NODE_MARKER + will appear in REQUEST.rc as: + GRID.THISGRID.NODE_SIZE|15 + GRID.THISGRID.NODE_RGB|1,0,0 + GRID.THISGRID.NODE_FONTSIZE|0 + GRID.THIDGRID.NODE_MARKER|o =head1 DATE SPAN AND PARAMETERS Date span allows to select the validity interval of NODES: - A start date - An end date + A start date + An end date Parameters (list of keys and default values are taken from GRIDMAPS.rc). @@ -131,39 +131,39 @@ =head1 DATE SPAN AND PARAMETERS @@ -203,7 +203,7 @@ =head1 DATE SPAN AND PARAMETERS print "
            $__{'Date span (NODES validity)'}"; -# DATE1| DATE2| +# DATE1| DATE2| print "
            -
            Date et lieu du prélèvement -

            - Date: "; for (@anneeListe) { if ($_ == $sel_annee) { print ""; } else { print ""; } } @@ -313,9 +313,9 @@ =head1 Query string parameter print "

            "; print "
            Mesures sur site\n -

            - Température de la fumerolle (en °C) =
            \n - pH =
            \n"; +

            + Température de la fumerolle (en °C) =
            \n + pH =
            \n"; print "Débit (qualitatif) =

            ); if ($val ne "") { print qq(

            Record timestamp: $val -

            ); +

            ); } if ($action eq "edit" && $id ne "") { if ($trash eq "1") { @@ -532,10 +532,10 @@ =head1 Query string parameter } } print qq(
            - Site: - + ); print @NODESSelList; for (@NODESSelList) { my @cle = split(/\|/,$_); @@ -544,7 +544,7 @@ =head1 Query string parameter } print qq(
            -
            $__{'Operator(s)'}: +
            $__{'Operator(s)'}: -
            -

            +
            +

            ); foreach (@columns) { @@ -602,12 +602,12 @@ =head1 Query string parameter for (@list_keys) { my $selected = ($prev_inputs{$field} eq "$_" ? "checked":""); print qq( ); + onMouseOut="nd()" onmouseover="overlib('$list{$_}{name}')">); } print "$dlm"; } else { print qq($txt = - - -
            "; print ""; print " + +
            "; @@ -215,7 +215,7 @@ =head1 DATE SPAN AND PARAMETERS for (@monthList) { print "$_\n"; } print ""; print "
            "; print "$__{'End date'}: "; } print " - - -

            $titrePage

            \n

            $titre2

            $nodevalidity
            "; +

            $titrePage

            \n

            $titre2

            $nodevalidity
            "; print "\n"; print "\n"; @@ -970,7 +970,7 @@ =head1 Query string parameters for (@monthList) { print "$_\n"; } print ""; print "
            "; print "$__{'End date'}: "; -for ($usrYearP,@yearListP) { print "$_\n"; } +for ($usrYearP,@yearListP) { print "$_\n"; } print ""; print "
            "; print "\n"; @@ -1405,9 +1405,9 @@ =head1 Query string parameters } # --- Propagates any other Proc's parameters (hidden) -# PROC.*.* = other proc's parameters -# ^* = list of selected parameters formerly associated with all proc): they have been used at the begining of this script -# to fill the default values in form, but will be also propagated to all other associated procs (see postNODE.pl) +# PROC.*.* = other proc's parameters +# ^* = list of selected parameters formerly associated with all proc): they have been used at the begining of this script +# to fill the default values in form, but will be also propagated to all other associated procs (see postNODE.pl) for (keys(%NODE)) { if ( !($_ =~ /^$GRIDType\.$GRIDName\./) && $_ =~ /^VIEW\.|^PROC\.|^FDSN_NETWORK_CODE$|^UTC_DATA$|^ACQ_RATE$|^RAWFORMAT$|^RAWDATA$|^CHANNEL_LIST$|^FID/ ) { @@ -1417,11 +1417,11 @@ =head1 Query string parameters ## # --- "Validity" ## if ( clientHasAdm(type=>"authmisc",name=>"NODES")) { -## print "

            " -## ."$__{'Valid Node'}

            \n"; +## print "

            " +## ."$__{'Valid Node'}

            \n"; ## } else { -## print ""; +## print ""; ## } print "
            "; if ($val ne "") { print "

            Information de saisie: $val -

            "; +

            "; } print ""; if (clientHasAdm(type=>"authforms",name=>"RIVERS")) { @@ -296,9 +296,9 @@ =head1 Query string parameter print ""; print ""; print " - - - - - - - - - - - - - - - }; + + + + + + + + + + + + + + + + }; } print ""; @@ -353,54 +353,54 @@ sub fetch_all {
              Scheduler status
            -
            -
            $schedstatus
            -
            +
            +
            $schedstatus
            +

            - - - - -

            Edit job definition

            - -
            - -
            - -
            - -
            - -
            - -
            - -
            - -
            - -
            -

            - -

            - + + + + +

            Edit job definition

            + +
            + +
            + +
            + +
            + +
            + +
            + +
            + +
            + +
            +

            + +

            +
              Jobs definitions 
            -
            -  Jobs defined: $jobsdefsCount (currently activated: $jobsdefsCountValid) - $jobsdefsMsg -
            -
            -
            -
            -
            Date et lieu du prélèvement -

            - Date: "; for (@anneeListe) { if ($_ == $sel_annee) { print ""; } else { print ""; } } diff --git a/CODE/cgi-bin/formSOILSOLUTION.pl b/CODE/cgi-bin/formSOILSOLUTION.pl index 82d08d30..a848f3bf 100755 --- a/CODE/cgi-bin/formSOILSOLUTION.pl +++ b/CODE/cgi-bin/formSOILSOLUTION.pl @@ -145,14 +145,14 @@ =head1 Query string parameter var form = document.formulaire; if (form.site.value != "") { - var array = lastData[form.site.value + "_" + form.depth.value].split("|"); - var date = array[1].split("-"); - var time = array[2].split(":"); - form.y1.value = date[0]; - form.m1.value = date[1]; - form.d1.value = date[2]; - form.hr1.value = time[0]; - form.mn1.value = time[1]; + var array = lastData[form.site.value + "_" + form.depth.value].split("|"); + var date = array[1].split("-"); + var time = array[2].split(":"); + form.y1.value = date[0]; + form.m1.value = date[1]; + form.d1.value = date[2]; + form.hr1.value = time[0]; + form.mn1.value = time[1]; } update_form(); } @@ -323,7 +323,7 @@ =head1 Query string parameter print qq(

            ); if ($val ne "") { print qq(

            $__{'Input Information'}: $val -

            ); +

            ); } print qq(); if (clientHasAdm(type=>"authforms",name=>"SOILSOLUTION")) { @@ -339,9 +339,9 @@ =head1 Query string parameter
            $__{'Sampling Location and Time'}

            - $__{'Site'}: - ); print qq() if ($QryParm->{id} eq ""); for (@NODESSelList) { @@ -466,8 +466,8 @@ =head1 Query string parameter } } print qq( -
            - $__{'Water Level'} (filled) =
            + $__{'Water Level'} (filled) =

            diff --git a/CODE/cgi-bin/formUPLOAD.pl b/CODE/cgi-bin/formUPLOAD.pl index 21edc89b..377290c4 100755 --- a/CODE/cgi-bin/formUPLOAD.pl +++ b/CODE/cgi-bin/formUPLOAD.pl @@ -19,18 +19,18 @@ =head1 DESCRIPTION =head1 QUERY-STRING - object= - fully qualified grid name OR node name, ie. gridtype.gridname[.nodename] - Document root path will be derived from object= , either: - $GRIDS{PATH_GRIDS}/gridtype/gridname or - $NODES{PATH_NODES}/nodename + object= + fully qualified grid name OR node name, ie. gridtype.gridname[.nodename] + Document root path will be derived from object= , either: + $GRIDS{PATH_GRIDS}/gridtype/gridname or + $NODES{PATH_NODES}/nodename - doc= - type of document, ie. target directory for document to be uploaded, within the root path derived from object= - one of: "SPATH_DOCUMENTS", "SPATH_PHOTOS", "SPATH_SCHEMES", "SPATH_INTERVENTIONS" + doc= + type of document, ie. target directory for document to be uploaded, within the root path derived from object= + one of: "SPATH_DOCUMENTS", "SPATH_PHOTOS", "SPATH_SCHEMES", "SPATH_INTERVENTIONS" - event= - only required if doc is SPATH_INTERVENTIONS: filename of Event or Project (intervention) + event= + only required if doc is SPATH_INTERVENTIONS: filename of Event or Project (intervention) =cut @@ -122,60 +122,60 @@ =head1 QUERY-STRING FIN @@ -217,8 +217,8 @@ =head1 QUERY-STRING print ""; print "
            $__{'Upload new file(s)'} Note: $__{'Avoid special characters and spaces in filename'} -
            -

            "; +
            +

            "; print "
            "; print ""; diff --git a/CODE/cgi-bin/formVEHICLES.pl b/CODE/cgi-bin/formVEHICLES.pl index 981d6cd8..ab7d1b58 100755 --- a/CODE/cgi-bin/formVEHICLES.pl +++ b/CODE/cgi-bin/formVEHICLES.pl @@ -115,22 +115,22 @@ =head1 Query string parameter function verif_formulaire() { - if(document.formulaire.site.value == \"\") { - alert(\"Veuillez spécifier le site de prélèvement!\"); - document.formulaire.site.focus(); - return false; - } - if(document.formulaire.type.value == \"\") { - alert(\"Veuillez entrer un type d'ampoule!\"); - document.formulaire.type.focus(); - return false; - } + if(document.formulaire.site.value == \"\") { + alert(\"Veuillez spécifier le site de prélèvement!\"); + document.formulaire.site.focus(); + return false; + } + if(document.formulaire.type.value == \"\") { + alert(\"Veuillez entrer un type d'ampoule!\"); + document.formulaire.type.focus(); + return false; + } \$.post(\"/cgi-bin/".$FORM->conf('CGI_POST')."\", \$(\"#theform\").serialize(), function(data) { - //var contents = \$( data ).find( '#contents' ).text(); - alert(data); - document.location=\"/cgi-bin/".$FORM->conf('CGI_SHOW')."\"; - } - ); + //var contents = \$( data ).find( '#contents' ).text(); + alert(data); + document.location=\"/cgi-bin/".$FORM->conf('CGI_SHOW')."\"; + } + ); } function calc() @@ -202,9 +202,9 @@ =head1 Query string parameter print ""; print ""; print ""; #print ""; #print ""; print ""; @@ -1712,33 +1712,33 @@ sub compute_energy { function resetDate1(x) { - if (x == 0) document.formulaire.m1.value = "01"; - if (x <= 1) document.formulaire.d1.value = "01"; - if (x <= 2) document.formulaire.h1.value = "00"; + if (x == 0) document.formulaire.m1.value = "01"; + if (x <= 1) document.formulaire.d1.value = "01"; + if (x <= 2) document.formulaire.h1.value = "00"; } function resetDate2(x) { - if (x == 0) document.formulaire.m2.value = "12"; - if (x <= 1) document.formulaire.d2.value = "31"; - if (x <= 2) document.formulaire.h2.value = "23"; + if (x == 0) document.formulaire.m2.value = "12"; + if (x <= 1) document.formulaire.d2.value = "31"; + if (x <= 2) document.formulaire.h2.value = "23"; } function effaceFiltre() { - document.formulaire.obs.value = ""; + document.formulaire.obs.value = ""; } function dumpData(d) { - document.formulaire.dump.value = d; - document.formulaire.setAttribute("target", "_blank"); - document.formulaire.submit(); + document.formulaire.dump.value = d; + document.formulaire.setAttribute("target", "_blank"); + document.formulaire.submit(); } function display() { - document.formulaire.dump.value = ""; - document.formulaire.setAttribute("target", ""); - document.formulaire.submit(); + document.formulaire.dump.value = ""; + document.formulaire.setAttribute("target", ""); + document.formulaire.submit(); } //--> @@ -1750,14 +1750,14 @@ sub compute_energy { print <<"ENDBOTOFPAGE";
            diff --git a/CODE/cgi-bin/nedit.pl b/CODE/cgi-bin/nedit.pl index e8a69cde..93386ac9 100755 --- a/CODE/cgi-bin/nedit.pl +++ b/CODE/cgi-bin/nedit.pl @@ -19,20 +19,20 @@ =head1 Query string parameters =item B - normnode := gridtype.gridname.nodename - The fully qualified (normalized) nodename in gridtype.gridname context + normnode := gridtype.gridname.nodename + The fully qualified (normalized) nodename in gridtype.gridname context =item B - filespec := [relpath/]name - The file to be edited, relative to $NODES{PATH_NODES}/nodename/ + filespec := [relpath/]name + The file to be edited, relative to $NODES{PATH_NODES}/nodename/ =item B - string := { edit | save } - 'edit' (default when action is not specified) to display edit html-form edit - 'save' internaly used to save the file after html-form edition - (other parameters are used along with 'save': ts0, txt) + string := { edit | save } + 'edit' (default when action is not specified) to display edit html-form edit + 'save' internaly used to save the file after html-form edition + (other parameters are used along with 'save': ts0, txt) =back @@ -168,16 +168,16 @@ =head1 Markitup customization function verif_formulaire() { \$.post(\"$me\", \$(\"#theform\").serialize(), function(data) { - if (data != '') alert(data); - location.href = document.referrer; - }); + if (data != '') alert(data); + location.href = document.referrer; + }); } function convert2MMD() { - if (confirm(\"Presentation might be affected by conversion,\\nrequiring manual editing.\")) { - \$(\"#theform\")[0].conv.value = \"1\"; - verif_formulaire(); - } + if (confirm(\"Presentation might be affected by conversion,\\nrequiring manual editing.\")) { + \$(\"#theform\")[0].conv.value = \"1\"; + verif_formulaire(); + } } @@ -190,15 +190,15 @@ =head1 Markitup customization "; if (length($meta) > 0) { print " - "; + "; } else { print " - "; + "; } print " diff --git a/CODE/cgi-bin/nloc.pl b/CODE/cgi-bin/nloc.pl index e6ab2ef1..d3c0331f 100755 --- a/CODE/cgi-bin/nloc.pl +++ b/CODE/cgi-bin/nloc.pl @@ -90,15 +90,15 @@ =head1 Query string parameters print $cgi->header(-type=>'application/vnd.google-earth.kml+xml', -attachment=>"$file.kml",-charset=>'utf-8'); print "\n"; print "\n\n"; + + ff1313f3 + 1.0 + \nhttp://maps.google.com/mapfiles/kml/shapes/triangle.png + + + 1 + + \n"; if (scalar(@NID)==2) { print "\n$grid\n"; } @@ -145,25 +145,25 @@ =head1 Query string parameters switch (lc($format)) { case 'kml' { print " - $alias : $name - - - $active - - - $start - - - $end - - - - $type
            $DOMAINS{$GRID{DOMAIN}}{NAME} / $GRID{NAME}
            ($GRIDType.$GRIDName.$sta)]]> -             - 1\n#webobs - - $NODE{$sta}{LON_WGS84},$NODE{$sta}{LAT_WGS84},$NODE{$sta}{ALTITUDE} - + $alias : $name + + + $active + + + $start + + + $end + + + + $type
            $DOMAINS{$GRID{DOMAIN}}{NAME} / $GRID{NAME}
            ($GRIDType.$GRIDName.$sta)]]> +             + 1\n#webobs + + $NODE{$sta}{LON_WGS84},$NODE{$sta}{LAT_WGS84},$NODE{$sta}{ALTITUDE} +             \n"; } case 'csv' { diff --git a/CODE/cgi-bin/nsearch.pl b/CODE/cgi-bin/nsearch.pl index 7a26d7d4..4e7264d0 100755 --- a/CODE/cgi-bin/nsearch.pl +++ b/CODE/cgi-bin/nsearch.pl @@ -17,38 +17,38 @@ =head1 Query String parametres =over =item B - The regexp to be searched for + The regexp to be searched for =item B - one of the keywords above, selecting all grids by type, OR a list of grids - (list of '+' delimited grid names. eg: +VIEW.SISMCEA+VIEW.SISMMAR) + one of the keywords above, selecting all grids by type, OR a list of grids + (list of '+' delimited grid names. eg: +VIEW.SISMCEA+VIEW.SISMMAR) =item B - = OK to search into CLB files. Default is "OK" + = OK to search into CLB files. Default is "OK" =item B - = OK to search into EVENTS files. Default is "OK" + = OK to search into EVENTS files. Default is "OK" =item B - = OK to search into node's information files (*.txt and FEATURES/*.txt). Default is "OK" + = OK to search into node's information files (*.txt and FEATURES/*.txt). Default is "OK" -=item B - = +=item B + = -=item B - = case sensitivity +=item B + = case sensitivity -=item B - = for a hit, show immediate context (grep output line), or extend to show all file. +=item B + = for a hit, show immediate context (grep output line), or extend to show all file. =item B + B + B - search starting from year1/month1/day1 + search starting from year1/month1/day1 =item B + B + B - search ending on year2/month2/day2 + search ending on year2/month2/day2 =item B - internal developer's switch to turn on debug messages + internal developer's switch to turn on debug messages =back @@ -360,9 +360,9 @@ =head1 Query String parametres if (($QryParm->{'year1'} eq "" || $date ge "$QryParm->{'year1'}-$QryParm->{'month1'}-$QryParm->{'day1'}") && ($QryParm->{'year2'} eq "" || $date le "$QryParm->{'year2'}-$QryParm->{'month2'}-$QryParm->{'day2'}")) { my $fileInterventions = "$pathInterventions/$file"; - my @intervention = grep(!/^$/, readFile($fileInterventions)); # lit le fichier et vire les lignes vides + my @intervention = grep(!/^$/, readFile($fileInterventions)); # lit le fichier et vire les lignes vides chomp(@intervention); - my @pLigne = split(/\|/,$intervention[0]); # ligne de titre/operateurs + my @pLigne = split(/\|/,$intervention[0]); # ligne de titre/operateurs my @listeNoms = split(/\+/,$pLigne[0]); #my $noms = join(", ",nomOperateur(@listeNoms)); @@ -371,7 +371,7 @@ =head1 Query String parametres shift(@intervention); my $modif = ""; ##if ($editOK == 1) { - ## $modif = "\"$__{'Edit...'}\""; + ## $modif = "\"$__{'Edit...'}\""; ##} $FHits++; $HTMLresults .= "

          • $titre $date $heure ($noms) $modif

            \n" diff --git a/CODE/cgi-bin/postGRIDMAPS.pl b/CODE/cgi-bin/postGRIDMAPS.pl index d8a42368..4bc99f34 100755 --- a/CODE/cgi-bin/postGRIDMAPS.pl +++ b/CODE/cgi-bin/postGRIDMAPS.pl @@ -18,17 +18,17 @@ =head1 DESCRIPTION 2) Builds the B file: image of the formGRIDMAPS's input-form fields to which is added $CLIENT's UID; see REQUEST.rc below. - + 3) Builds the GRIDMAPS' routine command line and submits it to the WebObs scheduler for immediate execution, using the scheduler's B submit command (see scheduler.pl perldoc). The job-definition-string UID: parameter of each submit command will be identical to the REQUEST.rc UID. Example of a job-definition-string : - XEQ1: Proc-SUBMIT_COMMAND, - XEQ2: OUTR-Path, - RES: Proc-SUBMIT_RESOURCE, - LOGPATH: Job-LogPath, - UID: $CLIENT's UID + XEQ1: Proc-SUBMIT_COMMAND, + XEQ2: OUTR-Path, + RES: Proc-SUBMIT_RESOURCE, + LOGPATH: Job-LogPath, + UID: $CLIENT's UID 4) Processes executed from B may choose to send their own 'notification' event to the WebObs PostBoard using perl's B or the B function. @@ -46,42 +46,42 @@ =head1 USING THE NOTIFICATIONS SYSTEM 2) Sending a notification to trigger email(s) from a PROC's routine, requires the following definitions and actions: - a) define an "event-id" identifying the notification so that PostBoard knows what to do with it: in this case, sending email - to who with what subject. This has to be defined in the WEBOBSUSERS.db database - table "NOTIFICATIONS". + a) define an "event-id" identifying the notification so that PostBoard knows what to do with it: in this case, sending email + to who with what subject. This has to be defined in the WEBOBSUSERS.db database - table "NOTIFICATIONS". - b) each PROC's routine can thus have their own "event-id" defined (with specific mail subject, mail recipients) BUT they also can use - the event-id "formreq." (don't forget the ending dot!), that is automatically defined as part of WebObs installation, and is intended to be - a 'common/default' event-id for all 'Requests for Graphs' routines. + b) each PROC's routine can thus have their own "event-id" defined (with specific mail subject, mail recipients) BUT they also can use + the event-id "formreq." (don't forget the ending dot!), that is automatically defined as part of WebObs installation, and is intended to be + a 'common/default' event-id for all 'Requests for Graphs' routines. - c) The WebOb's UID (or GID) defined as the addressee (recipient) of email in the NOTIFICATIONS table for the "event-id", may be OVERIDDEN - with a UID dynamically specified (ie. at PROC's routine run time) in the notification message itself (thru the uid= keyword, again read postboard.pl perldoc). - As an example, a typical PROC's routine notification will use the UID parameter found in its REQUEST.rc file to build its notification uid= keyword - (mainly because it references the WebObs $CLIENT's uid that submitted the PROC's request). + c) The WebOb's UID (or GID) defined as the addressee (recipient) of email in the NOTIFICATIONS table for the "event-id", may be OVERIDDEN + with a UID dynamically specified (ie. at PROC's routine run time) in the notification message itself (thru the uid= keyword, again read postboard.pl perldoc). + As an example, a typical PROC's routine notification will use the UID parameter found in its REQUEST.rc file to build its notification uid= keyword + (mainly because it references the WebObs $CLIENT's uid that submitted the PROC's request). - d) the 'sender-id' specified in a notification has no special meaning to the system, except if it is a valid email address, in which case - PostBoard will use it as the 'From:' mail's tag. + d) the 'sender-id' specified in a notification has no special meaning to the system, except if it is a valid email address, in which case + PostBoard will use it as the 'From:' mail's tag. - e) the 'file=' keyword in the notification message can be used to specify a filename whose contents will be inserted in the generated email text. - This is basically another (and optional) customization/standardization of the mail being sent from a PROC. + e) the 'file=' keyword in the notification message can be used to specify a filename whose contents will be inserted in the generated email text. + This is basically another (and optional) customization/standardization of the mail being sent from a PROC. =head1 REQUEST.rc - DATE1| - DATE2| - DPI| - PAPERSIZE_INCHES| - ... (complete list of keys from GRIDMAPS.rc) - ORIGIN| - UID| - PROC.procname.key| (optional, as many as given by formGRIDMAPS.pl) - VIEW.viewname.key| (optional, as many as given by formGRIDMAPS.pl) + DATE1| + DATE2| + DPI| + PAPERSIZE_INCHES| + ... (complete list of keys from GRIDMAPS.rc) + ORIGIN| + UID| + PROC.procname.key| (optional, as many as given by formGRIDMAPS.pl) + VIEW.viewname.key| (optional, as many as given by formGRIDMAPS.pl) =head1 OUTR REQUEST subdirectory - OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID - REQUEST.rc - GRIDMAPS/ - {exports,maps}/ + OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID + REQUEST.rc + GRIDMAPS/ + {exports,maps}/ =cut diff --git a/CODE/cgi-bin/postNODE.pl b/CODE/cgi-bin/postNODE.pl index 4a3324d0..629c75ad 100755 --- a/CODE/cgi-bin/postNODE.pl +++ b/CODE/cgi-bin/postNODE.pl @@ -149,7 +149,7 @@ =head1 Query string parameters # ---- checking if user is a THEIA user and if he wants to save data in metadatabase # my $theiaAuth = $WEBOBS{THEIA_USER_FLAG}; -my $saveAuth = $cgi->param('saveAuth') // ''; +my $saveAuth = $cgi->param('saveAuth') // ''; # ---- where are the NODE's directory and NODE's conf file ? my %allNodeGrids = WebObs::Grids::listNodeGrids(node=>$NODEName); @@ -159,7 +159,7 @@ =head1 Query string parameters # ---- If deleting NODE, do not wait for further information # -my $producer = $cgi->param('producer') // ''; # information needed to delete the NODE's related row in the metadata DB +my $producer = $cgi->param('producer') // ''; # information needed to delete the NODE's related row in the metadata DB if ($delete) { @@ -179,8 +179,8 @@ =head1 Query string parameters # --- connecting to the database my $driver = "SQLite"; my $database = $WEBOBS{SQL_METADATA}; - my $dsn = "DBI:$driver:dbname=$database"; - my $userid = ""; + my $dsn = "DBI:$driver:dbname=$database"; + my $userid = ""; my $password = ""; my $dbh = DBI->connect($dsn, $userid, $password, { RaiseError => 1 }) or die $DBI::errstr; @@ -221,10 +221,10 @@ =head1 Query string parameters my $desc1 = $desc; $desc1 =~ s/\r\n/
            /g; my $creator = $cgi->param('creators') // ''; my $theme = $cgi->param('theme') // ''; -my @roles = $cgi->param('role'); +my @roles = $cgi->param('role'); my @firstNames = $cgi->param('firstName'); my @lastNames = $cgi->param('lastName'); -my @emails = $cgi->param('email'); +my @emails = $cgi->param('email'); my @topics = $cgi->param('topics'); my $lineage = $cgi->param('lineage') // ''; my $tz = $cgi->param('tz') // ''; @@ -480,8 +480,8 @@ =head1 Query string parameters # --- connecting to the database my $driver = "SQLite"; my $database = $WEBOBS{SQL_METADATA}; - my $dsn = "DBI:$driver:dbname=$database"; - my $userid = ""; + my $dsn = "DBI:$driver:dbname=$database"; + my $userid = ""; my $password = ""; # --- station informations, coordinates are saved in WKT format diff --git a/CODE/cgi-bin/postREQ.pl b/CODE/cgi-bin/postREQ.pl index 14e5b77e..38e9c511 100755 --- a/CODE/cgi-bin/postREQ.pl +++ b/CODE/cgi-bin/postREQ.pl @@ -25,11 +25,11 @@ =head1 DESCRIPTION job-definition-string UID: parameter of each submit command will be identical to the REQUEST.rc UID. Example of a job-definition-string : - XEQ1: Proc-SUBMIT_COMMAND, - XEQ2: OUTR-Path, - RES: Proc-SUBMIT_RESOURCE, - LOGPATH: Job-LogPath, - UID: $CLIENT's UID + XEQ1: Proc-SUBMIT_COMMAND, + XEQ2: OUTR-Path, + RES: Proc-SUBMIT_RESOURCE, + LOGPATH: Job-LogPath, + UID: $CLIENT's UID 4) Processes executed from B may choose to send their own 'notification' event to the WebObs PostBoard using perl's B or the B function. @@ -47,54 +47,54 @@ =head1 USING THE NOTIFICATIONS SYSTEM 2) Sending a notification to trigger email(s) from a PROC's routine, requires the following definitions and actions: - a) define an "event-id" identifying the notification so that PostBoard knows what to do with it: in this case, sending email - to who with what subject. This has to be defined in the WEBOBSUSERS.db database - table "NOTIFICATIONS". + a) define an "event-id" identifying the notification so that PostBoard knows what to do with it: in this case, sending email + to who with what subject. This has to be defined in the WEBOBSUSERS.db database - table "NOTIFICATIONS". - b) each PROC's routine can thus have their own "event-id" defined (with specific mail subject, mail recipients) BUT they also can use - the event-id "formreq." (don't forget the ending dot!), that is automatically defined as part of WebObs installation, and is intended to be - a 'common/default' event-id for all 'Requests for Graphs' routines. + b) each PROC's routine can thus have their own "event-id" defined (with specific mail subject, mail recipients) BUT they also can use + the event-id "formreq." (don't forget the ending dot!), that is automatically defined as part of WebObs installation, and is intended to be + a 'common/default' event-id for all 'Requests for Graphs' routines. - c) The WebOb's UID (or GID) defined as the addressee (recipient) of email in the NOTIFICATIONS table for the "event-id", may be OVERIDDEN - with a UID dynamically specified (ie. at PROC's routine run time) in the notification message itself (thru the uid= keyword, again read postboard.pl perldoc). - As an example, a typical PROC's routine notification will use the UID parameter found in its REQUEST.rc file to build its notification uid= keyword - (mainly because it references the WebObs $CLIENT's uid that submitted the PROC's request). + c) The WebOb's UID (or GID) defined as the addressee (recipient) of email in the NOTIFICATIONS table for the "event-id", may be OVERIDDEN + with a UID dynamically specified (ie. at PROC's routine run time) in the notification message itself (thru the uid= keyword, again read postboard.pl perldoc). + As an example, a typical PROC's routine notification will use the UID parameter found in its REQUEST.rc file to build its notification uid= keyword + (mainly because it references the WebObs $CLIENT's uid that submitted the PROC's request). - d) the 'sender-id' specified in a notification has no special meaning to the system, except if it is a valid email address, in which case - PostBoard will use it as the 'From:' mail's tag. + d) the 'sender-id' specified in a notification has no special meaning to the system, except if it is a valid email address, in which case + PostBoard will use it as the 'From:' mail's tag. - e) the 'file=' keyword in the notification message can be used to specify a filename whose contents will be inserted in the generated email text. - This is basically another (and optional) customization/standardization of the mail being sent from a PROC. + e) the 'file=' keyword in the notification message can be used to specify a filename whose contents will be inserted in the generated email text. + This is basically another (and optional) customization/standardization of the mail being sent from a PROC. =head1 REQUEST.rc - DATE1| - DATE2| - TZ| - DATESTR| - PPI| - MARKERSIZE| - LINEWIDTH| - CUMULATE| - DECIMATE| - PLOTGRID| - PDFOUTPUT| - SVGOUTPUT| - EXPORTS| - ANONYMOUS| - DEBUG| - ORIGIN| - UID| - PROC.procname.key| (optional, as many as given by formREQ.pl) + DATE1| + DATE2| + TZ| + DATESTR| + PPI| + MARKERSIZE| + LINEWIDTH| + CUMULATE| + DECIMATE| + PLOTGRID| + PDFOUTPUT| + SVGOUTPUT| + EXPORTS| + ANONYMOUS| + DEBUG| + ORIGIN| + UID| + PROC.procname.key| (optional, as many as given by formREQ.pl) =head1 OUTR REQUEST subdirectory - OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID - REQUEST.rc - PROC.PROCa/ - {exports,graphs,maps,logs}/ - .... - PROC.PROCz/ - {exports,graphs,maps,logs}/ + OUTR/YYYYMMDD_HHMMSS_HOSTNAME_UID + REQUEST.rc + PROC.PROCa/ + {exports,graphs,maps,logs}/ + .... + PROC.PROCz/ + {exports,graphs,maps,logs}/ =cut diff --git a/CODE/cgi-bin/postUPLOAD.pl b/CODE/cgi-bin/postUPLOAD.pl index e18f294a..7e39e2d5 100755 --- a/CODE/cgi-bin/postUPLOAD.pl +++ b/CODE/cgi-bin/postUPLOAD.pl @@ -21,27 +21,27 @@ =head1 DESCRIPTION =head1 HTML-Form fields object= - required fully qualified grid name OR node name, ie. gridtype.gridname[.nodename] - Document root path will be derived from object= , either: - $GRIDS{PATH_GRIDS}/gridtype/gridname or - $NODES{PATH_NODES}/nodename + required fully qualified grid name OR node name, ie. gridtype.gridname[.nodename] + Document root path will be derived from object= , either: + $GRIDS{PATH_GRIDS}/gridtype/gridname or + $NODES{PATH_NODES}/nodename doc= - type of document, ie. target directory for document to be uploaded, within the root path derived from object= - one of: "SPATH_DOCUMENTS", "SPATH_PHOTOS", "SPATH_SCHEMES", "SPATH_INTERVENTIONS" + type of document, ie. target directory for document to be uploaded, within the root path derived from object= + one of: "SPATH_DOCUMENTS", "SPATH_PHOTOS", "SPATH_SCHEMES", "SPATH_INTERVENTIONS" event= - only required if doc is SPATH_INTERVENTIONS: filename of Event or Project (intervention) + only required if doc is SPATH_INTERVENTIONS: filename of Event or Project (intervention) nb= - required, number of existing files, is used as upper boundary for 'del{X}' below + required, number of existing files, is used as upper boundary for 'del{X}' below uploadFile{N}= - optional, one for each file to be uploaded (ie. saved to subdirectory 'doc'), indexed with N + optional, one for each file to be uploaded (ie. saved to subdirectory 'doc'), indexed with N del{X}= - optional, one for each existing file in 'doc' that will be deleted by this request, - indexed with X = {1..nb} + optional, one for each existing file in 'doc' that will be deleted by this request, + indexed with X = {1..nb} =cut diff --git a/CODE/cgi-bin/register.pl b/CODE/cgi-bin/register.pl index 9d4e2895..17d12da7 100755 --- a/CODE/cgi-bin/register.pl +++ b/CODE/cgi-bin/register.pl @@ -236,15 +236,15 @@ sub uid_exists { print <<__EOD__; - - WebObs logout - - - - - -

            You are now logged Out

            - + + WebObs logout + + + + + +

            You are now logged Out

            + __EOD__ exit; @@ -269,120 +269,120 @@ sub uid_exists { print <<__EOD__; - - WebObs registration form - - - - - - - - - - - -

            Access to $WEBOBS{WEBOBS_TITLE}

            -
            -

            - Access to this website is restricted to registered staff - members and associated researchers. -

            -

            - If you need access to this website, please read the - "Terms of Use" then fill in and submit the - registration form below. -

            -
            -
            -
            - Terms of Use -

            @charte

            -
            -
            -
            - $WEBOBS{WEBOBS_TITLE} registration form -
            - - -
            - -
            - -
            - -
            - -
            -
            - - -

            - + WebObs registration form + + + + + + + +

            + + + +

            Access to $WEBOBS{WEBOBS_TITLE}

            +
            +

            + Access to this website is restricted to registered staff + members and associated researchers. +

            +

            + If you need access to this website, please read the + "Terms of Use" then fill in and submit the + registration form below. +

            +
            +
            +
            + Terms of Use +

            @charte

            +
            +
            +
            + $WEBOBS{WEBOBS_TITLE} registration form + + + +
            + +
            + +
            + +
            + +
            +
            + + +

            + -

            - -
            - +

            + +
            + __EOD__ diff --git a/CODE/cgi-bin/relayMgr.pl b/CODE/cgi-bin/relayMgr.pl index b53b7913..eef51fae 100755 --- a/CODE/cgi-bin/relayMgr.pl +++ b/CODE/cgi-bin/relayMgr.pl @@ -85,8 +85,8 @@ my $commandStatus = "?RLY"; #$telnetClient->cmd( - # String => $commandStatus, - # Prompt => '/[01]{8}$/', + # String => $commandStatus, + # Prompt => '/[01]{8}$/', #); #$statusBefore = $telnetClient->last_prompt; @@ -102,8 +102,8 @@ #sleep(1); #$telnetClient->cmd( - # String => $commandStatus, - # Prompt => '/[01]{8}$/', + # String => $commandStatus, + # Prompt => '/[01]{8}$/', #); #$statusAfter = $telnetClient->last_prompt; @@ -119,16 +119,16 @@ #sleep(1); #$telnetClient->cmd( - # String => $commandStatus, - # Prompt => '/[01]{8}$/', + # String => $commandStatus, + # Prompt => '/[01]{8}$/', #); #$statusReboot = $telnetClient->last_prompt; } print "Location: $relayParams{$QryParm->{'action'}}[5]\n\n"; - # print $cgi->header(-charset=>'utf-8'); - # print <<"PART1"; + # print $cgi->header(-charset=>'utf-8'); + # print <<"PART1"; # # # @@ -169,7 +169,7 @@ return false; } else { return true; - } + } } @@ -186,19 +186,19 @@
            • - - + + + - - + + + PART2 if (clientHasAdm(type=>"authprocs",name=>"RELAYADM")) { @@ -208,21 +208,21 @@ + - + + + - + + PART3 } @@ -231,11 +231,11 @@ + - + + @@ -243,21 +243,21 @@ + - + + + - + + @@ -265,21 +265,21 @@ + - + + - - + + +
            -
            Date et lieu du déplacement -

            - Date: "; for (@anneeListe) { if ($_ == $sel_annee) { print ""; } else { print ""; } } @@ -251,7 +251,7 @@ =head1 Query string parameter print "

            "; print "
            Informations sur le déplacement\n -

            "; +

            "; print "Type de déplacement:
            "; print " Conducteur:
            \n - Kilomètre au compteur = km
            \n - Carburant = €
            \n"; + Kilomètre au compteur = km
            \n + Carburant = €
            \n"; -# print "Débit (qualitatif) = \n"; +# print "Débit (qualitatif) = \n"; print "

            "; print "
            "; -# print "Observations :

            "; -# if ($val ne "") { -# print "
            Information de saisie: $val -#

            "; -# } +# print "Observations :

            "; +# if ($val ne "") { +# print "
            Information de saisie: $val +#

            "; +# } print "
            "; print "

            "; diff --git a/CODE/cgi-bin/gedit.pl b/CODE/cgi-bin/gedit.pl index 2bd3753d..0136df79 100755 --- a/CODE/cgi-bin/gedit.pl +++ b/CODE/cgi-bin/gedit.pl @@ -21,21 +21,21 @@ =head1 Query string parameters =item B - normgrid := gridtype.gridname - The fully qualified normalized gridname + normgrid := gridtype.gridname + The fully qualified normalized gridname =item B - The file to be edited will be WEBOBS{PATH_GRIDS_DOCS}/gridtype.gridname||filesuffix - eg. ...?grid=VIEW.MYVIEW&file=_protocole.txt - ==> $WEBOBS{PATH_GRIDS_DOCS}/VIEW.MYVIEW_protocole.txt + The file to be edited will be WEBOBS{PATH_GRIDS_DOCS}/gridtype.gridname||filesuffix + eg. ...?grid=VIEW.MYVIEW&file=_protocole.txt + ==> $WEBOBS{PATH_GRIDS_DOCS}/VIEW.MYVIEW_protocole.txt =item B - string := { edit | save } - 'edit' (default when action is not specified) to display edit html-form edit - 'save' internaly used to save the file after html-form edition - (other parameters are used along with 'save': ts0, txt) + string := { edit | save } + 'edit' (default when action is not specified) to display edit html-form edit + 'save' internaly used to save the file after html-form edition + (other parameters are used along with 'save': ts0, txt) =back @@ -172,16 +172,16 @@ =head1 Markitup customization function verif_formulaire() { \$.post(\"$me\", \$(\"#theform\").serialize(), function(data) { - if (data != '') alert(data); - location.href = document.referrer; - }); + if (data != '') alert(data); + location.href = document.referrer; + }); } function convert2MMD() { - if (confirm(\"Presentation might be affected by conversion,\\nrequiring manual editing.\")) { - \$(\"#theform\")[0].conv.value = \"1\"; - verif_formulaire(); - } + if (confirm(\"Presentation might be affected by conversion,\\nrequiring manual editing.\")) { + \$(\"#theform\")[0].conv.value = \"1\"; + verif_formulaire(); + } } @@ -194,15 +194,15 @@ =head1 Markitup customization "; if (length($meta) > 0) { print " - "; + "; } else { print " - "; + "; } print " diff --git a/CODE/cgi-bin/gridsMgr.pl b/CODE/cgi-bin/gridsMgr.pl index ce060451..48c8055b 100755 --- a/CODE/cgi-bin/gridsMgr.pl +++ b/CODE/cgi-bin/gridsMgr.pl @@ -118,33 +118,33 @@ =head1 QUERY-STRING PARAMETERS $meas_var =~ s/'/\'/g; my @contacts = $cgi->param('contacts'); -my @roles = $cgi->param('roles'); +my @roles = $cgi->param('roles'); my @firstNames = $cgi->param('firstName'); my @lastNames = $cgi->param('lastName'); my @emails = $cgi->param('emails'); =pod foreach (@contacts) { - my @elements = split(/ /, $_); - push(@roles, (split '\(|\)', $_)[1]); - push(@firstNames, $elements[2]); - push(@lastNames, $elements[3]); - push(@emails, $elements[4]); + my @elements = split(/ /, $_); + push(@roles, (split '\(|\)', $_)[1]); + push(@firstNames, $elements[2]); + push(@lastNames, $elements[3]); + push(@emails, $elements[4]); } =cut my @funders = $cgi->param('funders'); my @typeFunders = $cgi->param('typeFunders'); -my @idScanR = $cgi->param('scanR'); -my @nameFunders = $cgi->param('nameFunders'); -my @acronyms = $cgi->param('acronyms'); +my @idScanR = $cgi->param('scanR'); +my @nameFunders = $cgi->param('nameFunders'); +my @acronyms = $cgi->param('acronyms'); =pod foreach (@funders) { - push(@typeFunders, (split ':', $_)[0]); - push(@idScanR, (split '/', $_)[1]); - push(@nameFunders, (split ':|\(', $_)[1]); - push(@acronyms, (split '\(|\)', $_)[1]); + push(@typeFunders, (split ':', $_)[0]); + push(@idScanR, (split '/', $_)[1]); + push(@nameFunders, (split ':|\(', $_)[1]); + push(@acronyms, (split '\(|\)', $_)[1]); } =cut @@ -413,7 +413,7 @@ =head1 QUERY-STRING PARAMETERS print $DBI::errstr; } -my @roles; # creating a role list for the contacts informations part +my @roles; # creating a role list for the contacts informations part while(my @row = $sth->fetchrow_array()) { my $role = $row[0]; @@ -428,7 +428,7 @@ =head1 QUERY-STRING PARAMETERS print $DBI::errstr; } -my @types; # creating a funding types list for the fundings informations part +my @types; # creating a funding types list for the fundings informations part while(my @row = $sth->fetchrow_array()) { my $type = $row[0]; @@ -443,7 +443,7 @@ =head1 QUERY-STRING PARAMETERS print $DBI::errstr; } -my @resources; # creating a resource types list for the online resources informations part +my @resources; # creating a resource types list for the online resources informations part my @resNames; while(my @row = $sth->fetchrow_array()) { @@ -475,46 +475,46 @@ =head1 QUERY-STRING PARAMETERS Domains $go2top

            -
            • $domainMsg

            - -
            Domains -
            - $ddomainsCount domains defined -
            -
            -
            - - - - - $ddomains - -
            -   - IdRankNameMarkerGrids
            -
            -
            -
            +
            • $domainMsg

            + +
            Domains +
            + $ddomainsCount domains defined +
            +
            +
            + + + + + $ddomains + +
            +   + IdRankNameMarkerGrids
            +
            +
            +
            @@ -525,52 +525,52 @@ =head1 QUERY-STRING PARAMETERS Producers $go2top
            -
            • $producerMsg

            -
            @@ -669,7 +669,7 @@ sub dbuow { my $rv = 0; my $dbh = DBI->connect("dbi:SQLite:dbname=".$_[0], '', '',{AutoCommit => 0, RaiseError => 1,}) or die "$DBI::errstr" ; eval { - $dbh->do("PRAGMA foreign_keys = ON;"); # query to make sure FOREIGN KEY are bounded + $dbh->do("PRAGMA foreign_keys = ON;"); # query to make sure FOREIGN KEY are bounded $dbh->do($_[1]); $dbh->do($_[2]); $rv = $dbh->do($_[3]) if ($_[3] ne ""); diff --git a/CODE/cgi-bin/gvTransit.pl b/CODE/cgi-bin/gvTransit.pl index 120cb619..761334a6 100755 --- a/CODE/cgi-bin/gvTransit.pl +++ b/CODE/cgi-bin/gvTransit.pl @@ -225,7 +225,7 @@ sub tree { --> diff --git a/CODE/cgi-bin/index.pl b/CODE/cgi-bin/index.pl index 654ca8a8..c8d82a72 100755 --- a/CODE/cgi-bin/index.pl +++ b/CODE/cgi-bin/index.pl @@ -45,7 +45,7 @@ =head1 NAVIGATION FILE .rc FORMAT ! : same as + but item only made available to administrator(s) * : same as omitting this first character, but item only made available - to administrator(s) + to administrator(s) menu-text : item's name as displayed @@ -141,7 +141,7 @@ =head1 NAVIGATION FILE .html FORMAT my @liste_title = split(/;/,$MENU{"LOGO_TITLES"}); my $logos=""; for my $i (0..$#liste_logos) { - i $logos .= "\"$liste_title[$i]\""; + i $logos .= "\"$liste_title[$i]\""; } $logos =~ s/'/\\'/g; @@ -226,20 +226,20 @@ =head1 NAVIGATION FILE .html FORMAT print <<"FIN"; - - - $WEBOBS{WEBOBS_TITLE} - - - - - - - - - - - + + + $WEBOBS{WEBOBS_TITLE} + + + + + + + + + + + FIN print <<"FIN"; -
            -
            -
            $logos
            -
            -  [$ENV{SERVER_NAME}] $WEBOBS{VERSION} - $logout - $drapeaux -
            -
            - -
            -
            +
            +
            +
            $logos
            +
            +  [$ENV{SERVER_NAME}] $WEBOBS{VERSION} + $logout + $drapeaux +
            +
            + +
            +
            FIN print <<"FIN"; -
            - - -
            -
            $signature
            - - +
            + + +
            +
            $signature
            + + FIN diff --git a/CODE/cgi-bin/listGRIDS.pl b/CODE/cgi-bin/listGRIDS.pl index 3f98fc87..33dbd26e 100755 --- a/CODE/cgi-bin/listGRIDS.pl +++ b/CODE/cgi-bin/listGRIDS.pl @@ -517,7 +517,7 @@ sub feditpopup { opendir my $dir, ($tdir) or die "Cannot open directory: $!"; my @templates = sort grep (/FORM\./, readdir($dir)); closedir $dir; - $SP .= " \n"; # select input, look into CODE/tplates to find the differents templates foreach my $f (@templates) { if ($f =~ /FORM\./) { my %cfg = readCfg("$tdir/$f"); diff --git a/CODE/cgi-bin/mailInfo_OVPF.pl b/CODE/cgi-bin/mailInfo_OVPF.pl index 995e0a4f..fdd8f96c 100755 --- a/CODE/cgi-bin/mailInfo_OVPF.pl +++ b/CODE/cgi-bin/mailInfo_OVPF.pl @@ -4,23 +4,23 @@ # mail_info.pl # ------ # Usage: Prepare an information mail based on the Main Courante -# (MC) seismological database +# (MC) seismological database # # Arguments -# mc= MC conf name (optional) -# dateStart= Start date (mandatory) -# dateEnd= End date (mandatory) -# stat_max_duration= Duration of the biggest VT for the -# selected time interval (mandatory) -# stat_max_magnitude= Magnitude of the biggest VT for the -# selected time interval (mandatory) -# stat_max_duration_loc= Duration of the biggest local -# for the selected time interval (mandatory) -# stat_max_magnitude_loc= Magnitude of the biggest local -# for the selected time interval (mandatory) -# RFcount = Number of rockfalls (mandatory) -# VTcount = number of VT (mandatory) -# LOCcount = number of VT (mandatory) +# mc= MC conf name (optional) +# dateStart= Start date (mandatory) +# dateEnd= End date (mandatory) +# stat_max_duration= Duration of the biggest VT for the +# selected time interval (mandatory) +# stat_max_magnitude= Magnitude of the biggest VT for the +# selected time interval (mandatory) +# stat_max_duration_loc= Duration of the biggest local +# for the selected time interval (mandatory) +# stat_max_magnitude_loc= Magnitude of the biggest local +# for the selected time interval (mandatory) +# RFcount = Number of rockfalls (mandatory) +# VTcount = number of VT (mandatory) +# LOCcount = number of VT (mandatory) # # # Author: Patrice Boissier @@ -325,12 +325,12 @@ $html .= '
            '; $html .= "

            Glossaire

            "; $html .= "

            - - Séisme volcano-tectonique sommital : séisme localisé au dessus du niveau de la mer à l'aplomb du sommet du volcan.
            + - Séisme volcano-tectonique sommital : séisme localisé au dessus du niveau de la mer à l'aplomb du sommet du volcan.
            - Séisme volcano-tectonique profond : séisme localisé sous le niveau de la mer à l'aplomb du volcan.
            - Séisme local : séisme localisé dans un rayon de 200km de l'île.
            - Signaux GPS sommitaux: témoin de l'influence de sources de pression superficielles à l'aplomb du volcan.
            - Signaux GPS lointains: témoin de l'influence de sources de pression profondes à l'aplomb du volcan. -

            "; +

            "; $html .= " "; $html .= " "; $html .= " "; @@ -349,7 +349,7 @@ close $fh; print "Fin ECRITURE BULLETIN"; - # print "Envoie du mail"; + # print "Envoie du mail"; my $from = $MC3{MAIL_FROM}; my $smtpServer = $MC3{MAIL_SMTP_SERVER}; diff --git a/CODE/cgi-bin/mailInfo_REVOSIMA.pl b/CODE/cgi-bin/mailInfo_REVOSIMA.pl index 554cec01..d6ad2777 100755 --- a/CODE/cgi-bin/mailInfo_REVOSIMA.pl +++ b/CODE/cgi-bin/mailInfo_REVOSIMA.pl @@ -4,12 +4,12 @@ # mail_info.pl # ------ # Usage: Prepare an information mail based on the Main Courante -# (MC) seismological database +# (MC) seismological database # # Arguments -# mc= MC conf name (optional) -# dateStart= Start date (mandatory) -# dateEnd= End date (mandatory) +# mc= MC conf name (optional) +# dateStart= Start date (mandatory) +# dateEnd= End date (mandatory) # # Author: Patrice Boissier # Acknowledgments: @@ -326,7 +326,7 @@ $html .= "Carte de localisation des épicentres (± 5 km) des séismes volcano-tectoniques avec les réseaux sismiques à terre (IPGP-IFREMER-CNRS-BRGM-BCSF-RéNaSS, ITES) au cours du dernier mois (échelle temporelle de couleur). Sont aussi représentées une projection des hypocentres des séismes le long de coupes transverses et axiales le long de la ride montrant la localisation estimée en profondeur (précision variant entre +-5km et +-15km) des séismes en fonction de la magnitude (taille des symboles) et de la date (échelle temporelle de couleur). ©OVPF-IPGP / REVOSIMA
            "; $html .= "La sismicité déterminée et validée en continu par le REVOSIMA peut être également suivie sur le portail RENASS."; $html .= "

            "; - $html .= '
            '; + $html .= '
            '; $htmlOutput .= $html; $htmlBrowser .= $html; @@ -369,7 +369,7 @@
          • Déformation: Depuis juillet 2018, l'île de Mayotte est affectée par des déplacements de surface liés à l'activité volcano-tectonique. Ces déformations sont liées à des circulations de fluides en profondeur se produisant à l'est de Mayotte, en lien avec l'activité volcanique.
            • -

            +

            Page Facebook du ReVoSiMa @@ -399,7 +399,7 @@ print $fh $htmlOutput; close $fh; - # print "Envoie du mail"; + # print "Envoie du mail"; my $from = $MC3{MAIL_FROM_REVOSIMA}; my $smtpServer = $MC3{MAIL_SMTP_SERVER}; diff --git a/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl b/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl index cac75f92..2f382c17 100755 --- a/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl +++ b/CODE/cgi-bin/mailInfo_REVOSIMA_mailclient.pl @@ -4,12 +4,12 @@ # mail_info.pl # ------ # Usage: Prepare an information mail based on the Main Courante -# (MC) seismological database +# (MC) seismological database # # Arguments -# mc= MC conf name (optional) -# dateStart= Start date (mandatory) -# dateEnd= End date (mandatory) +# mc= MC conf name (optional) +# dateStart= Start date (mandatory) +# dateEnd= End date (mandatory) # # Author: Patrice Boissier # Acknowledgments: @@ -365,7 +365,7 @@

          • Déformation: Depuis juillet 2018, l'île de Mayotte est affectée par des déplacements de surface liés à l'activité volcano-tectonique. Ces déformations sont liées à des circulations de fluides en profondeur se produisant à l'est de Mayotte, en lien avec l'activité volcanique.
            • -

            +

            Page Facebook du ReVoSiMa @@ -396,53 +396,53 @@ print $fh $htmlOutput; close $fh; - # print "Envoie du mail"; + # print "Envoie du mail"; -# my $from = $MC3{MAIL_FROM_REVOSIMA}; -# my $smtpServer = $MC3{MAIL_SMTP_SERVER}; -# my $smtpPort = $MC3{MAIL_SMTP_PORT}; -# my $user = $MC3{MAIL_USER_REVOSIMA}; -# my $passwd = $MC3{MAIL_PASSWD_REVOSIMA}; +# my $from = $MC3{MAIL_FROM_REVOSIMA}; +# my $smtpServer = $MC3{MAIL_SMTP_SERVER}; +# my $smtpPort = $MC3{MAIL_SMTP_PORT}; +# my $user = $MC3{MAIL_USER_REVOSIMA}; +# my $passwd = $MC3{MAIL_PASSWD_REVOSIMA}; # -# my $mailList = ''; -# my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); -# for (@mailConf) { -# my @liste = split(/\|/,$_); -# my %hash; -# @hash{@mail}=(); -# if (exists $hash{$liste[0]}){ -# if ($mailList eq '') { -# $mailList = $mailList.$liste[4] -# } else { -# $mailList = $mailList.','.$liste[4] -# } -# } -# } -# -# my $message = Email::MIME->create_html( -# header => [ -# From => $from, -# 'Reply-To' => $from, -# Subject => $subject, -# Type => 'text/html; charset=UTF-8', -# ], -# body => $htmlMail, -# ); -# -# my @mailingList = split(/,/,$mailList); -# for(@mailingList) { -# if($MC3{MAIL_USE_SMTP_REVOSIMA}) { -# my $transport = Email::Sender::Transport::SMTP::TLS->new( -# host => $smtpServer, -# port => $smtpPort, -# username => $user, -# password => $passwd, -# ); -# sendmail($message, { from => $from, to => $_, transport => $transport}); -# } else { -# sendmail($message, { from => $from, to => $_}); -# } -# } +# my $mailList = ''; +# my @mailConf = readCfgFile("$WEBOBS{ROOT_CONF}/$MC3{MAIL_REVOSIMA_INFO_CONF}"); +# for (@mailConf) { +# my @liste = split(/\|/,$_); +# my %hash; +# @hash{@mail}=(); +# if (exists $hash{$liste[0]}){ +# if ($mailList eq '') { +# $mailList = $mailList.$liste[4] +# } else { +# $mailList = $mailList.','.$liste[4] +# } +# } +# } +# +# my $message = Email::MIME->create_html( +# header => [ +# From => $from, +# 'Reply-To' => $from, +# Subject => $subject, +# Type => 'text/html; charset=UTF-8', +# ], +# body => $htmlMail, +# ); +# +# my @mailingList = split(/,/,$mailList); +# for(@mailingList) { +# if($MC3{MAIL_USE_SMTP_REVOSIMA}) { +# my $transport = Email::Sender::Transport::SMTP::TLS->new( +# host => $smtpServer, +# port => $smtpPort, +# username => $user, +# password => $passwd, +# ); +# sendmail($message, { from => $from, to => $_, transport => $transport}); +# } else { +# sendmail($message, { from => $from, to => $_}); +# } +# } } else { print $cgi->header(-charset=>'utf-8'); print <<"PART1"; diff --git a/CODE/cgi-bin/mc3.pl b/CODE/cgi-bin/mc3.pl index e4ec9dab..d7a3e9e7 100755 --- a/CODE/cgi-bin/mc3.pl +++ b/CODE/cgi-bin/mc3.pl @@ -581,7 +581,7 @@ sub compute_energy { # ---- Load hypocentres ------------------------------------------------------- # #DL-was: if ($MC3{SISMOHYP_HYPO_USE}) { -#DL-was: my $fileHypo = "$WEBOBS{RACINE_FTP}/$WEBOBS{SISMOHYP_PATH_FTP}/$WEBOBS{SISMOHYP_HYPO_FILE}"; +#DL-was: my $fileHypo = "$WEBOBS{RACINE_FTP}/$WEBOBS{SISMOHYP_PATH_FTP}/$WEBOBS{SISMOHYP_HYPO_FILE}"; if ($HYPO_USE_FMT0_PATH) { my $fileHypo = "$HYPO_USE_FMT0_PATH/$HYPO_USE_FMT0_FILE"; if (-e $fileHypo) { @@ -605,7 +605,7 @@ sub compute_energy { } #DL-was: if ($MC3{OVPF_HYPO_USE}) { - #DL-was: my $fileHypo3 = "$WEBOBS{OVPFHYP_PATH}/$y.hyp" + #DL-was: my $fileHypo3 = "$WEBOBS{OVPFHYP_PATH}/$y.hyp" if ($HYPO_USE_FMT1_PATH) { my $fileHypo3 = "$HYPO_USE_FMT1_PATH/$y.hyp"; if (-e $fileHypo3) { @@ -1078,7 +1078,7 @@ sub compute_energy { #print ""; #for(sort(keys(%stat))) { -# print ""; +# print ""; #} #print ""; #print "
            $_$_Total
            $total
            ", @@ -1230,26 +1230,26 @@ sub compute_energy { } # JMS was -# $dirTrigger = "$WEBOBS{SISMOCP_PATH_FTP}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; -# $dirTriggerUrn = "$WEBOBS{SISMOCP_PATH_FTP_URN}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; -# my @loca; -# my @suds_liste; -# my $suds_sans_seconde; -# my $suds_racine; -# my $suds_ext; -# my $suds2_pointe; +# $dirTrigger = "$WEBOBS{SISMOCP_PATH_FTP}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; +# $dirTriggerUrn = "$WEBOBS{SISMOCP_PATH_FTP_URN}/$evt_annee4/".substr($evt_annee4,2,2)."$evt_mois"; +# my @loca; +# my @suds_liste; +# my $suds_sans_seconde; +# my $suds_racine; +# my $suds_ext; +# my $suds2_pointe; #djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { -# if (length($suds)==12 && substr($suds,8,1) eq '.') { -# # ne prend que les premiers caractères du nom de fichier -# $suds_sans_seconde = substr($suds,0,7); -# @suds_liste = <$dirTrigger/$suds_sans_seconde*>; -# @loca = grep(/ $suds_sans_seconde/,grep(/^$evt_annee4$evt_mois/,@hypo)); -# } elsif (length($suds)==19) { -# $suds_racine = substr($suds,0,15); -# $suds_ext = substr($suds,16,3); -# $suds2_pointe = "${suds_racine}_a.${suds_ext}"; -# @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); -# } +# if (length($suds)==12 && substr($suds,8,1) eq '.') { +# # ne prend que les premiers caractères du nom de fichier +# $suds_sans_seconde = substr($suds,0,7); +# @suds_liste = <$dirTrigger/$suds_sans_seconde*>; +# @loca = grep(/ $suds_sans_seconde/,grep(/^$evt_annee4$evt_mois/,@hypo)); +# } elsif (length($suds)==19) { +# $suds_racine = substr($suds,0,15); +# $suds_ext = substr($suds,16,3); +# $suds2_pointe = "${suds_racine}_a.${suds_ext}"; +# @loca = grep(/ $suds_racine/,grep(/^$evt_annee4$evt_mois/,@hypo)); +# } my @lat; my @lon; @@ -1275,43 +1275,43 @@ sub compute_energy { if ($QryParm->{'hideloc'} == 0) { # JMS was -# if ($HYPO_USE_FMT0_PATH) { -# $ii = 0; -# for (@loca) { -# $dat[$ii] = sprintf("%d-%02d-%02d %02d:%02d:%02.2f TU",substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,9,2),substr($_,11,2),substr($_,14,5)); -# $mag[$ii] = substr($_,47,5); -# $mty[$ii] = 'Md'; -# $lat[$ii] = substr($_,20,2) + substr($_,23,5)/60; -# $lon[$ii] = -(substr($_,30,2) + substr($_,33,5)/60); -# $dep[$ii] = substr($_,39,6); -# #$qua[$ii] = sprintf("%d phases - classe %s",substr($_,53,2),substr($_,80,1)); -# $pha[$ii] = substr($_,53,2); -# $qua[$ii] = substr($_,80,1); -# $cod[$ii] = substr($_,83,5); -# $mod[$ii] = 'manual'; -# if ($cod[$ii] ne "XXX ") { $isNotManuel = 0; } -# if (substr($cod[$ii],2,1) ne "1") { $msk[$ii] = romain(substr($cod[$ii],2,1)); } -# if ($isNotManuel) { -# $nomB3[$ii] = $WEBOBS{SISMORESS_AUTO_PATH_FTP}."/".substr($_,0,4)."/".substr($_,4,2)."/" -# .substr($_,0,8)."T".sprintf("%02.0f",substr($_,9,2)).sprintf("%02.0f",substr($_,11,2)) -# .sprintf("%02.0f",substr($_,14,5))."_b3"; -# } -# else { -# $nomB3[$ii] = $WEBOBS{SISMORESS_PATH_FTP}."/".substr($_,0,4)."/".substr($_,4,2)."/" -# .substr($_,0,8)."T".sprintf("%02.0f",substr($_,9,2)).sprintf("%02.0f",substr($_,11,2)) -# .sprintf("%02.0f",substr($_,14,5))."_b3"; -# } +# if ($HYPO_USE_FMT0_PATH) { +# $ii = 0; +# for (@loca) { +# $dat[$ii] = sprintf("%d-%02d-%02d %02d:%02d:%02.2f TU",substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,9,2),substr($_,11,2),substr($_,14,5)); +# $mag[$ii] = substr($_,47,5); +# $mty[$ii] = 'Md'; +# $lat[$ii] = substr($_,20,2) + substr($_,23,5)/60; +# $lon[$ii] = -(substr($_,30,2) + substr($_,33,5)/60); +# $dep[$ii] = substr($_,39,6); +# #$qua[$ii] = sprintf("%d phases - classe %s",substr($_,53,2),substr($_,80,1)); +# $pha[$ii] = substr($_,53,2); +# $qua[$ii] = substr($_,80,1); +# $cod[$ii] = substr($_,83,5); +# $mod[$ii] = 'manual'; +# if ($cod[$ii] ne "XXX ") { $isNotManuel = 0; } +# if (substr($cod[$ii],2,1) ne "1") { $msk[$ii] = romain(substr($cod[$ii],2,1)); } +# if ($isNotManuel) { +# $nomB3[$ii] = $WEBOBS{SISMORESS_AUTO_PATH_FTP}."/".substr($_,0,4)."/".substr($_,4,2)."/" +# .substr($_,0,8)."T".sprintf("%02.0f",substr($_,9,2)).sprintf("%02.0f",substr($_,11,2)) +# .sprintf("%02.0f",substr($_,14,5))."_b3"; +# } +# else { +# $nomB3[$ii] = $WEBOBS{SISMORESS_PATH_FTP}."/".substr($_,0,4)."/".substr($_,4,2)."/" +# .substr($_,0,8)."T".sprintf("%02.0f",substr($_,9,2)).sprintf("%02.0f",substr($_,11,2)) +# .sprintf("%02.0f",substr($_,14,5))."_b3"; +# } # calcul de la distance epicentrale minimum (et azimut epicentre/villes) -# for (0..$#b3_lat) { -# my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); -# my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; -# $b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",sqrt($dx**2 + $dy**2),atan2($dy,$dx),$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); -# } -# my @xx = sort { $a cmp $b } @b3_dat; -# $bcube[$ii] = $xx[0]; -# $ii ++; -# } -# } +# for (0..$#b3_lat) { +# my $dx = ($lon[$ii] - $b3_lon[$_])*111.18*cos($lat[$ii]*0.01745); +# my $dy = ($lat[$ii] - $b3_lat[$_])*111.18; +# $b3_dat[$_] = sprintf("%06.1f|%g|%s|%s|%g",sqrt($dx**2 + $dy**2),atan2($dy,$dx),$b3_nam[$_],$b3_isl[$_],$b3_sit[$_]); +# } +# my @xx = sort { $a cmp $b } @b3_dat; +# $bcube[$ii] = $xx[0]; +# $ii ++; +# } +# } # si le séisme a été localisé, les infos sont dans le champ $origin if ($origin) { @@ -1365,7 +1365,7 @@ sub compute_energy { if ($QryParm->{'obs'} ne "") { #if (grep(/$QryParm->{'obs'}/i,$type)) { - # $typeAff =~ s/($QryParm->{'obs'})/$1<\/span>/ig; + # $typeAff =~ s/($QryParm->{'obs'})/$1<\/span>/ig; #} if (grep(/$QryParm->{'obs'}/i,$station)) { $station =~ s/($QryParm->{'obs'})/$1<\/span>/ig; @@ -1445,31 +1445,31 @@ sub compute_energy { #djl-was: if (length($suds)==12 && substr($suds,10,1) eq '.') { #if (length($suds)==12 && substr($suds,8,1) eq '.') { -# for(@suds_liste) { -# $html .= ""; -# } +# for(@suds_liste) { +# $html .= ""; +# } #} elsif (-f "$dirTrigger/$suds2_pointe") { -# for my $lettre ("a".."z") { -# $suds2_pointe = "${suds_racine}_${lettre}.${suds_ext}"; -# if (-f "$dirTrigger/$suds2_pointe") { -# $html .= ""; -# } -# } +# for my $lettre ("a".."z") { +# $suds2_pointe = "${suds_racine}_${lettre}.${suds_ext}"; +# if (-f "$dirTrigger/$suds2_pointe") { +# $html .= ""; +# } +# } #} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { -# $html .= ""; +# $html .= ""; #} elsif (-f "$MC3{PATH_DESTINATION_SIGNAUX}/${evt_annee4}-${evt_mois}/$suds") { -# $html .= ""; +# $html .= ""; #} elsif (-f "$WEBOBS{RACINE_SIGNAUX_SISMO}/$diriaspei/$suds") { -# $html .= ""; +# $html .= ""; #} elsif ($suds eq $nosuds) { -# $html .= ""; +# $html .= ""; #} elsif ($seedlink) { # [FXB] AJOUTER &all=1 lorsque le serveur ArcLink acceptera les wildcards... $html .= ""; #} else { - # $html .= "($suds)"; + # $html .= "($suds)"; #} $html .= "
            Piton de Bert   
            Camera Bert IRT     -
            Camera Bert OVPF     -
            Capteur de vent de BERT (IRT) - -   
            Relai analogique de NTR - -   
            Relai phonie de Bert - -   
            Piton des Basaltes
            Relai phonie de Basaltes - -   
            Relai radio SDIS de Basaltes - -   
            Hubert Delisle
            Camera de HDL - -   
            Cratere Bory
            Camera IR de Cratere Bory OVPF     -
            diff --git a/CODE/cgi-bin/schedulerLogs.pl b/CODE/cgi-bin/schedulerLogs.pl index 421e829e..3244eb90 100755 --- a/CODE/cgi-bin/schedulerLogs.pl +++ b/CODE/cgi-bin/schedulerLogs.pl @@ -76,9 +76,9 @@ =head1 DESCRIPTION EOHEADER @@ -93,7 +93,7 @@ =head1 DESCRIPTION
            - @results + @results
            EOPAGE diff --git a/CODE/cgi-bin/schedulerMgr.pl b/CODE/cgi-bin/schedulerMgr.pl index 62ceb508..9f34a747 100755 --- a/CODE/cgi-bin/schedulerMgr.pl +++ b/CODE/cgi-bin/schedulerMgr.pl @@ -307,24 +307,24 @@ sub fetch_all { .qq{}; } $jobsdefs .= qq{ -
            $edit_link$delete_link - - $djid$dvalid$dres$xeq1$xeq2$dxeq3$dintv$dmaxs$dlogp$dlstrun
            $edit_link$delete_link + + $djid$dvalid$dres$xeq1$xeq2$dxeq3$dintv$dmaxs$dlogp$dlstrun
            - + + + + + $jobsdefs + +
            +
            +  Jobs defined: $jobsdefsCount (currently activated: $jobsdefsCountValid) + $jobsdefsMsg +
            +
            +
            + + "; print <<"EOPAGE"; - - - - - - $jobsdefs - -
            EOPAGE if ($admOK) { @@ -412,16 +412,16 @@ sub fetch_all { print " JIDAResourceJob commandInterval
            (s)            		Max.
            load            		Log PathLast Start
            xeq1xeq2xeq3
            -
            -
            +             		JIDAResourceJob commandInterval
            (s)            		Max.
            load            		Log PathLast Start
            xeq1xeq2xeq3
            + + EOPAGE diff --git a/CODE/cgi-bin/schedulerRuns.pl b/CODE/cgi-bin/schedulerRuns.pl index a9f4ef8b..3da10da9 100755 --- a/CODE/cgi-bin/schedulerRuns.pl +++ b/CODE/cgi-bin/schedulerRuns.pl @@ -236,7 +236,7 @@ sub fetch_all { # ---- order by jid so that unique jid occurences appear on a single graph line my $timelineD1 = int(time()); if ( $QryParm->{'runsdate'} ne $today ) { $timelineD1 = WebObs::Dates::ymdhms2s("$QryParm->{'runsdate'} 23:59:00"); } -my $timelineD0 = $timelineD1 - 86400; +my $timelineD0 = $timelineD1 - 86400; my $query_timeline_runs = "SELECT jid, DATETIME(cast(startts as integer),'unixepoch','localtime')," . " CASE WHEN endts != 0 THEN DATETIME(CAST(endts AS INTEGER), 'unixepoch', 'localtime') ELSE NULL END," . " cmd, rc FROM runs" @@ -388,24 +388,24 @@ sub fetch_all { --> + FIN } @@ -412,25 +412,25 @@ =head1 Query string parameters for (@nd) { if ($d[$_][0] ne "") { my $dd = 0; - $DM += $offset + $ruban + $d[$_][0] + $d[$_][1]; # $DM = momentan�ment somme des x - $DS += ($offset + $ruban + $d[$_][0] + $d[$_][1])**2; # $DS = momentanement somme des x² + $DM += $offset + $ruban + $d[$_][0] + $d[$_][1]; # $DM = momentan�ment somme des x + $DS += ($offset + $ruban + $d[$_][0] + $d[$_][1])**2; # $DS = momentanement somme des x² $VM += $d[$_][2]; $n++; } } if ($n > 0) { - $DM = $DM/$n; # $DM = moyenne mesure - $DS = 2 * sqrt($DS/$n - $DM*$DM); # $DS = 2 * �cart-type - $VM = $VM/$n; # $VM = moyenne vent + $DM = $DM/$n; # $DM = moyenne mesure + $DS = 2 * sqrt($DS/$n - $DM*$DM); # $DS = 2 * �cart-type + $VM = $VM/$n; # $VM = moyenne vent } $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; my @listenoms = split(/\+/,$ope); - #djl-TBD my $noms = join(", ",nomOperateur(@listenoms)); - #djl-TBD for (@listenoms) { - #djl-TBD $operStat{$_} += 1; - #djl-TBD } + #djl-TBD my $noms = join(", ",nomOperateur(@listenoms)); + #djl-TBD for (@listenoms) { + #djl-TBD $operStat{$_} += 1; + #djl-TBD } my $normsite = WebObs::Grids::normNode(node=>"PROC.EXTENSO.$site"); if ($normsite eq "") { $normsite = WebObs::Grids::normNode(node=>".EXTENSO.$site") } @@ -495,16 +495,16 @@ =head1 Query string parameters } else { print @html; -#djl-TBD for ($nb=0;$nb<$#operateurs;$nb++) { -#djl-TBD $operNb[$nb] = sprintf("%5d x %s",$operStat{$operateurs[$nb][0]},$operateurs[$nb][1]); -#djl-TBD } -#djl-TBD @operNb = reverse(sort(grep(!/ 0 x/,@operNb))); -#djl-TBD print "

            ",@operNb)."',CAPTION,'Top opérateurs',ABOVE)\">?

            "; +#djl-TBD for ($nb=0;$nb<$#operateurs;$nb++) { +#djl-TBD $operNb[$nb] = sprintf("%5d x %s",$operStat{$operateurs[$nb][0]},$operateurs[$nb][1]); +#djl-TBD } +#djl-TBD @operNb = reverse(sort(grep(!/ 0 x/,@operNb))); +#djl-TBD print "

            ",@operNb)."',CAPTION,'Top opérateurs',ABOVE)\">?

            "; print "\n -
            \n\n\n"; + #attente { display: none; } + \n +
            \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showFISSURO.pl b/CODE/cgi-bin/showFISSURO.pl index 34075e53..5d1a3670 100755 --- a/CODE/cgi-bin/showFISSURO.pl +++ b/CODE/cgi-bin/showFISSURO.pl @@ -198,36 +198,36 @@ =head1 Query string parameters "\n", print <<"FIN"; - + FIN } @@ -419,16 +419,16 @@ =head1 Query string parameters for $i(@nd) { for $j(0..2) { if ($d[$i][$j] ne "") { - $DM[$j] += $d[$i][$j]; # $DM = momentanément somme des x - $DS[$j] += ($d[$i][$j])**2; # $DS = momentanément somme des x² + $DM[$j] += $d[$i][$j]; # $DM = momentanément somme des x + $DS[$j] += ($d[$i][$j])**2; # $DS = momentanément somme des x² $n[$j]++; } } } for $j(0..2) { if ($n[$j] > 0) { - $DM[$j] = $DM[$j]/$n[$j]; # $DM = moyenne mesure - $DS[$j] = 2 * sqrt($DS[$j]/$n[$j] - ($DM[$j]*$DM[$j])); # $DS = 2 * écart-type + $DM[$j] = $DM[$j]/$n[$j]; # $DM = moyenne mesure + $DS[$j] = 2 * sqrt($DS[$j]/$n[$j] - ($DM[$j]*$DM[$j])); # $DS = 2 * écart-type if ($DS[$j] < $err) { $DS[$j] = $err; } @@ -442,10 +442,10 @@ =head1 Query string parameters $aliasSite = $Ns{$site}{ALIAS} ? $Ns{$site}{ALIAS} : $site; my @listenoms = split(/\+/,$ope); - #djl-TBD my $noms = join(", ",nomOperateur(@listenoms)); - #djl-TBD for (@listenoms) { - #djl-TBD $operStat{$_} += 1; - #djl-TBD } + #djl-TBD my $noms = join(", ",nomOperateur(@listenoms)); + #djl-TBD for (@listenoms) { + #djl-TBD $operStat{$_} += 1; + #djl-TBD } my $normsite = WebObs::Grids::normNode(node=>"PROC.FISSURO.$site"); if ($normsite eq "") { $normsite = WebObs::Grids::normNode(node=>".FISSURO.$site") } @@ -503,7 +503,7 @@ =head1 Query string parameters $infoImg = ""; } -#djl-TBD $texte = $texte."            		Opérateurs: $noms
            ___
            Saisie: $val',CAPTION,'Observations $aliasSite')\">$infoImg
            Opérateurs: $noms
            ___
            Saisie: $val',CAPTION,'Observations $aliasSite')\">$infoImg
            ".join("
            ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml,$txt_rec,$txt_ant)."
            ".join("
            ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml,$txt_rec,$txt_ant)."
            ".join("
            ",$m3g_link_sitelog,$m3g_link_gml,$m3g_xml)."
            \n"; print "
            Receiver history featureAntenna history feature
            ".wiki2html($txt_rec)."".wiki2html($txt_ant)."
            - .\n"; + .\n"; for (reverse sort @reqlist) { my $dir = my $reqdir = $_; diff --git a/CODE/cgi-bin/showRIVERS.pl b/CODE/cgi-bin/showRIVERS.pl index 789e6d03..49c430d1 100755 --- a/CODE/cgi-bin/showRIVERS.pl +++ b/CODE/cgi-bin/showRIVERS.pl @@ -371,7 +371,7 @@ =head1 Query string parameters my $tzp = ""; my $tzn = ""; - # my $cond25 = ""; + # my $cond25 = ""; my $nicb = ""; my @rapv; my $iv = 0; @@ -389,7 +389,7 @@ =head1 Query string parameters if (($cond ne "") && ($tRiver ne "")) { $cond25 = sprintf("%4.1f",$cond/(1 + 0.02*($tRiver - 25))); }; $tzp = $cNa_mmol + $cK_mmol + 2*$cMg_mmol + 2*$cCa_mmol; - # if ($tzp != 0) { $tzp += $cH_mmol; } + # if ($tzp != 0) { $tzp += $cH_mmol; } $tzn = $cHCO3_mmol + $cCl_mmol + 2*$cSO4_mmol; if (($tzp != 0) && ($tzn != 0)) { $nicb = 100*($tzp - $tzn)/($tzp + $tzn); } @@ -498,9 +498,9 @@ =head1 Query string parameters } else { print @html; print "\n -
            \n\n\n"; + #attente { display: none; } + \n +
            \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showSISMOBUL.pl b/CODE/cgi-bin/showSISMOBUL.pl index 62061b96..35629553 100755 --- a/CODE/cgi-bin/showSISMOBUL.pl +++ b/CODE/cgi-bin/showSISMOBUL.pl @@ -152,27 +152,27 @@ =head1 Query string parameters "\n"; print "\n"; + + \n"; print "\n", "\n", @@ -293,7 +293,7 @@ =head1 Query string parameters $lien = "$aliasSite"; -# my $ligne_txt = substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis; +# my $ligne_txt = substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis; my $ligne_txt = sprintf("%3s%4s%15s%6s%1s %23s%4s%4s", substr($sta,0,3), $php, $tps, substr($phs,0,6), substr($phs,9,1), $com, substr($dur,1,4), $dis); $texte = $texte."" ."" @@ -306,8 +306,8 @@ =head1 Query string parameters ."\n"; $txt.=$ligne_txt; -# $txt = $txt.substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis."\n"; -# $texte .= ""; +# $txt = $txt.substr($sta,0,3).$php.$tps.substr($phs,0,6).substr($phs,9,1)." ".$com.substr($dur,1,4).$dis."\n"; +# $texte .= ""; $nbLignesRetenues++; } else { @@ -330,9 +330,9 @@ =head1 Query string parameters } else { print @html; print "\n -
            \n@signature\n\n\n"; + #attente { display: none; } + \n +
            \n@signature\n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showSOILSOLUTION.pl b/CODE/cgi-bin/showSOILSOLUTION.pl index 24d8b828..91849536 100755 --- a/CODE/cgi-bin/showSOILSOLUTION.pl +++ b/CODE/cgi-bin/showSOILSOLUTION.pl @@ -201,16 +201,16 @@ =head1 Query string parameters if ($QryParm->{'dump'} ne "csv") { print $cgi->header(-charset=>'utf-8'); print qq( - ).$FORM->conf('TITLE').qq( - - ); + ).$FORM->conf('TITLE').qq( + + ); print qq( - -
            $__{'Searching for the data... please wait'}.
            - - - \n); + +
            $__{'Searching for the data... please wait'}.
            + + + \n); } # ---- Debut du formulaire pour la selection de l'affichage @@ -248,16 +248,16 @@ =head1 Query string parameters } } print qq( - ); for (@cleParamUnite) { my ($val,$cle) = split (/\|/,$_); if ("$val" eq "$QryParm->{'unit'}") { print qq(\n); } else { print qq(\n); } } print qq(    - -
            -   \n$__{'Ratios'}:); + +
            +   \n$__{'Ratios'}:); $i = 0; for (@ratios) { @@ -275,7 +275,7 @@ =head1 Query string parameters qq( onClick="document.location='$form_url'" value="$__{'Enter a new record'}">); } print qq(
            $__{'Date & Time'}$__{'Host'}$__{'User'}$__{'Time Span'}$__{'Params'}$__{'Job logs'}$__{'Status'}$__{'Graphs'}$__{'Archive'}
            $__{'Job logs'}$__{'Status'}$__{'Graphs'}$__{'Archive'}
            $lien".substr($sta,0,3)."$php
            ".$ligne_txt."
            ".$ligne_txt."
            -

            ).$FORM->conf('TITLE').qq(

            \n); +

            ).$FORM->conf('TITLE').qq(

            \n); } # ---- Read the data file @@ -460,9 +460,9 @@ =head1 Query string parameters } else { print @html; print "\n -
            \n\n\n"; + #attente { display: none; } + \n +
            \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/showTHEIA.pl b/CODE/cgi-bin/showTHEIA.pl index 9366f742..ed75f270 100755 --- a/CODE/cgi-bin/showTHEIA.pl +++ b/CODE/cgi-bin/showTHEIA.pl @@ -310,54 +310,54 @@ =head1 DESCRIPTION print <<"FIN"; FIN diff --git a/CODE/cgi-bin/showVEHICLES.pl b/CODE/cgi-bin/showVEHICLES.pl index a5641638..26110ee4 100755 --- a/CODE/cgi-bin/showVEHICLES.pl +++ b/CODE/cgi-bin/showVEHICLES.pl @@ -303,9 +303,9 @@ =head1 Query string parameters } else { print @html; print "\n -
            \n\n\n"; + #attente { display: none; } + \n +
            \n\n\n"; } __END__ diff --git a/CODE/cgi-bin/usersMgr.pl b/CODE/cgi-bin/usersMgr.pl index 0a771afd..8b584c19 100755 --- a/CODE/cgi-bin/usersMgr.pl +++ b/CODE/cgi-bin/usersMgr.pl @@ -376,16 +376,16 @@ =head1 QUERY-STRING PARAMETERS # Build user table row (also used as input for the user edition form) $dusers .= <<_EOD_;
            $edit_link$del_link$dusers_uid$dusers_fullname$dusers_email$dusers_groups$dusers_validity$dusers_enddate$dusers_comment$edit_link$del_link$dusers_uid$dusers_fullname$dusers_email$dusers_groups$dusers_validity$dusers_enddate$dusers_comment
            - - - - $gid
            + + + + $gid
            - - - - - - - - $Sdgrps_gid$Sdgrps_uids + + + + + + + + $Sdgrps_gid$Sdgrps_uids
            - - - - $event + + + + $event
            - - - - - - - - $dnotf_event$dnotf_valid$dnotf_mail$dnotf_mailsubj$dnotf_mailatt$dnotf_act + + + + + + + + $dnotf_event$dnotf_valid$dnotf_mail$dnotf_mailsubj$dnotf_mailatt$dnotf_act
            $td_modif_auth$td_delete_auth$dauth_uid$dauth_res$dauth_auth$td_modif_auth$td_delete_auth$dauth_uid$dauth_res$dauth_auth
            - - - - - - - - - - - - - - - $dusers - -
            -  UidNameLoginEmailGroupsValidUntilComment
            - - -
            - -
            Groups -
            - $SdgrpsCount groups defined -
            -
            -
            - - - - $Sdgrps - -
            -   - GidUids -
            -
            -
            -
            +
            • $userMsg

            + + + +
            Users +
            + $dusersCountValid/$dusersCount users valid/defined +
            +
            +
            + + + + + + + + + + + + + + + + $dusers + +
            +  UidNameLoginEmailGroupsValidUntilComment
            +
            +
            +
            + +
            Groups +
            + $SdgrpsCount groups defined +
            +
            +
            + + + + $Sdgrps + +
            +   + GidUids +
            +
            +
            +
            @@ -695,76 +695,76 @@ =head1 QUERY-STRING PARAMETERS PostBoard subscriptions $go2top
            -
            • $notfMsg

            - - - - -
            -
            - -
            Postboard status -
            -
            $postboardstatus
            -
            -
            - -
            Notifications -
            - $dnotfCount notifications defined -
            -
            -
            - - - - - $dunotf - -
              - Event -
            -
            -
            -
            -
            - - - - $dnotf - -
            -   - EventVUidMail
            Subject            		Mail
            Attachm.            		Action -
            -
            -
            -
            - -
            +
            • $notfMsg

            + + + + +
            +
            + +
            Postboard status +
            +
            $postboardstatus
            +
            +
            + +
            Notifications +
            + $dnotfCount notifications defined +
            +
            +
            + + + + + $dunotf + +
              + Event +
            +
            +
            +
            +
            + + + + $dnotf + +
            +   + EventVUidMail
            Subject            		Mail
            Attachm.            		Action +
            +
            +
            +
            + +
            EOPART1 @@ -777,43 +777,43 @@ =head1 QUERY-STRING PARAMETERS Authorizations $go2top
            -
            • $authMsg

            - +
            • $authMsg

            + EOPART2 print ""; print "
            "; for my $i (qw(view proc form)) { print <<"EOAUTH1" -
            $i -
            -
            - - - - $TA{$i}{dauth} - -
            -   - UidRnameAuth -
            -
            -
            -
            +
            $i +
            +
            + + + + $TA{$i}{dauth} + +
            +   + UidRnameAuth +
            +
            +
            +
            EOAUTH1 } print "
            "; @@ -822,21 +822,21 @@ =head1 QUERY-STRING PARAMETERS print ""; for my $i (qw(wiki misc)) { print <<"EOAUTH2" -
            $i -
            -
            - - - - $TA{$i}{dauth} - -
            -   - UidRnameAuth -
            -
            -
            -
            +
            $i +
            +
            + + + + $TA{$i}{dauth} + +
            +   + UidRnameAuth +
            +
            +
            +
            EOAUTH2 } print ""; diff --git a/CODE/cgi-bin/vedit.pl b/CODE/cgi-bin/vedit.pl index bca2fdaa..82cdcb14 100755 --- a/CODE/cgi-bin/vedit.pl +++ b/CODE/cgi-bin/vedit.pl @@ -27,30 +27,30 @@ =head1 VEDIT-GAZETTE BEHAVIOR WebObs::Gazette::setArticle is used by vedit 'new' action, based on the $WEBOBS{EVENTS_TO_GAZETTE} settings. WebObs::Gazette::delEventArticle is used by vedit 'del' action, based on $WEBOBS{EVENTS_GAZETTE_DELETE} settings. - $WEBOBS{EVENTS_TO_GAZETTE}|ALL # ALL = insert all created events into Gazette (= default) + $WEBOBS{EVENTS_TO_GAZETTE}|ALL # ALL = insert all created events into Gazette (= default) # NONE = events are not inserted into Gazette - $WEBOBS{EVENTS_GAZETTE_DELETE}|YES # when deleting Event, try to delete it from Gazette too + $WEBOBS{EVENTS_GAZETTE_DELETE}|YES # when deleting Event, try to delete it from Gazette too =head1 Query string parameters - object = gridType.gridName{.nodeName} - event = eventName{.txt} | eventName{/subeventName/...}/subeventName{.txt} | projectName.txt + object = gridType.gridName{.nodeName} + event = eventName{.txt} | eventName{/subeventName/...}/subeventName{.txt} | projectName.txt - object="VIEW.SOURCES.GCSCBM1", - event="GCSCBM1_2012-01-01_20-10/GCSCBM1_2012-02-01_13-20.txt" - is: $WEBOBS{ROOT_PATH}/GCSCBM1/$NODES{SPATH_INTERVENTIONS}/GCSCBM1_2012-01-01_20-10/GCSCBM1_2012-02-01_13-20.txt + object="VIEW.SOURCES.GCSCBM1", + event="GCSCBM1_2012-01-01_20-10/GCSCBM1_2012-02-01_13-20.txt" + is: $WEBOBS{ROOT_PATH}/GCSCBM1/$NODES{SPATH_INTERVENTIONS}/GCSCBM1_2012-01-01_20-10/GCSCBM1_2012-02-01_13-20.txt =over =item B - normnode := gridtype.gridname.nodename - normgrid := gridtype.gridname + normnode := gridtype.gridname.nodename + normgrid := gridtype.gridname =item B - { upd | del | new | save } + { upd | del | new | save } B is 'called' to actually process a previous B or B or B request from the user. @@ -60,12 +60,12 @@ =head1 Query string parameters =item B - eventrelpath := relative path to event file (.txt) if action is 'upd' or 'del' , - OR relative path to event's parent's extensions dir if action is 'new' + eventrelpath := relative path to event file (.txt) if action is 'upd' or 'del' , + OR relative path to event's parent's extensions dir if action is 'new' =item B - projectName := NODEName_Projet.txt + projectName := NODEName_Projet.txt =back @@ -209,7 +209,7 @@ =head1 Markitup customization if ($evname eq "") { # no *txt specified, use $formname (new event) $target = "$evbase/$evpath/$formname"; WebObs::Events::versionit(\$target); - my $fp = dirname($target); qx(mkdir -p "$fp" 2>/dev/null); + my $fp = dirname($target); qx(mkdir -p "$fp" 2>/dev/null); } else { # moving an event @@ -354,9 +354,9 @@ =head1 Markitup customization } # event metadata are stored in the header line of file as pipe-separated fields: -# UID1[+UID2+...]/RUID1[+RUID2+...]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd -# event text content -# ... +# UID1[+UID2+...]/RUID1[+RUID2+...]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd +# event text content +# ... @lines = readFile("$evbase/$evpath"); chomp(@lines); (my $authors,my $remotes,$titre,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = WebObs::Events::headersplit($lines[0]); @@ -400,10 +400,10 @@ =head1 Markitup customization "; if (length($meta) > 0) { print " - "; + "; } else { print " - "; + "; } print " "; @@ -413,64 +413,64 @@ =head1 Markitup customization if (!$isProject) { print ""; @@ -479,32 +479,32 @@ =head1 Markitup customization } else { print ""; } diff --git a/CODE/cgi-bin/vsearch.pl b/CODE/cgi-bin/vsearch.pl index c0ac1302..b7d635d4 100755 --- a/CODE/cgi-bin/vsearch.pl +++ b/CODE/cgi-bin/vsearch.pl @@ -25,7 +25,7 @@ =head1 DESCRIPTION =item B - { notebook | author | remote | alias | grid | feature | startdate | enddate | title | comment | outcome } + { notebook | author | remote | alias | grid | feature | startdate | enddate | title | comment | outcome } B is notebook number. @@ -477,15 +477,15 @@ =head1 DESCRIPTION print <<"ENDBOTOFPAGE";
            diff --git a/CODE/cgi-bin/wdir.pl b/CODE/cgi-bin/wdir.pl index 89f44e56..1ed17060 100755 --- a/CODE/cgi-bin/wdir.pl +++ b/CODE/cgi-bin/wdir.pl @@ -50,9 +50,9 @@ =head1 Query string parameters my $dir = $QryParm->{'dir'} // 'WIKI'; my $del = $QryParm->{'del'} // ''; my $sdir = $QryParm->{'sdir'} // ''; -$dir =~ s|^/+||; # remove leading / -$dir =~ s|/?$|/|; # make sure ending / -$dir =~ s|/+|/|g; # condense successive / +$dir =~ s|^/+||; # remove leading / +$dir =~ s|/?$|/|; # make sure ending / +$dir =~ s|/+|/|g; # condense successive / my @tree = split(/\//, $dir); my $updir = scalar(@tree) > 1 ? join('/',splice(@tree,0,$#tree)) : ""; my $absdir = "$abs/$dir"; diff --git a/CODE/cgi-bin/wedit.pl b/CODE/cgi-bin/wedit.pl index 993a2f26..8acc100d 100755 --- a/CODE/cgi-bin/wedit.pl +++ b/CODE/cgi-bin/wedit.pl @@ -25,12 +25,12 @@ =head1 DESCRIPTION The authorization resource-name, in authwikis resource-type, that is checked for Edit/Adm access to the file, is built from filespec following the 'path-like' resource-names rules as described in WebObs::Users. - Example: - file = HTML/public/intro.wiki - ==> actual file = $WEBOBS{PATH_DATA_WEB}/HTML/public/intro.wiki - ==> resources = authwikis.HTML/public/intro.wiki OR - = authwikis.HTML/public OR - = authwikis.HTML/ + Example: + file = HTML/public/intro.wiki + ==> actual file = $WEBOBS{PATH_DATA_WEB}/HTML/public/intro.wiki + ==> resources = authwikis.HTML/public/intro.wiki OR + = authwikis.HTML/public OR + = authwikis.HTML/ =head1 Query string parameters @@ -38,15 +38,15 @@ =head1 Query string parameters =item B - filespec := [relpath/]name - filespec (with optional relpath) is relative to $WEBOBS{PATH_DATA_WEB} + filespec := [relpath/]name + filespec (with optional relpath) is relative to $WEBOBS{PATH_DATA_WEB} =item B - { edit | save } - 'edit' (default when action is not specified) to enter html-form edit - 'save' internaly used to save the file after html-form edition - (other parameters are used along with 'save': ts0, txt, titre, html) + { edit | save } + 'edit' (default when action is not specified) to enter html-form edit + 'save' internaly used to save the file after html-form edition + (other parameters are used along with 'save': ts0, txt, titre, html) =back @@ -194,16 +194,16 @@ =head1 Markitup customization function verif_formulaire() { \$.post(\"$me\", \$(\"#theform\").serialize(), function(data) { - if (data != '') alert(data); - location.href = document.referrer; - }); + if (data != '') alert(data); + location.href = document.referrer; + }); } function convert2MMD() { - if (confirm(\"Presentation might be affected by conversion,\\nrequiring manual editing.\")) { - \$(\"#theform\")[0].conv.value = \"1\"; - verif_formulaire(); - } + if (confirm(\"Presentation might be affected by conversion,\\nrequiring manual editing.\")) { + \$(\"#theform\")[0].conv.value = \"1\"; + verif_formulaire(); + } } @@ -215,15 +215,15 @@ =head1 Markitup customization "; if (length($meta) > 0) { print " - "; + "; } else { print " - "; + "; } print " diff --git a/CODE/cgi-bin/wow.pl b/CODE/cgi-bin/wow.pl index b7d0428a..4f8f1277 100755 --- a/CODE/cgi-bin/wow.pl +++ b/CODE/cgi-bin/wow.pl @@ -18,22 +18,22 @@ =head1 FUNCTIONS =head2 SYNTAX - curl -u userid:password 'siteUrl/wow.pl?F=functionCall{&F=functionCall}' + curl -u userid:password 'siteUrl/wow.pl?F=functionCall{&F=functionCall}' - functionCall := functionName(functionArgs) - functionName := webobs | grids | proc | view | nodes | node | nloc - functionArgs := argument {, argument {, argument ...} } + functionCall := functionName(functionArgs) + functionName := webobs | grids | proc | view | nodes | node | nloc + functionArgs := argument {, argument {, argument ...} } - argument := functionName-specific - argument := nodeSpecs - argument := filter (regexp to select configuration variables) + argument := functionName-specific + argument := nodeSpecs + argument := filter (regexp to select configuration variables) - nodeSpecs := nodeName{|nodeName{|nodeName}...} - nodeSpecs := grid{|validonly|active} + nodeSpecs := nodeName{|nodeName{|nodeName}...} + nodeSpecs := grid{|validonly|active} - grid := gridType.gridName - validonly := 0 | 1 - active := today | YYYY-MM-DD | YYYY-MM-DD:YYYY-MM-DD + grid := gridType.gridName + validonly := 0 | 1 + active := today | YYYY-MM-DD | YYYY-MM-DD:YYYY-MM-DD =cut @@ -90,8 +90,8 @@ =head2 webobs(filter) dump WEBOBS.rc contents as $WEBOBS{name}=value , where name(s) match filter. - $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=webobs(SCHED)' - $WEBOBS{CONF_SCHEDULER}=/opt/webobs/CONF/scheduler.rc + $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=webobs(SCHED)' + $WEBOBS{CONF_SCHEDULER}=/opt/webobs/CONF/scheduler.rc =cut @@ -110,11 +110,11 @@ =head2 grids(filter) dump GRIDS.rc contents as $GRIDS{name}=value , where name(s) match filter - $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=grids(SPATH_)' - $GRIDS{SPATH_DOCUMENTS}=DOCUMENTS - $GRIDS{SPATH_FEATURES}=FEATURES - $GRIDS{SPATH_INTERVENTIONS}=INTERVENTIONS - ...etc... + $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=grids(SPATH_)' + $GRIDS{SPATH_DOCUMENTS}=DOCUMENTS + $GRIDS{SPATH_FEATURES}=FEATURES + $GRIDS{SPATH_INTERVENTIONS}=INTERVENTIONS + ...etc... =cut @@ -134,8 +134,8 @@ =head2 proc(procname{,filter}) dump procname.rc contents as PROC.procname{name}=value, with names(s) ordered alphabetically. Optional filter to select the dumped name(s). - $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=proc(CGPSWI,COPYRIGHT)' - PROC.CGPSWI{COPYRIGHT}=OVS/IPGP + $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=proc(CGPSWI,COPYRIGHT)' + PROC.CGPSWI{COPYRIGHT}=OVS/IPGP =cut @@ -166,9 +166,9 @@ =head2 view(viewname{,filter}) dump viewname.rc contents as VIEW.viewname{name}=value, with names(s) ordered alphabetically. Optional filter to select the dumped name(s). - $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=view(CGPSWI,^TYPE|^NAME)' - VIEW.CGPSWI{NAME}=GNSS West Indies - VIEW.CGPSWI{TYPE}= + $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=view(CGPSWI,^TYPE|^NAME)' + VIEW.CGPSWI{NAME}=GNSS West Indies + VIEW.CGPSWI{TYPE}= =cut @@ -199,14 +199,14 @@ =head2 node(nodeSpecs,nodeFilter) dump node(s) configuration file(s) (*cnf) contents as nodename{name}=value , for all nodes matching nodeSpecs. Only variables whose names match nodeFilter are dumped. - $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=node(PROC.CGPSWI|1|today)' - WDCABD0{ALIAS}=ABD0 - WDCABD0{ALTITUDE}=12 - ... - WDCBIM0{ALIAS}=BIM0 - ... - WDCCBE0{ALIAS}=CBE0 - ... + $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=node(PROC.CGPSWI|1|today)' + WDCABD0{ALIAS}=ABD0 + WDCABD0{ALTITUDE}=12 + ... + WDCBIM0{ALIAS}=BIM0 + ... + WDCCBE0{ALIAS}=CBE0 + ... =cut @@ -231,11 +231,11 @@ =head2 nodes(nodeSpecs) list nodes (ie. nodenames) matching nodeSpecs - $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=nodes(PROC.CGPSWI)' - WDCABD0 - WDCBIM0 - WDCCBE0 - ...etc... + $ curl -su user:pass 'webobs.site/cgi-bin/wow.pl?F=nodes(PROC.CGPSWI)' + WDCABD0 + WDCBIM0 + WDCCBE0 + ...etc... =cut @@ -254,19 +254,19 @@ =head2 nloc(nodeSpecs,coord,format) dump locations of nodes of a grid in different formats. - nodeSpecs must be of the form grid{|validonly|active} (ie. nodes list not allowed). + nodeSpecs must be of the form grid{|validonly|active} (ie. nodes list not allowed). - coord := geo | utm | local | xyz - for txt and csv formats, specifies the type of coordinates: - geo is latitude,longitude,altitude WGS84 (default) - utm is eastern,northern,altitude UTM WGS84 (Universal Transverse Mercator) - local is UTM in a local geodetic system (see UTM.rc) - xyz is geocentric X,Y,Z coordinates (in m) + coord := geo | utm | local | xyz + for txt and csv formats, specifies the type of coordinates: + geo is latitude,longitude,altitude WGS84 (default) + utm is eastern,northern,altitude UTM WGS84 (Universal Transverse Mercator) + local is UTM in a local geodetic system (see UTM.rc) + xyz is geocentric X,Y,Z coordinates (in m) - format := txt | csv | kml - txt returns a tab-delimited text file of nodes (default) - csv returns a semicolon-delimited text file of nodes (Excel compatible) - kml returns a KML file of nodes (Google Earth compatible) + format := txt | csv | kml + txt returns a tab-delimited text file of nodes (default) + csv returns a semicolon-delimited text file of nodes (Excel compatible) + kml returns a KML file of nodes (Google Earth compatible) =cut @@ -286,15 +286,15 @@ sub do_nloc { push(@out, $cgi->header(-type=>'application/vnd.google-earth.kml+xml', -attachment=>"$attachFn.kml",-charset=>'utf-8')); push(@out, "\n"); push(@out, "\n\n"); + + ff1313f3 + 1.0 + \nhttp://maps.google.com/mapfiles/kml/shapes/triangle.png + + + 1 + + \n"); push(@out, "\n$grid[0].$grid[1]\n"); } if ( $fmt =~ /csv/i ) { diff --git a/CODE/cgi-bin/wpage.pl b/CODE/cgi-bin/wpage.pl index 2fb3693a..e5e1c602 100755 --- a/CODE/cgi-bin/wpage.pl +++ b/CODE/cgi-bin/wpage.pl @@ -19,22 +19,22 @@ =head1 DESCRIPTION The authorization resource-name, in authwikis resource-type, that is checked for Read access to the file, is built from filespec following the 'path-like' resource-names rules as described in WebObs::Users. - Example: - file = HTML/public/intro.wiki - ==> actual file = $WEBOBS{PATH_DATA_WEB}/HTML/public/intro.wiki - ==> resources = authwikis.HTML/public/intro.wiki OR - = authwikis.HTML/public OR - = authwikis.HTML/ + Example: + file = HTML/public/intro.wiki + ==> actual file = $WEBOBS{PATH_DATA_WEB}/HTML/public/intro.wiki + ==> resources = authwikis.HTML/public/intro.wiki OR + = authwikis.HTML/public OR + = authwikis.HTML/ =head1 Query string parameters file=filespec - file to be interpreted/displayed. - B - filespec (with optional relpath) is relative to $WEBOBS{PATH_DATA_WEB} + file to be interpreted/displayed. + B + filespec (with optional relpath) is relative to $WEBOBS{PATH_DATA_WEB} css=cssfile - user-defined css file to include in output page; must be located in WebObs css directory + user-defined css file to include in output page; must be located in WebObs css directory =cut diff --git a/CODE/cgi-bin/xedit.pl b/CODE/cgi-bin/xedit.pl index 516e42a4..e70eab7b 100755 --- a/CODE/cgi-bin/xedit.pl +++ b/CODE/cgi-bin/xedit.pl @@ -22,20 +22,20 @@ =head1 QUERY STRING B is a 1-level indirection, where wokey is the $WEBOBS{key} that points to the configuration file that defines the ikey whose value is the filename to be edited. In both cases, the target filename must reside in $WEBOBS{ROOT_CONF} or $WEBOBS{ROOT_DATA}; its WebObs' authorization resource name is B (see Users.pm for path-like resources) - eg. : fs=CONF_NODES - will browse/edit the CONF/file pointed to by $WEBOBS{CONF_NODES} + eg. : fs=CONF_NODES + will browse/edit the CONF/file pointed to by $WEBOBS{CONF_NODES} - eg. : fs=CONF_NODES(FILE_NODES2NODES) - will browse/edit the file pointed to by FILE_NODES2NODES in the file pointed to by $WEBOBS{CONF_NODES} + eg. : fs=CONF_NODES(FILE_NODES2NODES) + will browse/edit the file pointed to by FILE_NODES2NODES in the file pointed to by $WEBOBS{CONF_NODES} B or B is the filename to be edited, in $WEBOBS{ROOT_CONF} or $WEBOBS{ROOT_DATA} respectively; its WebObs' authorization resource name is B (see Users.pm for path-like resources) =item action={save | edit} - 'edit' (default when action is not specified) to display edit html-form edit - 'save' internaly used to save the file after html-form edition - (other parameters are used along with 'save': ts0, txt) + 'edit' (default when action is not specified) to display edit html-form edit + 'save' internaly used to save the file after html-form edition + (other parameters are used along with 'save': ts0, txt) =item browse= @@ -210,13 +210,13 @@ =head1 CONFIGURATION VARIABLES # - page, xedit scripts print " diff --git a/CODE/perl/exposerc.pl b/CODE/perl/exposerc.pl index b987d0da..76e0f4cb 100755 --- a/CODE/perl/exposerc.pl +++ b/CODE/perl/exposerc.pl @@ -21,17 +21,17 @@ =head1 DESCRIPTION example from a bash script exporting WEBOBS.rc variables following WEBOBS' readCfg rules: - oIFS=${IFS}; IFS=$'\n' - LEXP=($(perl /etc/webobs.d/../CODE/cgi-bin/exposerc.pl '=' 'WO__')) - for i in $(seq 0 1 $(( ${#LEXP[@]}-1 )) ); do export ${LEXP[$i]}; done - IFS=${oIFS} + oIFS=${IFS}; IFS=$'\n' + LEXP=($(perl /etc/webobs.d/../CODE/cgi-bin/exposerc.pl '=' 'WO__')) + for i in $(seq 0 1 $(( ${#LEXP[@]}-1 )) ); do export ${LEXP[$i]}; done + IFS=${oIFS} example from a bash script exportng $WEBOBS{CONF_SCHEDULER} file's variables : - oIFS=${IFS}; IFS=$'\n' - LEXP=($(perl /etc/webobs.d/../CODE/cgi-bin/exposerc.pl '=' 'SC__' 'CONF_SCHEDULER')) - for i in $(seq 0 1 $(( ${#LEXP[@]}-1 )) ); do export ${LEXP[$i]}; done - IFS=${oIFS} + oIFS=${IFS}; IFS=$'\n' + LEXP=($(perl /etc/webobs.d/../CODE/cgi-bin/exposerc.pl '=' 'SC__' 'CONF_SCHEDULER')) + for i in $(seq 0 1 $(( ${#LEXP[@]}-1 )) ); do export ${LEXP[$i]}; done + IFS=${oIFS} =cut diff --git a/CODE/perl/lib/Config.pm b/CODE/perl/lib/Config.pm index bce27a33..0b67b9c2 100644 --- a/CODE/perl/lib/Config.pm +++ b/CODE/perl/lib/Config.pm @@ -6,13 +6,13 @@ Package WebObs : Common perl-cgi variables and functions =head1 SYNOPSIS - use WebObs::Config; + use WebObs::Config; - $file = $WEBOBS{FILE_MYFILENAME}; # using %WEBOBS definitions - %myHash = readCfg($file); # reading a key|value configuration file + $file = $WEBOBS{FILE_MYFILENAME}; # using %WEBOBS definitions + %myHash = readCfg($file); # reading a key|value configuration file - use CGI::Carp qw(fatalsToBrowser set_message); - set_message(\&webobs_cgi_msg); # using the dedicated cgi error messages formatter + use CGI::Carp qw(fatalsToBrowser set_message); + set_message(\&webobs_cgi_msg); # using the dedicated cgi error messages formatter =head1 DESCRIPTION @@ -61,13 +61,13 @@ Rule #6 : field value substitution is allowed in =key|value form: Rule #7 : line continuation (ie. field value spanning more than one line), if desired, is specified by a \ (backslash) as the last character of a line. - Note: leading and trailing spaces in each line are preserved. - Example: + Note: leading and trailing spaces in each line are preserved. + Example: - LONGLIST|Element1,\ - Element2,\ - Element3 - is equivalent to: LONGLIST|Element1, Element2,Element3 + LONGLIST|Element1,\ + Element2,\ + Element3 + is equivalent to: LONGLIST|Element1, Element2,Element3 Rule #8 : configuration files are all considered ISO-8859-15 (latin) encoded @@ -127,12 +127,12 @@ sub webobs_cgi_msg { =head2 readFile - # reading all lines from filepath/filename into @lines: - @lines = readFile("filepath/filename"); + # reading all lines from filepath/filename into @lines: + @lines = readFile("filepath/filename"); - # reading all lines starting with 1130| from /filepath/filename into @lines : - $filter = qr/^1130\|/; - @lines = readFile("/filepath/filename",$filter); + # reading all lines starting with 1130| from /filepath/filename into @lines : + $filter = qr/^1130\|/; + @lines = readFile("/filepath/filename",$filter); Reads file contents (optionaly filtered with $filter regex reference) into an array. All lines are read unfiltered, uninterpreted, unchanged. @@ -168,9 +168,9 @@ sub readFile eXtended readFile(). Performs same functions as readFile, but returns both 1) a reference to the file contents and 2) the 'last-modified-timestamp' of the file - # reading all lines from filepath/filename : - ($ptr, $ts) = readFile("filepath/filename"); - print "filepath/filename timestamped ".strftime("%F %T",localtime($ts)).":\n @$ptr"; + # reading all lines from filepath/filename : + ($ptr, $ts) = readFile("filepath/filename"); + print "filepath/filename timestamped ".strftime("%F %T",localtime($ts)).":\n @$ptr"; Follows all other rules of readFile(). @@ -205,7 +205,7 @@ sub xreadFile =head2 readCfgFile - @lines = readCfgFile("[filepath/]filename"); + @lines = readCfgFile("[filepath/]filename"); reads file contents into an array, converting lines to UTF8, and removing commented lines (# in col1), blank lines, and all \r (CR). @@ -234,10 +234,10 @@ sub readCfgFile =head2 readCfg - %lines = readCfg("[filepath]/filename"); # for key|value[|value...] files - %lines = readCfg("[filepath]/filename",'sorted'); # adds $lines{}{_SO_} (sort order) + %lines = readCfg("[filepath]/filename"); # for key|value[|value...] files + %lines = readCfg("[filepath]/filename",'sorted'); # adds $lines{}{_SO_} (sort order) - @lines = readCfg("[filepath]/filename"); # other files + @lines = readCfg("[filepath]/filename"); # other files reads in a configuration file (defaults to main webobs WEBOBS.conf if none is specified). See DESCRIPTION above for a description of readCfg interpretation rules @@ -259,11 +259,11 @@ sub readCfg s/(^\s+)||(\s+$)//g; # remove leading & trailing blanks s/\r//g; # remove all CRs not only in CRLF next if /^$/ ; # ignore empty lines - if (m/^=([^ ]*)/) { # got a definition line ? - @df = split(/\|/); # save it - next; # and forget it + if (m/^=([^ ]*)/) { # got a definition line ? + @df = split(/\|/); # save it + next; # and forget it } - $l = l2u($_); # force utf8 ! + $l = l2u($_); # force utf8 ! @wrk = split(/(? DATA/DB/yourFormName.db - /yourFormName.ddl + CONF/FORMS/yourFormName/yourFormName.conf --> DATA/DB/yourFormName.db + /yourFormName.ddl =head1 DEVELOPPER NOTES @@ -29,109 +29,109 @@ DBForm Perl object: interface to a WebObs 'Form' SQLite DataBase =head1 USING DBForm OBJECT - ## Path to DBFORMSdirectory/thisform - print $F->{path}; # eg: /webobs/site/path/to/dbforms/DBF + ## Path to DBFORMSdirectory/thisform + print $F->{path}; # eg: /webobs/site/path/to/dbforms/DBF - ## full name of DBFORM's database file - print $F->{dbname}; # eg: /webobs/site/DATA/DB/DBF.db + ## full name of DBFORM's database file + print $F->{dbname}; # eg: /webobs/site/DATA/DB/DBF.db - ## access the DBFORM's DataBase Handle (presumably to issue your own sql queries?) - $F->{dbh} + ## access the DBFORM's DataBase Handle (presumably to issue your own sql queries?) + $F->{dbh} - ## any parameter from DBFORM's conf file - print $F->conf(BANG); # eg: 2000 + ## any parameter from DBFORM's conf file + print $F->conf(BANG); # eg: 2000 - ## last DBFORM's sql-related method call error - print $F->{errstr} + ## last DBFORM's sql-related method call error + print $F->{errstr} - ## the sql select where clause (no leading 'and') - $F->{where} = " ids.node = 'MYNODE' "; # select for MYNODE only - $F->{where} = " ids.ts1 like '2014-07%' or ids.ts1 is null "; # only Jul 2014 or unknown date1 - $F->{where} = " ids.id = 25 "; # select unique row 25 ($F->select(25) would do the same) - # the default {where} is : " ids.hidden = 'N' " (check, may change over releases) + ## the sql select where clause (no leading 'and') + $F->{where} = " ids.node = 'MYNODE' "; # select for MYNODE only + $F->{where} = " ids.ts1 like '2014-07%' or ids.ts1 is null "; # only Jul 2014 or unknown date1 + $F->{where} = " ids.id = 25 "; # select unique row 25 ($F->select(25) would do the same) + # the default {where} is : " ids.hidden = 'N' " (check, may change over releases) - ## the sql select order by clause - $F->{order} = " order by ids.node,data.val1 ASC "; - # the default {order} is : " ORDER BY ids.ts1 ASC" (check, may change over releases) + ## the sql select order by clause + $F->{order} = " order by ids.node,data.val1 ASC "; + # the default {order} is : " ORDER BY ids.ts1 ASC" (check, may change over releases) - ## read and process all rows - $F->select; - if (! $self->{errstr}) { - while ( my $row = $F->fetch ) { - print Dumper $row; - } - } + ## read and process all rows + $F->select; + if (! $self->{errstr}) { + while ( my $row = $F->fetch ) { + print Dumper $row; + } + } - ## processing a single row $row returned by 'fetch' method - ## $row is a reference to a hash of columnName => value - ## null sql values are Perl's undef - if ($row->{columnName}) { do sthg, $row->{columnName} is the value } - else { do your own defaulting/processing for such undef value} + ## processing a single row $row returned by 'fetch' method + ## $row is a reference to a hash of columnName => value + ## null sql values are Perl's undef + if ($row->{columnName}) { do sthg, $row->{columnName} is the value } + else { do your own defaulting/processing for such undef value} - ## returns array of column names that have been used in select - print $F->cols; # eg: (id,ts1,.....,val1,val2,val3) + ## returns array of column names that have been used in select + print $F->cols; # eg: (id,ts1,.....,val1,val2,val3) - ## insert a row from an Html QueryString parameters hash - ## the QueryString hash reference is your CGI's $cgi->Vars - ## also returns a scalar = the inserted row id on success - $QS = $cgi->Vars; - $i = $F->insert($QP); - if ($F->{errstr)) { your own error processing, $F->{errstr} containing the error string } + ## insert a row from an Html QueryString parameters hash + ## the QueryString hash reference is your CGI's $cgi->Vars + ## also returns a scalar = the inserted row id on success + $QS = $cgi->Vars; + $i = $F->insert($QP); + if ($F->{errstr)) { your own error processing, $F->{errstr} containing the error string } - ## delete the row ID=10 - $F->delete(10); + ## delete the row ID=10 + $F->delete(10); - ## get array of CHECK constraints in DATA table - print map { "$_\n" } $F->datachecks; - # eg: val2 > 10 - # val3 between 0.0 and 1.0 + ## get array of CHECK constraints in DATA table + print map { "$_\n" } $F->datachecks; + # eg: val2 > 10 + # val3 between 0.0 and 1.0 - ## get list of all procs pointing to this FORM, along with their 'long' name - %P = $F->procs - print $P{SOURCES}; #eg: 'Analyse Sources Thermales' - map { print "$_ ... " } keys(%P); #eg: 'TRACAGE2010 ... SOURCES ...' + ## get list of all procs pointing to this FORM, along with their 'long' name + %P = $F->procs + print $P{SOURCES}; #eg: 'Analyse Sources Thermales' + map { print "$_ ... " } keys(%P); #eg: 'TRACAGE2010 ... SOURCES ...' - ## get all NODEs (and its ALIAS,NAME and FID) of a PROC pointing to this FORM - %N = $F->nodes(SOURCES); - map {print "$_ ... "} keys(%N); #eg: GCSGAL1 ... GCSTAR1 ... GCSACQ0 ... - print $N{GCSGAL1}{ALIAS}; #eg: 'GA' + ## get all NODEs (and its ALIAS,NAME and FID) of a PROC pointing to this FORM + %N = $F->nodes(SOURCES); + map {print "$_ ... "} keys(%N); #eg: GCSGAL1 ... GCSTAR1 ... GCSACQ0 ... + print $N{GCSGAL1}{ALIAS}; #eg: 'GA' - ## dump the DBFORM object - print $F->dump; + ## dump the DBFORM object + print $F->dump; =head1 DBFORM CONFIGURATION A DBFORM is defined by its configuration file: $WEBOBS{PATH_FORMS}/DBFORMName/DBFORMName.conf - =key|value - BANG|2000 - DBNAME|DBF.db - TITLE|DB-based Form Model - FILE_CSV_PREFIX|DBF + =key|value + BANG|2000 + DBNAME|DBF.db + TITLE|DB-based Form Model + FILE_CSV_PREFIX|DBF =head1 DBFORM DB SCHEMA A DBFORM DataBase ( $WEBOBS{PATH_DATA_DB}/DBNAME ) has the following basic structure: - Required TABLE 'ids' - * note: ts1, ts2 not timestamps because of required nullable components - ------------------ - id INTEGER PRIMARY KEY AUTOINCREMENT, - ts1 TEXT, - ts2 TEXT, - node TEXT NOT NULL, - comment TEXT, - hidden TEXT DEFAULT 'N', - tsupd TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, - userupd TEXT NOT NULL DEFAULT '!' + Required TABLE 'ids' + * note: ts1, ts2 not timestamps because of required nullable components + ------------------ + id INTEGER PRIMARY KEY AUTOINCREMENT, + ts1 TEXT, + ts2 TEXT, + node TEXT NOT NULL, + comment TEXT, + hidden TEXT DEFAULT 'N', + tsupd TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, + userupd TEXT NOT NULL DEFAULT '!' Required TABLE 'data' example - * note: data fields may not be all known at once, so define them then as 'nullable' - --------------------------- - id INTEGER REFERENCES ids(id) ON DELETE CASCADE ON UPDATE CASCADE - val1 TEXT - val2 INTEGER CHECK(val2 > 10) - val3 REAL CHECK(val3 BETWEEN 0.0 AND 1.0) + * note: data fields may not be all known at once, so define them then as 'nullable' + --------------------------- + id INTEGER REFERENCES ids(id) ON DELETE CASCADE ON UPDATE CASCADE + val1 TEXT + val2 INTEGER CHECK(val2 > 10) + val3 REAL CHECK(val3 BETWEEN 0.0 AND 1.0) =cut @@ -391,4 +391,4 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . =cut - + diff --git a/CODE/perl/lib/Dates.pm b/CODE/perl/lib/Dates.pm index ba6acd8f..a6e95993 100644 --- a/CODE/perl/lib/Dates.pm +++ b/CODE/perl/lib/Dates.pm @@ -13,7 +13,7 @@ use WebObs::Dates @calhtml = WebObs::Dates::Calendar(month=>'2012-12', ptri=>'Calendar', - today=>'2012-12-31'); + today=>'2012-12-31'); $monday = WebObs::Dates::lundi('2012-09-14'); @@ -152,10 +152,10 @@ sub Calendar my $lundiCalendrier = WebObs::Dates::lundi("$moisCalendrier-01"); push(@contenu," - - - - \n"); + + + + \n"); push(@contenu,""); # il faut balayer 6 semaines pour être sûr d'avoir le mois complet dans toutes les situations... diff --git a/CODE/perl/lib/Events.pm b/CODE/perl/lib/Events.pm index b77e63e4..98e5faff 100644 --- a/CODE/perl/lib/Events.pm +++ b/CODE/perl/lib/Events.pm @@ -19,40 +19,40 @@ Subevents are themselves events, thus building up a tree structure for each even B live in B of nodes and/or grids: B subdirectories. - Events base directories (interventions): - $GRIDS{PATH_GRIDS}/gridtype/gridname/$GRIDS{SPATH_INTERVENTIONS}/ - $NODES{PATH_NODES}/nodename/$NODES{SPATH_INTERVENTIONS}/ - - Events 'trash' directories (for deleted events): - $NODES{PATH_EVENTNODE_TRASH} - $GRIDS{PATH_EVENTGRID_TRASH} - - Events files and extensions naming conventions: - event_file := event.txt - event_extensions := event/ - event := name_YYYY-MM-DD_HH-MM{_v} | name_YYYY-MM-DD_NA{_v} - name := { gridname | nodename } - v := so-called version number (automatically generated to make event name unique) - NA := "NA" for unknown/undefined HH-MM - - Special event file: the Project; only one allowed per Node or Grid, at the first level - project_file := name_Projet.txt - - Unfolded example for node NODEA events: - $NODES{PATH_NODES}/NODEA/$NODES{SPATH_INTERVENTIONS}/ - NODEA_Projet.txt - NODEA_2001-01-01_20-00.txt Event 2001-01-01 20:00 file - NODEA_2001-01-01_20-00/ Event 2001-01-01 20:00 extensions - PHOTOS/ Event 2001-01-01 20:00 photos - *.[jpg,pdf] - THUMBNAILS/ - NODEA_2002-02-02_02-02.txt subEvent 2002-02-02 02:02 - NODEA_2002-02-02_02-02/ subEvent 2002-02-02 02:02 extensions - PHOTOS/ subEvent 2002-02-02 02:02 photos - *.[jpg,pdf] - THUMBNAILS - NODEA_2003-03-03_03-03.txt subsubEvent 2003-03-03 03:03 - NODEA_2010-02-02_22-30.txt Event 2010-02-02 22:30 + Events base directories (interventions): + $GRIDS{PATH_GRIDS}/gridtype/gridname/$GRIDS{SPATH_INTERVENTIONS}/ + $NODES{PATH_NODES}/nodename/$NODES{SPATH_INTERVENTIONS}/ + + Events 'trash' directories (for deleted events): + $NODES{PATH_EVENTNODE_TRASH} + $GRIDS{PATH_EVENTGRID_TRASH} + + Events files and extensions naming conventions: + event_file := event.txt + event_extensions := event/ + event := name_YYYY-MM-DD_HH-MM{_v} | name_YYYY-MM-DD_NA{_v} + name := { gridname | nodename } + v := so-called version number (automatically generated to make event name unique) + NA := "NA" for unknown/undefined HH-MM + + Special event file: the Project; only one allowed per Node or Grid, at the first level + project_file := name_Projet.txt + + Unfolded example for node NODEA events: + $NODES{PATH_NODES}/NODEA/$NODES{SPATH_INTERVENTIONS}/ + NODEA_Projet.txt + NODEA_2001-01-01_20-00.txt Event 2001-01-01 20:00 file + NODEA_2001-01-01_20-00/ Event 2001-01-01 20:00 extensions + PHOTOS/ Event 2001-01-01 20:00 photos + *.[jpg,pdf] + THUMBNAILS/ + NODEA_2002-02-02_02-02.txt subEvent 2002-02-02 02:02 + NODEA_2002-02-02_02-02/ subEvent 2002-02-02 02:02 extensions + PHOTOS/ subEvent 2002-02-02 02:02 photos + *.[jpg,pdf] + THUMBNAILS + NODEA_2003-03-03_03-03.txt subsubEvent 2003-03-03 03:03 + NODEA_2010-02-02_22-30.txt Event 2010-02-02 22:30 =cut @@ -90,11 +90,11 @@ $VERSION = "1.00"; struct(objectname) takes objectname as a normalized grid name OR normalized node name and returns an array whose elements are: - [0] = gridtype - [1] = gridname - [2] = nodename - [3] = path-to-event-directory - [4] = path-to-trash-directory + [0] = gridtype + [1] = gridname + [2] = nodename + [3] = path-to-event-directory + [4] = path-to-trash-directory struct returns 'undef' if 1) objectname is not a well-formed normalized object or 2) it is a grid but $GRIDS{PATH_GRIDS} is not defined (ie. events for grids are not enabled). @@ -121,10 +121,10 @@ sub struct { eventnameSplit(eventname) decodes event name string and returns an array of elements: - [0] = object (node ID or grid name) - [1] = date (yyyy-mm-dd) - [2] = time (HH:MM or void) - [3] = version + [0] = object (node ID or grid name) + [1] = date (yyyy-mm-dd) + [2] = time (HH:MM or void) + [3] = version =cut @@ -152,15 +152,15 @@ sub eventnameSplit { headersplit(header) decodes header string and returns an array of elements: - [0] = author UID (array) - [1] = remote operator UID (array) - [2] = title - [3] = end date & time - [4] = feature - [5] = channel - [6] = outcome flag - [7] = notebook number - [8] = notebook forward flag + [0] = author UID (array) + [1] = remote operator UID (array) + [2] = title + [3] = end date & time + [4] = feature + [5] = channel + [6] = outcome flag + [7] = notebook number + [8] = notebook forward flag =cut @@ -168,7 +168,7 @@ sub headersplit { my ($title,$date2,$time2,$feature,$channel,$outcome,$notebook,$notebookfwd) = ""; # event metadata are stored in the header line of file as pipe-separated fields: -# UID1[+UID2+...][/RUID1[+RUID2+...]]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd +# UID1[+UID2+...][/RUID1[+RUID2+...]]|title|enddatetime|feature|channel|outcome|notebook|notebookfwd my $pipes = $_[0] =~ tr/\|//; # count the number of pipes in header my @header = split(/\|/,$_[0]); # splits pipe-separated arguments my @people = split(/\//,$header[0]); # splits authors and remotes (forward slash separator) @@ -199,12 +199,12 @@ sub headersplit { eventsTree(list, path) appends to list the events filenames tree starting path and sorted by descending dates. - list is a reference to the array of Events filenames (*.txt) - path the objectname + list is a reference to the array of Events filenames (*.txt) + path the objectname - Example: - my @treeInterventions; - eventsTree(\@listInterventions, "/webobs/path/DATA/NODES/node/INTERVENTIONS"); + Example: + my @treeInterventions; + eventsTree(\@listInterventions, "/webobs/path/DATA/NODES/node/INTERVENTIONS"); =cut @@ -232,12 +232,12 @@ sub eventsTree { eventsChrono(list, path) appends to list the sorted (dates descending) events filenames in path. - list is a reference to the target array of events filenames (*.txt) - path path to events directory structure + list is a reference to the target array of events filenames (*.txt) + path path to events directory structure - Example: - my @listInterventions; - eventsChrono(\@listInterventions, "/webobs/path/DATA/NODES/node/INTERVENTIONS"); + Example: + my @listInterventions; + eventsChrono(\@listInterventions, "/webobs/path/DATA/NODES/node/INTERVENTIONS"); =cut @@ -308,9 +308,9 @@ sub countEvents { return existEvents(@_) } eventsShow(sortedBy, objectname, editYN) returns the html string displaying the sortedBy events of objectname. editYN indicates wether current viewing client has authorization to edit events (0/1). - $contents = eventsShow("events", "PROC.PNAME", 0 ); + $contents = eventsShow("events", "PROC.PNAME", 0 ); - $contents = eventsShow("date", "VIEW.MYVIEW.NODE1", 1); + $contents = eventsShow("date", "VIEW.MYVIEW.NODE1", 1); =cut @@ -421,7 +421,7 @@ sub eventsShow { projectShow(objectname, editYN) returns the html string displaying the Project contents of objectname. editYN indicates wether current viewing client has authorization to edit Project (0/1). - $contents = projectShow("PROC.PNAME", 0 ); + $contents = projectShow("PROC.PNAME", 0 ); =cut @@ -513,8 +513,8 @@ returns an html-tagged string describing all parent events of an event: path is the events directory 'root' path, as can be obtained via a call to struct routine; event is the relative (to path) event path. - $path = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_INTERVENTIONS}"; - $html = parents($path, "$NODEName_2000-01-01_01-01/$NODEName_2002-12-11_01-01"); + $path = "$NODES{PATH_NODES}/$NODEName/$NODES{SPATH_INTERVENTIONS}"; + $html = parents($path, "$NODEName_2000-01-01_01-01/$NODEName_2002-12-11_01-01"); This routine replaces the WebObs::Grids::parentEvents() method to account for grids events as well as nodes events diff --git a/CODE/perl/lib/Form.pm b/CODE/perl/lib/Form.pm index ce706431..c4570865 100644 --- a/CODE/perl/lib/Form.pm +++ b/CODE/perl/lib/Form.pm @@ -6,39 +6,39 @@ Package WebObs : Common perl-cgi variables and functions =head1 SYNOPSIS - use WebObs::Form; - $F = new WebObs::Form('EAUX'); + use WebObs::Form; + $F = new WebObs::Form('EAUX'); - # Path to FORMSdirectory/thisform - # eg: /webobs/site/path/to/forms/EAUX - print $F->path; + # Path to FORMSdirectory/thisform + # eg: /webobs/site/path/to/forms/EAUX + print $F->path; - # full name of FORM's data file - # eg: /webobs/site/data/EAUX.DAT - print $F->fnam + # full name of FORM's data file + # eg: /webobs/site/data/EAUX.DAT + print $F->fnam - # any parameter from FORM's conf file - # eg: CGI_SHOW : showEAUX.pl - print $F->conf(CGI-SHOW) + # any parameter from FORM's conf file + # eg: CGI_SHOW : showEAUX.pl + print $F->conf(CGI-SHOW) - # read FORM's data file's record id = 1130 - ($recs, $ts) = $F->data(1130); @line = @$recs; + # read FORM's data file's record id = 1130 + ($recs, $ts) = $F->data(1130); @line = @$recs; - # read FORM's data file - ($recs, $ts) = $F->data; @lines = @$recs; + # read FORM's data file + ($recs, $ts) = $F->data; @lines = @$recs; - # get list of all procs pointing to this FORM, along with their 'long' name - %P = $F->procs - print $P{SOURCES}; #eg: 'Analyse Sources Thermales' - map { print "$_ ... " } keys(%P); #eg: 'TRACAGE2010 ... SOURCES ...' + # get list of all procs pointing to this FORM, along with their 'long' name + %P = $F->procs + print $P{SOURCES}; #eg: 'Analyse Sources Thermales' + map { print "$_ ... " } keys(%P); #eg: 'TRACAGE2010 ... SOURCES ...' - # get all NODEs (and its ALIAS,NAME and FID) of a PROC pointing to this FORM - %N = $F->nodes(SOURCES); - map {print "$_ ... "} keys(%N); #eg: GCSGAL1 ... GCSTAR1 ... GCSACQ0 ... - print $N{GCSGAL1}{ALIAS}; #eg: 'GA' + # get all NODEs (and its ALIAS,NAME and FID) of a PROC pointing to this FORM + %N = $F->nodes(SOURCES); + map {print "$_ ... "} keys(%N); #eg: GCSGAL1 ... GCSTAR1 ... GCSACQ0 ... + print $N{GCSGAL1}{ALIAS}; #eg: 'GA' - # dump the FORM object - print $F->dump; + # dump the FORM object + print $F->dump; =head1 DESCRIPTION @@ -260,4 +260,4 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . =cut - + diff --git a/CODE/perl/lib/GML.pm b/CODE/perl/lib/GML.pm index dcdbec7a..850443d7 100644 --- a/CODE/perl/lib/GML.pm +++ b/CODE/perl/lib/GML.pm @@ -56,7 +56,7 @@ sub gmlarray2nodearray { } return @NodesList; - ## Case 2: we want a specific node (idx € int) + ## Case 2: we want a specific node (idx € int) } else { ## find id of the node we want my $id = @Ids[$idx]; @@ -130,7 +130,7 @@ sub gmlread_feature { } #### HARDCODED XML2 - # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); + # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); my @Gml = qx(/usr/bin/xml2 < $file); ###### Receiver @@ -220,7 +220,7 @@ sub gml2mmdtable { push(@outlines,"WebObs: converted with wiki2MMD\n\n"); #### HARDCODED XML2 - # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); + # my @Gml = qx($WEBOBS{XML2_PRGM} < $file); my @Gml = qx(/usr/bin/xml2 < $gmlfile); ###### Receiver diff --git a/CODE/perl/lib/Gazette.pm b/CODE/perl/lib/Gazette.pm index 8dcd8fab..3363fd69 100644 --- a/CODE/perl/lib/Gazette.pm +++ b/CODE/perl/lib/Gazette.pm @@ -14,7 +14,7 @@ Webobs' Gazette management. Gazette DB table columns: - ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT + ID,STARTDATE,STARTTIME,ENDDATE,ENDTIME,CATEGORY,UID,OTHERS,PLACE,SUBJECT =cut @@ -84,22 +84,22 @@ Builds html code to display Gazette articles for a given period. Returns an array of html strings. - Show(view=>, from=>, to=>, categories=>, textfilter=>, jseditor=>, jsevent=>) + Show(view=>, from=>, to=>, categories=>, textfilter=>, jseditor=>, jsevent=>) Arguments: - Required: - view=> { calendar | datelist | categorylist | ical | dump | stats} - from=> YYYY-MM-DD start date + Required: + view=> { calendar | datelist | categorylist | ical | dump | stats} + from=> YYYY-MM-DD start date - Optional: - to=> YYYY-MM-DD end date (defaults to from) - categories=> { '' | 'categoryName(,categoryName(,...))' } - textfilter=> regexp to keep matching articles - jseditor=> a javascript function name to be called when click on article for edition; - automatically passed arguments will be (this,article's ID). - jsevent=> a javascript function name to be called when click on 'event' article; - automatically passed argument will be (objectname), ie: (gridtype.gridname[.nodename]). + Optional: + to=> YYYY-MM-DD end date (defaults to from) + categories=> { '' | 'categoryName(,categoryName(,...))' } + textfilter=> regexp to keep matching articles + jseditor=> a javascript function name to be called when click on article for edition; + automatically passed arguments will be (this,article's ID). + jsevent=> a javascript function name to be called when click on 'event' article; + automatically passed argument will be (objectname), ie: (gridtype.gridname[.nodename]). =cut @@ -548,19 +548,19 @@ NOTE: checkings for valid and user-authorized categories, if desired, must be ha Arguments: - Required: - from=> startdate YYYY-MM-DD - to=> enddate YYYY-MM-DD + Required: + from=> startdate YYYY-MM-DD + to=> enddate YYYY-MM-DD - Optional: - categories=> sql 'in' clause, ie. if omitted or '' will select all categories - order=> sql 'order by' clause + Optional: + categories=> sql 'in' clause, ie. if omitted or '' will select all categories + order=> sql 'order by' clause Example: - $Gazette = WebObs::Gazette::getRaw(from=>'2014-12-26',to=>'2015-01-20',order=>'STARTDATE,ENDDATE'); - print("Number of articles = ".@{$Gazette}."\n"); - map { print join(", ",@{$_}), "\n" } @{$Gazette}; # print each article with comma-separated fields + $Gazette = WebObs::Gazette::getRaw(from=>'2014-12-26',to=>'2015-01-20',order=>'STARTDATE,ENDDATE'); + print("Number of articles = ".@{$Gazette}."\n"); + map { print join(", ",@{$_}), "\n" } @{$Gazette}; # print each article with comma-separated fields =cut @@ -623,9 +623,9 @@ to build the article fields. setEventArticle will then use setArticle(). Also refer to vedit.pl for Event management considerations. - objectname: GRIDType.GRIDName[.NODEName]. - filename: NODEName_YYYY-MM-DD_HH-MM[_version].txt or - GRIDName_YYYY-MM-DD_HH-MM[_version].txt + objectname: GRIDType.GRIDName[.NODEName]. + filename: NODEName_YYYY-MM-DD_HH-MM[_version].txt or + GRIDName_YYYY-MM-DD_HH-MM[_version].txt =cut @@ -689,9 +689,9 @@ This function identifies the article by contents (ie. date,time,,category,place, internal ID column. Also refer to vedit.pl for Event management considerations. - objectname: GRIDType.GRIDName[.NODEName]. - filename: NODEName_YYYY-MM-DD_HH-MM[_version].txt or - GRIDName_YYYY-MM-DD_HH-MM[_version].txt + objectname: GRIDType.GRIDName[.NODEName]. + filename: NODEName_YYYY-MM-DD_HH-MM[_version].txt or + GRIDName_YYYY-MM-DD_HH-MM[_version].txt Returns 0 or number of rows deleted. @@ -884,15 +884,15 @@ sub articleTip { ixApplicable(rs,from,to) list the articles indexes of a getRaw() result set array corresponding to articles appearing in the [from-to] period. The list of 'applicable' indexes of 'rs' is returned as an array. - Required arguments: - rs Reference to a getRaw() result set array - from Time::Piece object of the first day of the period as a Time::Piece object - to Time::Piece object of the last day of the period; if omitted, will default to from + Required arguments: + rs Reference to a getRaw() result set array + from Time::Piece object of the first day of the period as a Time::Piece object + to Time::Piece object of the last day of the period; if omitted, will default to from - @ix = ixApplicable(\@Gazette, $fromTimePiece, $toTimePiece); - # printing all corresponding article-IDs ([G_ID]) would then be : - map { print "@{$Gazette}[$_]->[G_ID]\n" } @ix; - + @ix = ixApplicable(\@Gazette, $fromTimePiece, $toTimePiece); + # printing all corresponding article-IDs ([G_ID]) would then be : + map { print "@{$Gazette}[$_]->[G_ID]\n" } @ix; + =cut sub ixApplicable { @@ -931,4 +931,4 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . =cut - + diff --git a/CODE/perl/lib/Grids.pm b/CODE/perl/lib/Grids.pm index 6027ca2f..1f5f6c99 100644 --- a/CODE/perl/lib/Grids.pm +++ b/CODE/perl/lib/Grids.pm @@ -129,7 +129,7 @@ sub readProc { opendir(DIR, "$WEBOBS{PATH_GRIDS2FORMS}"); my @lSf = grep {/^PROC\.($f)\./ && -l $WEBOBS{PATH_GRIDS2FORMS}."/".$_} readdir(DIR); foreach (@lSf) {s/^PROC\.($f)\.//g}; - $tmp{'FORM'} = $lSf[0]; #NOTE: keeps only the first FORM + $tmp{'FORM'} = $lSf[0]; #NOTE: keeps only the first FORM closedir(DIR); # --- get DOMAIN diff --git a/CODE/perl/lib/Mapping.pm b/CODE/perl/lib/Mapping.pm index 2c33063d..c3dc62dd 100644 --- a/CODE/perl/lib/Mapping.pm +++ b/CODE/perl/lib/Mapping.pm @@ -30,7 +30,7 @@ configuration parameter UTM_LOCAL pointing to its own definitions file. Author: François Beauducel, IPGP Created: 2009-10-21 (translated from Matlab 2003 author's toolbox) - Updated: 2022-05-29 + Updated: 2022-05-29 I.G.N., Changement de système géodésique: Algorithmes, Notes Techniques NT/G 80, janvier 1995. I.G.N., Projection cartographique Mercator Transverse: Algorithmes, Notes Techniques NT/G 76, janvier 1995. @@ -69,9 +69,9 @@ Sets the %UTM structure with the contents of $utmfilename (if provided and exist or with the contents of $WEBOBS{UTM_LOCAL} -the default definitions- (if it exists). Returns %UTM address if loaded successfully, 0 otherwise. - print "OK" if ( setUTMLOCAL($utmfilename) ); # try load $utmfilename or default settings + print "OK" if ( setUTMLOCAL($utmfilename) ); # try load $utmfilename or default settings - print Dumper setUTMLOCAL(); # try load + dump the default UTM settings + print Dumper setUTMLOCAL(); # try load + dump the default UTM settings =cut @@ -96,10 +96,10 @@ sub setUTMLOCAL { Calcul de la latitude isométrique - $L = IGN0001(PHi,E); # $L = altitude isométrique (PHI = latitude, E = première excentricité de l'ellpsoide) + $L = IGN0001(PHi,E); # $L = altitude isométrique (PHI = latitude, E = première excentricité de l'ellpsoide) - References: - I.G.N., Projection cartographique Mercator Transverse: Algorithmes, Notes Techniques NT/G 76, janvier 1995. + References: + I.G.N., Projection cartographique Mercator Transverse: Algorithmes, Notes Techniques NT/G 76, janvier 1995. =cut @@ -183,7 +183,7 @@ sub ign0012 { # Jeu d'essai #$a = 6378249.2; $e = 0.08248325679; $x = 6376064.695; $y = 111294.623; $z = 128984.725; - my $EPS = 1e-11; # EPS = tolérance de convergence, en rad + my $EPS = 1e-11; # EPS = tolérance de convergence, en rad my $IMAX = 10; # Imax = nombre maximum d'itérations my $R = sqrt($x*$x + $y*$y); @@ -507,8 +507,8 @@ sub geo2utm { my ($F0,$K0,$P0,$L0,$X0,$Y0) = utmwgs($p1,$l1); # Définition des constantes - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement # Conversion des données $P0 /= $D0; @@ -552,10 +552,10 @@ sub geo2utml { # Définition des constantes my $D0 = 180/pi; - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement - my $A2 = $UTM{ELLIPSOID_LOCAL_SEMIMAJOR_AXIS}; # HAYFORD 1909 demi grand axe - my $F2 = 1/$UTM{ELLIPSOID_LOCAL_INVERSE_FLATTENING}; # HAYFORD 1909 aplatissement + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + my $A2 = $UTM{ELLIPSOID_LOCAL_SEMIMAJOR_AXIS}; # HAYFORD 1909 demi grand axe + my $F2 = 1/$UTM{ELLIPSOID_LOCAL_INVERSE_FLATTENING}; # HAYFORD 1909 aplatissement my ($F0,$K0,$P0,$L0,$X0,$Y0) = utm($p1,$l1); my $TX = $UTM{GEODETIC_LOCAL2WGS84_TRANSLATION_X}; # HAYFORD 1909 => WGS84 : Translation X (m) @@ -604,17 +604,17 @@ sub utmwgs { my $l1 = shift; my $D0 = 180/pi; - my $F0 = $UTM{UTM_ZONE}; # utm zone - my $K0 = $UTM{UTM_SCALE_FACTOR}; # scale factor (0.9996) + my $F0 = $UTM{UTM_ZONE}; # utm zone + my $K0 = $UTM{UTM_SCALE_FACTOR}; # scale factor (0.9996) if ($F0 le 0) { #$F0 = int(($l1 + 183)/6); $F0 = int(($l1 + 183)/6 + .5); } - my $L0 = (6*$F0 - 183)/$D0; # longitude origin (rad) - my $P0 = 0; # latitude origin (rad) / UTM20 = 0 - my $X0 = 500000; # false easting - my $Y0 = 0; # false northing + my $L0 = (6*$F0 - 183)/$D0; # longitude origin (rad) + my $P0 = 0; # latitude origin (rad) / UTM20 = 0 + my $X0 = 500000; # false easting + my $Y0 = 0; # false northing if ($p1 lt 0) { $Y0 = 10000000; } @@ -636,13 +636,13 @@ sub utm { my $D0 = 180/pi; - #my $F0 = int(($l1 + 183)/6); # UTM zone + #my $F0 = int(($l1 + 183)/6); # UTM zone my $F0 = int(($l1 + 183)/6 + .5); # UTM zone - my $K0 = $UTM{UTM_LOCAL_SCALE_FACTOR}; # scale factor - my $L0 = $UTM{UTM_LOCAL_MERIDIAN_ORIGIN}/$D0; # longitude origin (rad) - my $P0 = 0; # latitude origin (rad) / UTM20 = 0 - my $X0 = $UTM{UTM_LOCAL_FALSE_EASTING}; # false easting - my $Y0 = 0; # false northing + my $K0 = $UTM{UTM_LOCAL_SCALE_FACTOR}; # scale factor + my $L0 = $UTM{UTM_LOCAL_MERIDIAN_ORIGIN}/$D0; # longitude origin (rad) + my $P0 = 0; # latitude origin (rad) / UTM20 = 0 + my $X0 = $UTM{UTM_LOCAL_FALSE_EASTING}; # false easting + my $Y0 = 0; # false northing if ($p1 lt 0) { $Y0 = 10000000; } @@ -666,8 +666,8 @@ sub geo2cart { my $D0 = 180/pi; # Définition des constantes - my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe - my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement + my $A1 = $UTM{ELLIPSOID_WGS84_SEMIMAJOR_AXIS}; # WGS84 demi grand axe + my $F1 = 1/$UTM{ELLIPSOID_WGS84_INVERSE_FLATTENING}; # WGS84 aplatissement # Conversion des données my $B1 = $A1*(1 - $F1); @@ -683,11 +683,11 @@ sub geo2cart { =head2 greatcircle -# greatcircle(lat1,lon1,lat2,lon2) computes the distance (in km) between two -# geographic coordinates lat/lon (greatcircle Haversin formula). It returns -# also the bear angle (in °). +# greatcircle(lat1,lon1,lat2,lon2) computes the distance (in km) between two +# geographic coordinates lat/lon (greatcircle Haversin formula). It returns +# also the bear angle (in °). # -# Reference: modified from greatcircle.m by F. Beauducel, IPGP +# Reference: modified from greatcircle.m by F. Beauducel, IPGP =cut @@ -702,7 +702,7 @@ sub greatcircle { my $dlat = ($lat2 - $lat1)*$k; my $dlon = ($lon2 - $lon1)*$k; - my $rearth = 6371; # volumetric Earth radius (in km) + my $rearth = 6371; # volumetric Earth radius (in km) my $dist = $rearth*2*asin(sqrt(sin($dlat/2)**2 + cos($lat1*$k)*cos($lat2*$k)*sin($dlon/2)**2)); my $bear = atan2(sin($dlon)*cos($lat2*$k),cos($lat1*$k)*sin($lat2*$k) - sin($lat1*$k)*cos($lat2*$k)*cos($dlon))/$k; @@ -714,8 +714,8 @@ sub greatcircle { =head2 compass -# compass(azimuth) returns a short string indicating geographical orientation from azimuth in -# degrees from North, clockwise +# compass(azimuth) returns a short string indicating geographical orientation from azimuth in +# degrees from North, clockwise =cut @@ -731,8 +731,8 @@ sub compass { =head2 KMLfeed -# KMLfeed(URL) dowloads a KML string from URL and returns latitude, longitude, -# altitude, and timestamp. +# KMLfeed(URL) dowloads a KML string from URL and returns latitude, longitude, +# altitude, and timestamp. =cut diff --git a/CODE/perl/lib/Scheduler.pm b/CODE/perl/lib/Scheduler.pm index e324a9c1..14cf8847 100644 --- a/CODE/perl/lib/Scheduler.pm +++ b/CODE/perl/lib/Scheduler.pm @@ -9,8 +9,8 @@ scheduler process and submit it with commands. =head1 SYNOPSIS - use WebObs::Scheduler qw(scheduler_client); - my ($response, $error) = scheduler_client($opts{'msg'}, \%opts); + use WebObs::Scheduler qw(scheduler_client); + my ($response, $error) = scheduler_client($opts{'msg'}, \%opts); =head1 DESCRIPTION diff --git a/CODE/perl/lib/Search.pm b/CODE/perl/lib/Search.pm index d592c2f6..653ce0a1 100644 --- a/CODE/perl/lib/Search.pm +++ b/CODE/perl/lib/Search.pm @@ -180,4 +180,4 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . =cut - + diff --git a/CODE/perl/lib/Users.pm b/CODE/perl/lib/Users.pm index 282f3e38..8d6b52f3 100644 --- a/CODE/perl/lib/Users.pm +++ b/CODE/perl/lib/Users.pm @@ -10,8 +10,8 @@ Package WebObs : Common perl-cgi variables and functions use WebObs::Users - $someoneaddr = $USERS{someone}{EMAIL}; - if (clientHasEdit(name=>'HEBDO',type=>'authwikis')) {...} + $someoneaddr = $USERS{someone}{EMAIL}; + if (clientHasEdit(name=>'HEBDO',type=>'authwikis')) {...} =head1 DESCRIPTION @@ -161,8 +161,8 @@ sub allUsers { Gets the list of currently defined resources of a given type. Returns a reference to the list (or 0). - $pres = WebObs::Users::listRNames(type=>'authprocs'); - for (@$pres) { print "=>$_\n" }; # ie., all @$pres[] + $pres = WebObs::Users::listRNames(type=>'authprocs'); + for (@$pres) { print "=>$_\n" }; # ie., all @$pres[] =cut @@ -219,7 +219,7 @@ sub userName { Given a user 'login' (as defined in 'users' table),returns an array of all known user's groups: - @Group = userListGroup('juntel'); + @Group = userListGroup('juntel'); =cut @@ -256,8 +256,8 @@ sub userListGroup { Given a user 'login' (as defined in 'users' table),returns an Hash of arrays of all known user's authorizations: - %HoA = userListAuth('juntel'); - $HoA{resource-type} = array of all juntel's authorizations for resource-type + %HoA = userListAuth('juntel'); + $HoA{resource-type} = array of all juntel's authorizations for resource-type =cut @@ -294,15 +294,15 @@ sub userListAuth { =head2 userHasAuth - print "Yes" if (WebObs::Users::userHasAuth(user=>'juntel', type=>'authprocs', name=>'SISMOBUL',auth=>READAUTH); + print "Yes" if (WebObs::Users::userHasAuth(user=>'juntel', type=>'authprocs', name=>'SISMOBUL',auth=>READAUTH); returns true (1) if given 'user' login has given 'auth' access right to to resource-'type' named 'name'. - 'user' has 'xAUTH'-access to resource-type/resource-name when : - 1) resource-type has: user / resource-name / auth >= xAUTH - OR 2) resource-type has: user / * /auth >= xAUTH - OR 3) 'user' belongs to 'group' that verifies 1) OR 2) as above + 'user' has 'xAUTH'-access to resource-type/resource-name when : + 1) resource-type has: user / resource-name / auth >= xAUTH + OR 2) resource-type has: user / * /auth >= xAUTH + OR 3) 'user' belongs to 'group' that verifies 1) OR 2) as above =cut @@ -351,7 +351,7 @@ sub userHasAuth { returns maximum authorization granted to user on resource type / resource name in name - $max = WebObs::Users::userMaxAuth(user=>'juntel', type=>'authprocs', name=>"('res1','res2')"; + $max = WebObs::Users::userMaxAuth(user=>'juntel', type=>'authprocs', name=>"('res1','res2')"; =cut @@ -395,7 +395,7 @@ sub userMaxAuth { =head2 userIsValid - print "Yes" if (WebObs::Users::userIsValid(user=>'juntel'); + print "Yes" if (WebObs::Users::userIsValid(user=>'juntel'); returns true (1) if given 'user' login has a validity status 'Y' @@ -474,7 +474,7 @@ sub clientIsWO { Given a group ID 'GID' (starts with a '+'), returns an array of all associated user's UID: - @Users = groupListUser('+DUTY'); + @Users = groupListUser('+DUTY'); =cut @@ -512,8 +512,8 @@ Given a given resource-type and resource-name (as defined in 'users' table), returns an Hash of arrays of all UID or GID's for each authorization levels (1,2,4): - %HoA = WebObs::Users::resListAuth(type=>'authprocs',name=>'res1'); - $HoA{authlevel} = array of all UID/GID for authlevel + %HoA = WebObs::Users::resListAuth(type=>'authprocs',name=>'res1'); + $HoA{authlevel} = array of all UID/GID for authlevel =cut diff --git a/CODE/perl/lib/Utils.pm b/CODE/perl/lib/Utils.pm index 8d2453b5..29310f66 100644 --- a/CODE/perl/lib/Utils.pm +++ b/CODE/perl/lib/Utils.pm @@ -83,7 +83,7 @@ sub htmlspecialchars $txt =~ s//>/g; - # print "
            ".$txt."
            "; + # print "
            ".$txt."
            "; $txt =~ s/($re)/$1<\/b>/g if ($re ne ""); return $txt; } @@ -397,17 +397,17 @@ should be used to check CGI parameters security. Examples: - # Pass a scalar parameter: - my $param = checkParam($q->param('myparam'), qr/^[0-9A-Za-z_-]+i$/", "myparam"); + # Pass a scalar parameter: + my $param = checkParam($q->param('myparam'), qr/^[0-9A-Za-z_-]+i$/", "myparam"); - # This is actually the same as: - my $param = checkParam(scalar($q->param('myparam')), qr/^[0-9A-Za-z_-]+$/", "myparam"); + # This is actually the same as: + my $param = checkParam(scalar($q->param('myparam')), qr/^[0-9A-Za-z_-]+$/", "myparam"); - # A list of param should be passed by reference: - my $param = checkParam([$q->param('myparam')], qr/^[\w_-]+$/, "myparamlist"); + # A list of param should be passed by reference: + my $param = checkParam([$q->param('myparam')], qr/^[\w_-]+$/, "myparamlist"); - # The param name is only used in the error message and is optional - my $param = checkParam($q->param('myparam'), qr/^[0-9]*$/); + # The param name is only used in the error message and is optional + my $param = checkParam($q->param('myparam'), qr/^[0-9]*$/); Notes: @@ -421,9 +421,9 @@ parameter is allowed to be empty (in which you will usually provide a default value). In the following example, the default value "default" will never be set and an error will be raised if no value are provided for the CGI parameter 'myparam': - my $param = checkParam($q->param('myparam'), qr/^[0-9]+$/) // "default"; + my $param = checkParam($q->param('myparam'), qr/^[0-9]+$/) // "default"; Use this instead: - my $param = checkParam($q->param('myparam'), qr/^[0-9]*$/) // "default"; + my $param = checkParam($q->param('myparam'), qr/^[0-9]*$/) // "default"; =cut diff --git a/CODE/perl/lib/Wiki.pm b/CODE/perl/lib/Wiki.pm index 498e2247..df2d7c0c 100644 --- a/CODE/perl/lib/Wiki.pm +++ b/CODE/perl/lib/Wiki.pm @@ -44,12 +44,12 @@ Note that WebObs::Wiki uses the special 'WebObs:' metadata (whose value has curr - metadata section follow the syntax as described in http://fletcher.github.io/MultiMarkdown-4/metadata.html , with these special considerations: - - keys are case sensitive - - keys are NOT 'compressed', ie. embedded blanks are preserved in keys - - must contain one 'WebObs:' key , otherwise input will be considered has NOT having metadata - - WO's specific 'TITRE.*|xxx' optional as very first line of $txt is stripped off (ie. - ignored, so that MMD parsing/markup is allowed after a TITRE*| ) - - non 'key:value' lines preceeding a valid metadata section will be discarded + - keys are case sensitive + - keys are NOT 'compressed', ie. embedded blanks are preserved in keys + - must contain one 'WebObs:' key , otherwise input will be considered has NOT having metadata + - WO's specific 'TITRE.*|xxx' optional as very first line of $txt is stripped off (ie. + ignored, so that MMD parsing/markup is allowed after a TITRE*| ) + - non 'key:value' lines preceeding a valid metadata section will be discarded - WebObs extra line containing the special tags TITRE and TITRE_HTML (always 1st line) are still recognized, even for MMD files: WebObs::Wiki ignores it; any associated processing must be handled outside of Wiki processing. @@ -182,14 +182,14 @@ sub wiki { $txt =~ s/<__row__>/            /g; # take care of leftover temporary rows # --- - ==>
              - $txt =~ s/^-/\n-/; # to find start of list - $txt =~ s/([^\n]$)/$1\n/; # to find end of list + $txt =~ s/^-/\n-/; # to find start of list + $txt =~ s/([^\n]$)/$1\n/; # to find end of list $txt =~ s/\n-((?:.|\n)+?)\n([^-]|$)/\n
              • $1<\/UL>$2/g; $txt =~ s/\n-/
              • /g; # --- # ==>
                  - $txt =~ s/^#/\n#/; # to find start of list - $txt =~ s/([^\n]$)/$1\n/; # to find end of list + $txt =~ s/^#/\n#/; # to find start of list + $txt =~ s/([^\n]$)/$1\n/; # to find end of list $txt =~ s/\n#((?:.|\n)+?)\n([^#]|$)/\n
                  1. $1<\/OL>$2/g; $txt =~ s/\n#/
                  2. /g; @@ -240,9 +240,9 @@ sub wiki { $txt =~ s/\*\*(.*?)\*\*/$1<\/B>/g; # --- //italic// ==> italic - $txt =~ s/(http|https|ftp|file):\/\//$1:_DoubleSlash_/g; # temporary substitution of URLs //... + $txt =~ s/(http|https|ftp|file):\/\//$1:_DoubleSlash_/g; # temporary substitution of URLs //... $txt =~ s/\/\/(.*?)\/\//$1<\/I>/g; - $txt =~ s/_DoubleSlash_/\/\//g; # backup of // ... + $txt =~ s/_DoubleSlash_/\/\//g; # backup of // ... # --- __underscore__ ==> underscore $txt =~ s/__(.*?)__/$1<\/U>/g; @@ -346,10 +346,10 @@ sub wiki2MMD { # --- automatic links to WEBOBS configuration files # --- if not immediately preceeded with a /, some filename-like strings will generate an href -# $txt =~ s/\b(?$1<\/A>/g; -# $txt =~ s/\b(?$1<\/A>/g; -# $txt =~ s/\b(?$1<\/A>/g; -# $txt =~ s/\b(?$1<\/A>/g; +# $txt =~ s/\b(?$1<\/A>/g; +# $txt =~ s/\b(?$1<\/A>/g; +# $txt =~ s/\b(?$1<\/A>/g; +# $txt =~ s/\b(?$1<\/A>/g; # --- + ==> not useful anymore $txt =~ s/\n\+/\n/g; diff --git a/CODE/perl/navrc2html.pl b/CODE/perl/navrc2html.pl index 5b2abf61..8842c926 100755 --- a/CODE/perl/navrc2html.pl +++ b/CODE/perl/navrc2html.pl @@ -14,8 +14,8 @@ next if(/^[ ]*#/ || /^$/); my ($titre,$lien)=split(/\|/,$_); - # $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; - # my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; + # $lien =~ s/[\$]WEBOBS[\{](.*?)[\}]/$WEBOBS{$1}/g ; + # my $xtrn = ($lien =~ m/http.?:\/\//) ? " externe ": ""; if (substr($titre,0,1) eq "+" || substr($titre,0,1) eq "!") { if ($l2==1) { print "
                \n"; $l2 = 0; } if ($l1==1) { print "\n"; } diff --git a/CODE/perl/postboard.pl b/CODE/perl/postboard.pl index 6b168663..1b6710fe 100755 --- a/CODE/perl/postboard.pl +++ b/CODE/perl/postboard.pl @@ -53,29 +53,29 @@ =head1 EMAIL B syntax is B<[text][keyword=value[keyword=value...]]> where: - 1) text is any string you want to be embedded in the mail contents - blanks are allowed - | (pipes) , \n , are forbidden. - it is optional and stops when a keyword= string is encountered (see below) or end of string + 1) text is any string you want to be embedded in the mail contents + blanks are allowed + | (pipes) , \n , are forbidden. + it is optional and stops when a keyword= string is encountered (see below) or end of string - 2) available optional keywords in B for any event-name: - uid= a_webobs_uid_or_gid : redefines (ie. overrides), if it is valid, the addressee's uid (or gid) - file= an_absolute_filename> : includes the contents of filename in the mail + 2) available optional keywords in B for any event-name: + uid= a_webobs_uid_or_gid : redefines (ie. overrides), if it is valid, the addressee's uid (or gid) + file= an_absolute_filename> : includes the contents of filename in the mail - 3) available optional keywords in B for the 'submitrc.jid' event-name (only used by the WebObs scheduler, - but listed here for reference as you MUST avoid using them in your own text string): - org= , log= , cmd= , rc= + 3) available optional keywords in B for the 'submitrc.jid' event-name (only used by the WebObs scheduler, + but listed here for reference as you MUST avoid using them in your own text string): + org= , log= , cmd= , rc= Example: perl script notifying an occurence of 'myevent', defined in 'notification' table as myevent,Y,UID,mysubject,-,- : - WebObs::Config::notify("myevent|dummy|my message with a file file=/opt/webobs/OUTR/requestid/mail.msg"); - will result in the following email: - From: webobs@webobsaddr - To: UID-mailaddr - Subject: [WEBOBS_ID] mysubject - User-Agent: Mutt/1.x.xx (2000-01-01) - my message with a file - + WebObs::Config::notify("myevent|dummy|my message with a file file=/opt/webobs/OUTR/requestid/mail.msg"); + will result in the following email: + From: webobs@webobsaddr + To: UID-mailaddr + Subject: [WEBOBS_ID] mysubject + User-Agent: Mutt/1.x.xx (2000-01-01) + my message with a file + =head1 ACTION @@ -86,9 +86,9 @@ =head1 ACTION =head1 EVENTS NAMING CONVENTIONS - event-name = string[.[string]] - string = any alphanumeric string with no blank and no .,*?!/\(){};+ - string.string = aka 'majorname.minorname' form of event-name + event-name = string[.[string]] + string = any alphanumeric string with no blank and no .,*?!/\(){};+ + string.string = aka 'majorname.minorname' form of event-name 'majorname.minorname' is used to define specific actions for each 'majorname.minorname' events AND also common actions applying to all of them using B event (don't forget the ending dot!). @@ -100,7 +100,7 @@ =head1 SUBMITRC. SPECIAL EVENT 1) the WebObs Scheduler automatically emits a B when job B ends: - notify("submitrc.jid|$$|org={S|R} rc={returncode} log={jid-std-logpath} uid={$CLIENTuid}") + notify("submitrc.jid|$$|org={S|R} rc={returncode} log={jid-std-logpath} uid={$CLIENTuid}") 2) you control the B email activation along with its default addressee with specific and/or global definitions of respectively B and/or B in the @@ -113,15 +113,15 @@ =head1 SUBMITRC. SPECIAL EVENT 4) Example: a submit "job-definition-string" command sent to the scheduler (see scheduler.pl doc) and the corresponding mail sent: - $ scheduler submit 'XEQ1:perl,XEQ2:/path/to/jobtst.pl,RES:mylock,LOGPATH:/var/log/webobs/jobtst,UID:DL' - will built/sent the following email: - From: scheduleruid@webobsaddr - To: DL-mailaddr - Subject: [WebObs-WEBOBS_ID] request -8 has ended - User-Agent: Mutt/1.x.xx (2000-01-01) - Job = perl /path/to/jobtst.pl - Ended with rc=0 - Log = /var/log/webobs/jobtst + $ scheduler submit 'XEQ1:perl,XEQ2:/path/to/jobtst.pl,RES:mylock,LOGPATH:/var/log/webobs/jobtst,UID:DL' + will built/sent the following email: + From: scheduleruid@webobsaddr + To: DL-mailaddr + Subject: [WebObs-WEBOBS_ID] request -8 has ended + User-Agent: Mutt/1.x.xx (2000-01-01) + Job = perl /path/to/jobtst.pl + Ended with rc=0 + Log = /var/log/webobs/jobtst =head1 NOTES diff --git a/CODE/perl/scheduler.pl b/CODE/perl/scheduler.pl index 89cb0a57..fe0d5d85 100755 --- a/CODE/perl/scheduler.pl +++ b/CODE/perl/scheduler.pl @@ -66,28 +66,28 @@ =head2 CONFIGURATION PARAMETERS Changes to the configuration file are NOT dynamically read/used by the running scheduler; scheduler.pl MUST be stopped/started to load new configuration values. - # CONF_SCHEDULER|${ROOT_CONF}/scheduler.rc # in WEBOBS.rc - - # scheduler.rc example configuration file - # - =key|value # readCfg() specification - BEAT|2 # find/start jobs each BEAT seconds - MAX_CHILDREN|10 # maximum simultaneous jobs running - LISTEN_ADDR|localhost # client-command interface address - PORT|7761 # client-command UDP port number - SOCKET_MAXLEN|1500; # client-command max msg length - SQL_DB_JOBS|$WEBOBS{ROOT_CONF}/WEBOBSJOBS.db # sqlite DataBase name for JOBS table - LOADAVG1_THRESHOLD|0.7 # 1' max system load averages - LOADAVG5_THRESHOLD|0.7 # 5' = - LOADAVG15_THRESHOLD|0.7 #15' = - PATH_STD|$WEBOBS{ROOT_CONF}/jobslogs # root directory for all jobs STDOUT/ERR - PATH_RES|$WEBOBS{ROOT_CONF}/res # root directory for jobs resources (==ENQ ==LOCKS) - DITTO_LOG_MAX|500 # how many occurences of a msg to log before forcing a write - DITTO_NTF_MAX|1000 # how many occurences of a msg to notify before forcing a notify - CANCEL_SUBMIT|3600 # how long (seconds) a submited job can be waiting in JOBQ - DAYS_IN_RUN|30 # number of days that jobs stay in runs table - LMISS_BIAS|10 # number of seconds to delay candidates not run because of load-threshold - EMISS_BIAS|4 # number of seconds to delay candidates not run because of enq busy + # CONF_SCHEDULER|${ROOT_CONF}/scheduler.rc # in WEBOBS.rc + + # scheduler.rc example configuration file + # + =key|value # readCfg() specification + BEAT|2 # find/start jobs each BEAT seconds + MAX_CHILDREN|10 # maximum simultaneous jobs running + LISTEN_ADDR|localhost # client-command interface address + PORT|7761 # client-command UDP port number + SOCKET_MAXLEN|1500; # client-command max msg length + SQL_DB_JOBS|$WEBOBS{ROOT_CONF}/WEBOBSJOBS.db # sqlite DataBase name for JOBS table + LOADAVG1_THRESHOLD|0.7 # 1' max system load averages + LOADAVG5_THRESHOLD|0.7 # 5' = + LOADAVG15_THRESHOLD|0.7 #15' = + PATH_STD|$WEBOBS{ROOT_CONF}/jobslogs # root directory for all jobs STDOUT/ERR + PATH_RES|$WEBOBS{ROOT_CONF}/res # root directory for jobs resources (==ENQ ==LOCKS) + DITTO_LOG_MAX|500 # how many occurences of a msg to log before forcing a write + DITTO_NTF_MAX|1000 # how many occurences of a msg to notify before forcing a notify + CANCEL_SUBMIT|3600 # how long (seconds) a submited job can be waiting in JOBQ + DAYS_IN_RUN|30 # number of days that jobs stay in runs table + LMISS_BIAS|10 # number of seconds to delay candidates not run because of load-threshold + EMISS_BIAS|4 # number of seconds to delay candidates not run because of enq busy =head2 JOBS DATABASE @@ -96,15 +96,15 @@ =head2 JOBS DATABASE the 'PROGRAM LIST' passed to 'exec' for job's execution (see 'exec' syntax in perldoc). Each row of B is a single job definition consisting of the following columns/information: - JID char, unique jobid (length <= 20 chars, no blanks allowed), - VALIDITY char, Y|N : wether this definition is currently valid (Y), ie. processed or ignored - XEQ1 text, 1st element of 'exec' - XEQ2 text, 2nd element of 'exec' - XEQ3 text, 3rd element of 'exec' - RUNINTERVAL int, how many seconds between two runs of the job - MAXSYSLOAD real, system load 5'-average above which the job shouldn't be executed - LOGPATH text, subdirectory of scheduler's PATH_STD to store job's STDOUT & STDERR - LASTSTRTS real, timestamp when last run was started + JID char, unique jobid (length <= 20 chars, no blanks allowed), + VALIDITY char, Y|N : wether this definition is currently valid (Y), ie. processed or ignored + XEQ1 text, 1st element of 'exec' + XEQ2 text, 2nd element of 'exec' + XEQ3 text, 3rd element of 'exec' + RUNINTERVAL int, how many seconds between two runs of the job + MAXSYSLOAD real, system load 5'-average above which the job shouldn't be executed + LOGPATH text, subdirectory of scheduler's PATH_STD to store job's STDOUT & STDERR + LASTSTRTS real, timestamp when last run was started XEQ1, XEQ2 and XEQ3 can reference variables from WEBOBS.rc configuration. Such a reference is coded $WEBOBS{key} (eg. $WEBOBS{MYXEQ1S}/matlab p1 p2). @@ -112,15 +112,15 @@ =head2 JOBS DATABASE Executing and executed jobs (aka 'runs') are kept in the summary/history B table. Each row of B reflects one (1) execution of a job (identified by it's JID and KID) : - JID int, unique jobid (see table B) - KID int, linux process id forked by scheduler - ORG text, 'S' selected by Scheduler, 'R' selected on [user's] Request - STARTTS int, time this run was started - ENDTS int, time this run has ended - CMD text, executed command - STDPATH text, location of this run's stdout and stderr - RC int, return code of this run - RCMSG text, text return code + JID int, unique jobid (see table B) + KID int, linux process id forked by scheduler + ORG text, 'S' selected by Scheduler, 'R' selected on [user's] Request + STARTTS int, time this run was started + ENDTS int, time this run has ended + CMD text, executed command + STDPATH text, location of this run's stdout and stderr + RC int, return code of this run + RCMSG text, text return code =head2 COMMANDS @@ -149,12 +149,12 @@ =head2 COMMANDS 2) a B is a comma-separated list of jobdef's I ("keyword1:value,....,keywordN:value"), where allowed keywords are: - XEQ1:, XEQ2:, XEQ3: (same as jobs table columns) - LOGPATH:, RES:, MAXSYSLOAD: (same as jobs table columns) - UID: (submitter uid to be used for end of job notification) + XEQ1:, XEQ2:, XEQ3: (same as jobs table columns) + LOGPATH:, RES:, MAXSYSLOAD: (same as jobs table columns) + UID: (submitter uid to be used for end of job notification) - Example: - $ scheduler submit 'XEQ1:perl,XEQ2:/path/to/jobtst.pl,RES:mylock,UID:DL' + Example: + $ scheduler submit 'XEQ1:perl,XEQ2:/path/to/jobtst.pl,RES:mylock,UID:DL' Each time a job-definition-string is submitted, the job will automatically be assigned a unique numeric negative jid, for reporting/database identification purposes. @@ -212,37 +212,37 @@ =head2 JOBS OUTPUTS any subdirectories defined in the path will be dynamically created if needed, and pid is the job's pid. - name PATH_STD/name.std{out,err} - name/ PATH_STD/name/pid.std{out,err} - name/name/out PATH_STD/name/name/name/out.std{out,err} - PATH_STD/pid.std{out,err} + name PATH_STD/name.std{out,err} + name/ PATH_STD/name/pid.std{out,err} + name/name/out PATH_STD/name/name/name/out.std{out,err} + PATH_STD/pid.std{out,err} The following two rules apply to any one of the above syntaxes: - >name overwrite previous file with same name - >>name append to previous file with same name + >name overwrite previous file with same name + >>name append to previous file with same name The following B are also available in the name(s) you supply for easier specification of unique log files: - {TS} replaced with job's start-timestamp - {RTNE} replaced with job's XEQ2 string, with any blanks (spaces) chars - changed to '_' underscores. + {TS} replaced with job's start-timestamp + {RTNE} replaced with job's XEQ2 string, with any blanks (spaces) chars + changed to '_' underscores. =head2 NOTIFICATIONS The scheduler currently send the following B to the WebObs B system Following is the list of "event-name => situation" of these notifications: - scheduler.critical => system loadavg thresholds have been reached, before selecting candidates jobs - scheduler.critical => maximum # of process kids already running, before selecting candidates jobs - scheduler.critical => couldn't fork for executing a job - scheduler.warning => a job is candidate, but already in the runQ and its maxintances don't allow - scheduler.warning => a job is candidate, but its maxsysload has been reached - scheduler.critical => scheduler has been stopped from a 'STOP' command - scheduler.critical => scheduler has been killed (sigint received) - submitrc. => jid has ended (see postboard.pl documentation) + scheduler.critical => system loadavg thresholds have been reached, before selecting candidates jobs + scheduler.critical => maximum # of process kids already running, before selecting candidates jobs + scheduler.critical => couldn't fork for executing a job + scheduler.warning => a job is candidate, but already in the runQ and its maxintances don't allow + scheduler.warning => a job is candidate, but its maxsysload has been reached + scheduler.critical => scheduler has been stopped from a 'STOP' command + scheduler.critical => scheduler has been killed (sigint received) + submitrc. => jid has ended (see postboard.pl documentation) =head2 VERBOSITY @@ -251,26 +251,26 @@ =head2 VERBOSITY messages logged, ignoring verbosity setting: - - received commands - - failed to fork a kid, failed to exec a kid - - main loop drift > tick interval - - maximum number of kids executing - - locked job's resource - - loadavg above job's threshold - - all messages during the stop sequence + - received commands + - failed to fork a kid, failed to exec a kid + - main loop drift > tick interval + - maximum number of kids executing + - locked job's resource + - loadavg above job's threshold + - all messages during the stop sequence messages logged when verbosity on (-v or verbose cmd) - - forked kids detailed info - - reaper details - - system's sysload warnings - - enq and deq job's resources + - forked kids detailed info + - reaper details + - system's sysload warnings + - enq and deq job's resources messages logged when verbosity level 2 on (-V) - - RUNQ status at each beat - - CANDIDATES list at each beat - - paused status and adjust-loop on each beat + - RUNQ status at each beat + - CANDIDATES list at each beat + - paused status and adjust-loop on each beat =head2 SCHEDULER EXIT @@ -353,21 +353,21 @@ BEGIN # ----------------------------------------------------------------------------- our $STRT = time; # when I was started our $STRTTS = strftime("%Y-%m-%d %H:%M:%S (UTC%z)",localtime($STRT)); # when I was started -our $PID = $$; # my own pid (parent of all running kids) +our $PID = $$; # my own pid (parent of all running kids) our $PUID= (getpwuid($<))[0]; # who am I after all -our $PAUSED = 0; # tick but don't schedule anything if PAUSED -our %kids; # 'running' kids hash: $kids{kid_pid} = internal kid_id -our $kidcmd; # command to be executed by currently forked kid -our $rid = 0; # a run id -our $dcd = 0; # ended kid_pid in the REAPER's waitpid loop -our $utick = 1000000; # base tick (microseconds) -our $adjutick = $utick; # utick adjusted for drift -our %CANDIDATES; # jobs, candidates for this 'tick' from DB and Q -our %RUNQ; # jobs, running () -our %JOBRQ; # queued jobs requests (from udp submits) -our @CMDRQ; # queued cmds from udp client -our $JSTARTED=0; # number of jobs started so far, for this scheduler's session -our $JENDED=0; # number of jobs ended so far, for this scheduler's session +our $PAUSED = 0; # tick but don't schedule anything if PAUSED +our %kids; # 'running' kids hash: $kids{kid_pid} = internal kid_id +our $kidcmd; # command to be executed by currently forked kid +our $rid = 0; # a run id +our $dcd = 0; # ended kid_pid in the REAPER's waitpid loop +our $utick = 1000000; # base tick (microseconds) +our $adjutick = $utick; # utick adjusted for drift +our %CANDIDATES; # jobs, candidates for this 'tick' from DB and Q +our %RUNQ; # jobs, running () +our %JOBRQ; # queued jobs requests (from udp submits) +our @CMDRQ; # queued cmds from udp client +our $JSTARTED=0; # number of jobs started so far, for this scheduler's session +our $JENDED=0; # number of jobs ended so far, for this scheduler's session our $CFGF=''; # active configuration filename our %SCHED; # active configuration our $lldate = ''; # date of last record written to log diff --git a/CODE/perl/woc.pl b/CODE/perl/woc.pl index 9cf688ec..6e85b4b8 100755 --- a/CODE/perl/woc.pl +++ b/CODE/perl/woc.pl @@ -87,8 +87,8 @@ =head1 DESCRIPTION 'dbruns' => {'rtne' => \&dbruns, 'seq' => 200, 'auth' => 'A' ,'help' => 'dbruns : list all jobs last run info' }, 'sys' => {'rtne' => \&sys, 'seq' => 300, 'auth' => 'R' ,'help' => 'sys : print system information' }, -# '!' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '! cmd : exec shell cmd (WebObs vars single-quoted for interpolation)' }, -# '=' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '= expr : exec perl expr (interactive mode only)' }, +# '!' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '! cmd : exec shell cmd (WebObs vars single-quoted for interpolation)' }, +# '=' => {'rtne' => \&xsys, 'seq' => 310, 'auth' => 'A' ,'help' => '= expr : exec perl expr (interactive mode only)' }, 'dd' => {'rtne' => \&dd, 'seq' => 320, 'auth' => 'A' ,'help' => 'dd : keys of main hashes and their occurence' }, 'ddxref' => {'rtne' => \&ddx, 'seq' => 321, 'auth' => 'A' ,'help' => 'ddxref : keys of main hashes + their occurence + xref' }, 'help' => {'rtne' => \&dhelp, 'seq' => 400, 'auth' => 'R' ,'help' => 'help : this help text !' }, @@ -745,8 +745,8 @@ sub ddev { } #if ( $lienNode{$carFileName} ne "" ) { - # $lienNode{$carFileName} .= "\n\n"; - #} + # $lienNode{$carFileName} .= "\n\n"; + #} $lien_car = 1; } printf (" %s %s $NODES{FILE_NODES2NODES} , %s\n",$carFileName,($lien_car==1)?"in ":"not in" ,(-e $carFile)?"has $carFile":"has no txt file"); @@ -809,12 +809,12 @@ sub ddx { print Dumper \%keysWO; ddxrevcore(\%keysWO, "webobs"); - # print"\n**************************************************************\n"; - # print"* xrefs might NOT be comprehensive lists. They are built *\n"; - # print"* using naming/coding conventions & also scan comments. *\n"; - # print"* cgi: 'key' looked for in {key} or {'key'} case insensitive.*\n"; - # print"* mat: 'key' looked for in xx.key, xx 1 or 2 uppercase alpha.*\n"; - # print"**************************************************************\n"; + # print"\n**************************************************************\n"; + # print"* xrefs might NOT be comprehensive lists. They are built *\n"; + # print"* using naming/coding conventions & also scan comments. *\n"; + # print"* cgi: 'key' looked for in {key} or {'key'} case insensitive.*\n"; + # print"* mat: 'key' looked for in xx.key, xx 1 or 2 uppercase alpha.*\n"; + # print"**************************************************************\n"; } # woc internal helpers functions for dd* commands @@ -1037,44 +1037,44 @@ =head1 COMMANDS dump %WEBOBS key or all keys - [key] is a regular expression. - %WEBOBS POSTB - [[ %WEBOBS from /etc/webobs.d/WEBOBS.conf (1371052936) + /etc/webobs.d/WEBOBS.rc (1371114257) ]] - $WEBOBS{POSTBOARD_MAILER} => mutt - $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT} => test - $WEBOBS{POSTBOARD_MAILER_OPTS} => -nx - $WEBOBS{POSTBOARD_NPIPE} => /tmp/WEBOBSNP - $WEBOBS{SQL_DB_POSTBOARD} => /data1/webobs/CONF/WEBOBSUSERS.db + %WEBOBS POSTB + [[ %WEBOBS from /etc/webobs.d/WEBOBS.conf (1371052936) + /etc/webobs.d/WEBOBS.rc (1371114257) ]] + $WEBOBS{POSTBOARD_MAILER} => mutt + $WEBOBS{POSTBOARD_MAILER_DEFSUBJECT} => test + $WEBOBS{POSTBOARD_MAILER_OPTS} => -nx + $WEBOBS{POSTBOARD_NPIPE} => /tmp/WEBOBSNP + $WEBOBS{SQL_DB_POSTBOARD} => /data1/webobs/CONF/WEBOBSUSERS.db =item B<-%WEBOBS value> which %WEBOBS key(s) holds value - value is a regular expression - -%WEBOBS WEBOBSUSERS - [[ %WEBOBS from /etc/webobs.d/WEBOBS.conf (1371052936) + /etc/webobs.d/WEBOBS.rc (1371114257) ]] - $WEBOBS{SQL_DB_POSTBOARD} => /data1/webobs/CONF/WEBOBSUSERS.db - $WEBOBS{SQL_DB_USERS} => /data1/webobs/CONF/WEBOBSUSERS.db + -%WEBOBS WEBOBSUSERS + [[ %WEBOBS from /etc/webobs.d/WEBOBS.conf (1371052936) + /etc/webobs.d/WEBOBS.rc (1371114257) ]] + $WEBOBS{SQL_DB_POSTBOARD} => /data1/webobs/CONF/WEBOBSUSERS.db + $WEBOBS{SQL_DB_USERS} => /data1/webobs/CONF/WEBOBSUSERS.db =item B<%OWNERS> dump all %OWNRS hash - %OWNERS - $OWNRS{B} => MVO - $OWNRS{M} => OVSM - $OWNRS{R} => OVPF - $OWNRS{I} => IPGP + %OWNERS + $OWNRS{B} => MVO + $OWNRS{M} => OVSM + $OWNRS{R} => OVPF + $OWNRS{I} => IPGP =item B<%USERS [login]> dump %USERS entry for login or all - %USERS webobs - [[ %USERS DB /data1/webobs/CONF/WEBOBSUSERS.db (1371053050) TABLE users ]] - $USERS{webobs} => HASH(0x866eae0) - UID ==> ! - FULLNAME ==> WebObs Owner - EMAIL ==> webhost@somewhere.org - LOGIN ==> webobs + %USERS webobs + [[ %USERS DB /data1/webobs/CONF/WEBOBSUSERS.db (1371053050) TABLE users ]] + $USERS{webobs} => HASH(0x866eae0) + UID ==> ! + FULLNAME ==> WebObs Owner + EMAIL ==> webhost@somewhere.org + LOGIN ==> webobs =item B @@ -1082,134 +1082,134 @@ =head1 COMMANDS all possible resources as used by WebObs programs, but ONLY those currently defined (active) in the database. - authres - authprocs / HEBDO - authprocs / HEBDOTout - ... + authres + authprocs / HEBDO + authprocs / HEBDOTout + ... =item B query USERS database for login , ie. user definition + its current authorizations + its user-group(s) - dbuser webobs - !,WebObs Owner,webobs,webobs@somewhere.org - authprocs: - ! * 4 - authviews: - ! * 4 - .... - groups : - +BASE ! + dbuser webobs + !,WebObs Owner,webobs,webobs@somewhere.org + authprocs: + ! * 4 + authviews: + ! * 4 + .... + groups : + +BASE ! =item B add (define) a new user - newuser - enter new row as: 'UID','FULLNAME','LOGIN','EMAIL' - > 'JD','John Doe','jdoe','john.doe@somewhere.org' - = insert into users values('JD','John Doe','jdoe','john.doe@somewhere.org') - Y/N ? Y + newuser + enter new row as: 'UID','FULLNAME','LOGIN','EMAIL' + > 'JD','John Doe','jdoe','john.doe@somewhere.org' + = insert into users values('JD','John Doe','jdoe','john.doe@somewhere.org') + Y/N ? Y =item B delete a user - deluser jdoe - = delete from users where login = jdoe - Y/N ? Y + deluser jdoe + = delete from users where login = jdoe + Y/N ? Y =item B add (define) a new user's group - newgroup - enter new row as: 'GID',UID - > 'myowngroup','DL' - = insert into groups values('myowngroup','DL') - Y/N ? Y + newgroup + enter new row as: 'GID',UID + > 'myowngroup','DL' + = insert into groups values('myowngroup','DL') + Y/N ? Y =item B delete a user's group - delgroup group - = delete from group where gid = group - Y/N ? Y + delgroup group + = delete from group where gid = group + Y/N ? Y =item B define an access record into the 'auth' authorization table, ie. grant Read or Edit or Adm authorization to a userid for a resourceName of the resourceType 'auth'. - grant authprocs - enter new row as: 'UID','RESOURCE',AUTH - > 'JD','SOURCES',4 - = insert into authprocs values('JD','SOURCES',4) - Y/N ? Y + grant authprocs + enter new row as: 'UID','RESOURCE',AUTH + > 'JD','SOURCES',4 + = insert into authprocs values('JD','SOURCES',4) + Y/N ? Y =item B another way to look at authorizations granted to 'login' user. - auth webobs - authprocs => - * 4 - authviews => - * 4 - authmisc => - * 4 - authforms => - * 4 - authwikis => - * 4 + auth webobs + authprocs => + * 4 + authviews => + * 4 + authmisc => + * 4 + authforms => + * 4 + authwikis => + * 4 =item B<%NODES [key]> dump %NODES key or all keys - [key] is a regular expression - %NODES - $NODES{SPATH_SCHEMES} => SCHEMAS - $NODES{FILE_NODES2NODES} => /data1/webobs/CONF/nodes2nodes.rc - $NODES{CGI_FORM} => formNODE.pl - ..... - $NODES{SPATH_DOCUMENTS} => DOCUMENTS + %NODES + $NODES{SPATH_SCHEMES} => SCHEMAS + $NODES{FILE_NODES2NODES} => /data1/webobs/CONF/nodes2nodes.rc + $NODES{CGI_FORM} => formNODE.pl + ..... + $NODES{SPATH_DOCUMENTS} => DOCUMENTS =item B dump a PROC proc or list all PROCs - proc - SOURCES - CGPSWI + proc + SOURCES + CGPSWI - proc SO - SOURCES - ddb ==> CGI_AFFICHE_EAUX - net ==> 304 - THUMBNAIL ==> 1 - .... - FORM ==> EAUX + proc SO + SOURCES + ddb ==> CGI_AFFICHE_EAUX + net ==> 304 + THUMBNAIL ==> 1 + .... + FORM ==> EAUX =item B
                dump a FORM form or list all FORMS. Form is dump using the Form object's dump method (ie. my $F = new WebObs::Form($_[0]); print $F->dump; ) - form EAUX - Form EAUX - Form configuration path: /data1/woz/CONF/FORMS/EAUX - FILE_NAME => EAUX.DAT - BANG => 1797 - FILE_TYPE => typeSitesEaux.conf - TITLE => Databank of waters chemical analysis - CGI_POST => postEAUX.pl - CGI_SHOW => showEAUX.pl - CGI_FORM => formEAUX.pl - FILE_RAPPORTS => rapportsEaux.conf - FILE_CSV_PREFIX => OVSG_EAUX - Form data file is: /data1/woz/DATA/DB/EAUX.DAT - Related proc(s): SOURCES(Soufrière Hot Springs Analysis) + form EAUX + Form EAUX + Form configuration path: /data1/woz/CONF/FORMS/EAUX + FILE_NAME => EAUX.DAT + BANG => 1797 + FILE_TYPE => typeSitesEaux.conf + TITLE => Databank of waters chemical analysis + CGI_POST => postEAUX.pl + CGI_SHOW => showEAUX.pl + CGI_FORM => formEAUX.pl + FILE_RAPPORTS => rapportsEaux.conf + FILE_CSV_PREFIX => OVSG_EAUX + Form data file is: /data1/woz/DATA/DB/EAUX.DAT + Related proc(s): SOURCES(Soufrière Hot Springs Analysis) =item B @@ -1219,18 +1219,18 @@ =head1 COMMANDS dump a NODE node or list all NODES names - node - GCSBJN1 WDCBIM0 WDCMPOM WDCDHS0 WDCTDB0 WDCABD0 WDCDSD0 WDCCBE0 - DJLTEST JTATEST WDCILAM GCSBCM1 WDCMGL0 + node + GCSBJN1 WDCBIM0 WDCMPOM WDCDHS0 WDCTDB0 WDCABD0 WDCDSD0 WDCCBE0 + DJLTEST JTATEST WDCILAM GCSBCM1 WDCMGL0 =item B list all GRIDS referenced by a NODE node, or all GRIDS of all NODES - nodegrids GCSBCM1 - GCSBCM1 : - PROC.SOURCES - VIEW.SOURCES + nodegrids GCSBCM1 + GCSBCM1 : + PROC.SOURCES + VIEW.SOURCES =item B @@ -1240,12 +1240,12 @@ =head1 COMMANDS statistics on node+grids - statnodes - 13 node directories - 2 nodes have no grid - DJLTEST JTATEST - 0 node has no proc - 0 node has no view + statnodes + 13 node directories + 2 nodes have no grid + DJLTEST JTATEST + 0 node has no proc + 0 node has no view =item B @@ -1262,41 +1262,41 @@ =head1 COMMANDS dump file using readCfg. Well-known WebObs hash (such as %WEBOBS, %USERS,...) keys may be used in place of 'file'. Example: - %WEBOBS HEBDO - [[ %WEBOBS from /etc/webobs.d/WEBOBS.conf (1381419055) + /etc/webobs.d/WEBOBS.rc (1381471427) ]] - $WEBOBS{HEBDO_CONF} => /data1/woz/CONF/HEBDO.conf - - readcfg $WEBOBS{HEBDO_CONF} - /data1/woz/CONF/HEBDO.conf - $VAR1 = { - 'FILE_NAME' => '/data1/woz/DATA/DB/HEBDO.DAT', - 'BANG' => '2001', - 'FILE_TYPE_EVENEMENTS' => '/data1/woz/CONF/HEBDOtypes.conf', - 'CGI_FORM' => 'formHEBDO.pl', - 'DEFAULT_TRI' => 'Calendar', - 'DEFAULT_DATE' => 'semaineCourante', - 'TITLE' => 'Hebdo', - 'CGI_POST' => 'postHEBDO.pl', - 'CGI_SHOW' => 'showHEBDO.pl', - 'DEFAULT_TYPE' => 'Tout' - }; + %WEBOBS HEBDO + [[ %WEBOBS from /etc/webobs.d/WEBOBS.conf (1381419055) + /etc/webobs.d/WEBOBS.rc (1381471427) ]] + $WEBOBS{HEBDO_CONF} => /data1/woz/CONF/HEBDO.conf + + readcfg $WEBOBS{HEBDO_CONF} + /data1/woz/CONF/HEBDO.conf + $VAR1 = { + 'FILE_NAME' => '/data1/woz/DATA/DB/HEBDO.DAT', + 'BANG' => '2001', + 'FILE_TYPE_EVENEMENTS' => '/data1/woz/CONF/HEBDOtypes.conf', + 'CGI_FORM' => 'formHEBDO.pl', + 'DEFAULT_TRI' => 'Calendar', + 'DEFAULT_DATE' => 'semaineCourante', + 'TITLE' => 'Hebdo', + 'CGI_POST' => 'postHEBDO.pl', + 'CGI_SHOW' => 'showHEBDO.pl', + 'DEFAULT_TYPE' => 'Tout' + }; =item B list all jobs definitions known to the scheduler. - dbjobs - JID = 1 - VALIDITY = N - XEQ1 = $WEBOBS{JOB_MLNODISPLAY} - XEQ2 = -r "locastat;exit(0)" - XEQ3 = - RUNINTERVAL = 86400 - MAXSYSLOAD = 0.7 - LOGPATH = locastat - - JID = 2 - .... + dbjobs + JID = 1 + VALIDITY = N + XEQ1 = $WEBOBS{JOB_MLNODISPLAY} + XEQ2 = -r "locastat;exit(0)" + XEQ3 = + RUNINTERVAL = 86400 + MAXSYSLOAD = 0.7 + LOGPATH = locastat + + JID = 2 + .... =item B diff --git a/CODE/perl/wsudp.pl b/CODE/perl/wsudp.pl index 80d3d8c9..6df392b1 100755 --- a/CODE/perl/wsudp.pl +++ b/CODE/perl/wsudp.pl @@ -24,27 +24,27 @@ =head1 ARGUMENTS Mandatory arguments: - msg => message to be sent to server - eg: msg=>"CMD STAT" + msg => message to be sent to server + eg: msg=>"CMD STAT" Optional arguments: - host => server addr , used as socket PeerAddr - default value: value of LISTEN_ADDR as set in the scheduler configuration, - or 'localhost' if this configuration is not set. + host => server addr , used as socket PeerAddr + default value: value of LISTEN_ADDR as set in the scheduler configuration, + or 'localhost' if this configuration is not set. - port => server port , used as socket PeerPort - default value: value of PORT as set in the scheduler configuration. + port => server port , used as socket PeerPort + default value: value of PORT as set in the scheduler configuration. - max_length => maximum reply length , used in socket recv - default value: value of SOCKET_MAXLEN as set in the scheduler - configuration. + max_length => maximum reply length , used in socket recv + default value: value of SOCKET_MAXLEN as set in the scheduler + configuration. - timeout => timeout , used as socket Timeout (in seconds) - default value: 5 seconds + timeout => timeout , used as socket Timeout (in seconds) + default value: 5 seconds - For backward compatibility with older version, the 'll' option is accepted - as an alias for 'max_length', and 'to' as an alias for 'timeout'. + For backward compatibility with older version, the 'll' option is accepted + as an alias for 'max_length', and 'to' as an alias for 'timeout'. =head1 OUTPUTS @@ -53,11 +53,11 @@ =head1 OUTPUTS Possible error message are (followed by lower level error message if any): - wsudp.pl error: empty command: nothing to send - wsudp.pl error: unable to create socket: - wsudp.pl error: failed to send request: - wsudp.pl error: failed to read answer: - wsudp.pl error: connection timeout after Xs: + wsudp.pl error: empty command: nothing to send + wsudp.pl error: unable to create socket: + wsudp.pl error: failed to send request: + wsudp.pl error: failed to read answer: + wsudp.pl error: connection timeout after Xs: =head1 EXIT CODES From 90004905b1d3181e1f88d0ed07a4ecf232dc1014 Mon Sep 17 00:00:00 2001 From: "ovsgnss, volcalcgnss's tech user" Date: Tue, 11 Mar 2025 09:27:35 +0000 Subject: [PATCH 13/68] cm2cf mods --- CODE/shells/gnss/download_orbit | 8 ++-- CODE/shells/gnss/gnss_run_gipsyx | 64 ++++++++++++++++++++++++++------ 2 files changed, 56 insertions(+), 16 deletions(-) diff --git a/CODE/shells/gnss/download_orbit b/CODE/shells/gnss/download_orbit index 7bda7336..02b0b35a 100755 --- a/CODE/shells/gnss/download_orbit +++ b/CODE/shells/gnss/download_orbit @@ -12,14 +12,14 @@ # if [ $# -lt 2 ]; then echo " Syntax: download_orbit DAYS DEST [options]" - echo "Description: downloads best available orbit for chosen dates from the" + echo "Description: downloads best avalaible orbit for chosen dates from the" echo " JPL secured web server (see " echo " https://sideshow.jpl.nasa.gov/pub/JPL_GNSS_Products)" echo " Arguments:" echo " DAYS = number of days to process (from start day)" echo " DEST = root directory where orbits shall be saved" echo " Options:" - echo " -o ORBIT = type of orbit (Ultra, Rapid, Final, or Rapid_GE)" + echo " -o ORBIT = type of orbit (Ultra, Rapid or Final)" echo " -d STARTDAY = days to start retrieving (YYYY/mm/dd)" echo " -r DAYS = remove orbit files older than DAYS days" echo " -v = verbose mode" @@ -64,7 +64,7 @@ for (( i=1; i<=$#; i++)); do if [ "$ORBIT" != "Rapid" ]; then if [ "$ORBIT" != "Final" ]; then if [ "$ORBIT" != "Rapid_GE" ]; then - echo "Error : Please enter orbit as Ultra, Rapid, Final, or Rapid_GE" + echo "Error : Please enter orbit as Ultra, Rapid or Final" exit 0 fi fi @@ -126,7 +126,7 @@ for day in $DAYLIST; do echo " OK." break else - echo " not yet available!" + echo " not yet avalaible!" fi else diff --git a/CODE/shells/gnss/gnss_run_gipsyx b/CODE/shells/gnss/gnss_run_gipsyx index 62f458e4..4d1bf1a1 100755 --- a/CODE/shells/gnss/gnss_run_gipsyx +++ b/CODE/shells/gnss/gnss_run_gipsyx @@ -39,7 +39,12 @@ # JPL's GPS analysis was initially its contribution to the FLINN # (Zumberge et al. 1994, https://hdl.handle.net/hdl:2014/32449) # - +# ** 2024-09-12 Pierre Sakic +# - implement full logs +# +# ** 2025-03-10 Pierre Sakic +# - store full log in 7zip (easier to extract stuffs from it) +# - add CM/CF option #Check lock file @@ -75,7 +80,7 @@ if [ $# -lt 2 ]; then echo " -debug" echo " verbose mode & temporary folders will not be deleted" echo " -fullog" - echo " Full log record. Temporary folders are stored in a .fullog.tar.gz file" + echo " Full log record. Temporary folders are stored in a .fullog.7z file (7-zip needed)" echo "" exit 0; fi @@ -160,6 +165,11 @@ if [ -z "$NFORB" ]; then NFORB=0 fi +# boolean for enabling Center-of-Mass > Center-of-Figure +# transformation (enabled per default) +if [ -z "$CM2CF" ]; then + CM2CF=1 +fi echo "*** GipsyX / WebObs $GRID GNSS File Processing ***" @@ -246,7 +256,9 @@ for station in $NODES; do mm=${ymd:5:2} dd=${ymd:8:2} bb=$(date -d "$ymd" +"%b") - rinex="$tmpdir/${sta}${doy}0.${yy}o" + #rinex="$tmpdir/${sta}${doy}0.${yy}o" + rinex="$tmpdir/${sta}${yyyy}${doy}.rnx" # non-conventionnal RNX name, can be 2 or 3 without confusion... + label="" # used in the tdp file to custom the parameter labels # uses station.info to overwrite rinex header if [[ "$STATION_INFO" != "" && -s "$STATION_INFO" ]]; then @@ -287,7 +299,7 @@ for station in $NODES; do gipsyres="$res.tdp" gipsycov="$res.gdcov" gipsylog="$res.log" - gipsyfullog_targz="$res.fullog.tar.gz" # will be used only if $FULLOG is activated + gipsyfullog_targz="$res.fullog.7z" # will be used only if $FULLOG is activated if [[ $FORCE == 0 && -s "$gipsyres" ]]; then echo " file $gipsyres [flinn] already exists..." @@ -354,6 +366,7 @@ for station in $NODES; do # makes GipsyX processing tdp="$tmpdir/smoothFinal.tdp" + cov="$tmpdir/smoothFinal.gdcov" cd $tmpdir # makes a loop for different orbits precision: from Final to Ultra @@ -393,24 +406,43 @@ for station in $NODES; do # if we use NF orbits, add the necessary options -prodTypeGNSS nf -gdCov if [ $NFORBLOOP -eq 1 ]; then - NFORBOPTIONS="-prodTypeGNSS nf -gdCov" + NFORBOPTS="-prodTypeGNSS nf -gdCov" + else + NFORBOPTS="" + fi + + # if we use CM2CF transformation, add the necessary option -gdCov + if [ $CM2CF -eq 1 ]; then + CM2CFOPTS="-gdCov" else - NFORBOPTIONS="" + CM2CFOPTS="" fi - cmd="gd2e.py -rnxFile $rinex -GNSSproducts $ORBITOPT $GIPSYOPTIONS $NFORBOPTIONS" + # vvvvvvvvvv RUN GIPSYX HERE vvvvvvvvvv + cmd="gd2e.py -rnxFile $rinex -GNSSproducts $ORBITOPT $GIPSYOPTIONS $NFORBOPTS $CM2CFOPTS" echo " $cmd" if [ $DEBUG -eq 0 ]; then eval "$cmd > $LOG 2>&1" else eval $cmd fi + # ^^^^^^^^^^ RUN GIPSYX HERE ^^^^^^^^^^ rc=$? if [[ $rc == 0 && -s $tdp ]]; then mkdir -p "$DEST/$FID/$year" rm -f $gipsyres.* + ### Apply Center-of-Mass > Center-of-Figure transformation + if [ $CM2CF -eq 1 ]; then + echo " Apply Center-of-Mass > Center-of-Figure transformation" + cp ${cov} ${cov}_cm + netApplyNonLinear.py ${cov} -cmFile $GOA_VAR/sta_info/IGS20.cm -reverse + cp ${cov} ${cov}_cf + label="${label}CF" + fi + ### handle non-fiducial orbits: a further transformation has to be applied if [ $NFORBLOOP -eq 1 ]; then + echo " Apply Non-Fiducial > Fiducial Helmert transformation" #cp -v $cov $gipsycov #### copy the gdcov from temp > final dir, for debug only trsprm="$ORBITSDIR/$product/$yyyy/$yyyy-$mm-$dd.x.gz" cmdtrans="netApply.py -t -r -s -i $cov -o ${cov}_trs -x $trsprm" @@ -420,10 +452,14 @@ for station in $NODES; do else eval $cmdtrans fi + # save nf anf transformed versions, but regular cov is now the transformed + mv ${cov} ${cov}_nf + cp ${cov}_trs ${cov} + label="${label}NFtrs" fi - if [ $NFORBLOOP -eq 0 ]; then - ### Fiducial orbit (standard case) + if [[ $NFORBLOOP -eq 0 && $CM2CF -eq 0 ]]; then + ### Simple case: No Fiducial orbit nor CM2CF grep "\.State\.Pos\.[XYZ]" $tdp | tail -n3 > $gipsyres else ### Non Fiducial orbit, a conversion gdcov > tdp must be done @@ -431,8 +467,11 @@ for station in $NODES; do # 1) get the coordinates # 2) 1st awk to reorder the fields # 3) 2nd awk to format the fields (issue when trying to merge both awk) - # 4) Substitute the label field and customize it. NFtrs => Non Fiducial transformed, WebObs internal custom code - grep ".STA.[XYZ]" ${cov}_trs | awk '{print $3,0,$4,$5,".Station."$2}' | awk '{printf "%9d %+22.15e %+22.15e %+22.15e %s\n",$1,$2,$3,$4,$5}' | sed 's/.STA./.State.Pos.NFtrs./g' > $gipsyres + # 4) Substitute the label field and customize it with WebObs internal custom code + # + # NFtrs => Non Fiducial transformed + # CF => Center-of-Figure + grep ".STA.[XYZ]" ${cov} | awk '{print $3,0,$4,$5,".Station."$2}' | awk '{printf "%9d %+22.15e %+22.15e %+22.15e %s\n",$1,$2,$3,$4,$5}' | sed "s/.STA./.State.Pos.${label}./g" > $gipsyres fi if [ ! -z $TROP_TDP ]; then @@ -468,7 +507,8 @@ for station in $NODES; do else curdir=`pwd` cd $tmpdir - tar -zcf $gipsyfullog_targz * + #tar -zcf $gipsyfullog_targz * + 7za a $gipsyfullog_targz * > /dev/null 2>&1 cd $curdir echo " full log saved in $gipsyfullog_targz" fi From a0b71216ed69d09fa4bae7ff6cb0b2c84e4a26ce Mon Sep 17 00:00:00 2001 From: "ovsgnss, volcalcgnss's tech user" Date: Tue, 11 Mar 2025 09:34:22 +0000 Subject: [PATCH 14/68] mod download_orbit --- CODE/shells/gnss/download_orbit | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODE/shells/gnss/download_orbit b/CODE/shells/gnss/download_orbit index 02b0b35a..b0fbb040 100755 --- a/CODE/shells/gnss/download_orbit +++ b/CODE/shells/gnss/download_orbit @@ -19,7 +19,7 @@ if [ $# -lt 2 ]; then echo " DAYS = number of days to process (from start day)" echo " DEST = root directory where orbits shall be saved" echo " Options:" - echo " -o ORBIT = type of orbit (Ultra, Rapid or Final)" + echo " -o ORBIT = type of orbit (Ultra, Rapid, Final, or Rapid_GE)" echo " -d STARTDAY = days to start retrieving (YYYY/mm/dd)" echo " -r DAYS = remove orbit files older than DAYS days" echo " -v = verbose mode" @@ -64,7 +64,7 @@ for (( i=1; i<=$#; i++)); do if [ "$ORBIT" != "Rapid" ]; then if [ "$ORBIT" != "Final" ]; then if [ "$ORBIT" != "Rapid_GE" ]; then - echo "Error : Please enter orbit as Ultra, Rapid or Final" + echo "Error : Please enter orbit as Ultra, Rapid, Final, or Rapid_GE" exit 0 fi fi From a4ab2087c348129d465f79fd5d088e030a08d533 Mon Sep 17 00:00:00 2001 From: "ovsgnss, volcalcgnss's tech user" Date: Tue, 11 Mar 2025 10:25:00 +0000 Subject: [PATCH 15/68] cm2cf --- CODE/shells/gnss/download_orbit | 4 ++-- CODE/shells/gnss/gnss_run_gipsyx | 22 +++++++++++----------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/CODE/shells/gnss/download_orbit b/CODE/shells/gnss/download_orbit index b0fbb040..7bda7336 100755 --- a/CODE/shells/gnss/download_orbit +++ b/CODE/shells/gnss/download_orbit @@ -12,7 +12,7 @@ # if [ $# -lt 2 ]; then echo " Syntax: download_orbit DAYS DEST [options]" - echo "Description: downloads best avalaible orbit for chosen dates from the" + echo "Description: downloads best available orbit for chosen dates from the" echo " JPL secured web server (see " echo " https://sideshow.jpl.nasa.gov/pub/JPL_GNSS_Products)" echo " Arguments:" @@ -126,7 +126,7 @@ for day in $DAYLIST; do echo " OK." break else - echo " not yet avalaible!" + echo " not yet available!" fi else diff --git a/CODE/shells/gnss/gnss_run_gipsyx b/CODE/shells/gnss/gnss_run_gipsyx index 4d1bf1a1..83c6c9da 100755 --- a/CODE/shells/gnss/gnss_run_gipsyx +++ b/CODE/shells/gnss/gnss_run_gipsyx @@ -44,7 +44,7 @@ # # ** 2025-03-10 Pierre Sakic # - store full log in 7zip (easier to extract stuffs from it) -# - add CM/CF option +# - add CM2CF option #Check lock file @@ -166,9 +166,9 @@ if [ -z "$NFORB" ]; then fi # boolean for enabling Center-of-Mass > Center-of-Figure -# transformation (enabled per default) +# transformation (default value doesn't) if [ -z "$CM2CF" ]; then - CM2CF=1 + CM2CF=0 fi echo "*** GipsyX / WebObs $GRID GNSS File Processing ***" @@ -412,7 +412,7 @@ for station in $NODES; do fi # if we use CM2CF transformation, add the necessary option -gdCov - if [ $CM2CF -eq 1 ]; then + if [[ $CM2CF -eq 1 && $NFORBLOOP -eq 0 ]]; then CM2CFOPTS="-gdCov" else CM2CFOPTS="" @@ -437,7 +437,7 @@ for station in $NODES; do cp ${cov} ${cov}_cm netApplyNonLinear.py ${cov} -cmFile $GOA_VAR/sta_info/IGS20.cm -reverse cp ${cov} ${cov}_cf - label="${label}CF" + label="${label}.CF" fi ### handle non-fiducial orbits: a further transformation has to be applied @@ -455,7 +455,7 @@ for station in $NODES; do # save nf anf transformed versions, but regular cov is now the transformed mv ${cov} ${cov}_nf cp ${cov}_trs ${cov} - label="${label}NFtrs" + label="${label}.NFtrs" fi if [[ $NFORBLOOP -eq 0 && $CM2CF -eq 0 ]]; then @@ -467,11 +467,11 @@ for station in $NODES; do # 1) get the coordinates # 2) 1st awk to reorder the fields # 3) 2nd awk to format the fields (issue when trying to merge both awk) - # 4) Substitute the label field and customize it with WebObs internal custom code - # - # NFtrs => Non Fiducial transformed - # CF => Center-of-Figure - grep ".STA.[XYZ]" ${cov} | awk '{print $3,0,$4,$5,".Station."$2}' | awk '{printf "%9d %+22.15e %+22.15e %+22.15e %s\n",$1,$2,$3,$4,$5}' | sed "s/.STA./.State.Pos.${label}./g" > $gipsyres + # 4) Substitute the label field + # 5) Customize it with WebObs internal custom code + # NFtrs => Non Fiducial transformed + # CF => Center-of-Figure + grep ".STA.[XYZ]" ${cov} | awk '{print $3,0,$4,$5,".Station."$2}' | awk '{printf "%9d %+22.15e %+22.15e %+22.15e %s\n",$1,$2,$3,$4,$5}' | sed "s/.STA./.State.Pos./g" | sed "s/$/${label}/" > $gipsyres fi if [ ! -z $TROP_TDP ]; then From 76f5968f9e861f094aadf772e0439eff457a44f7 Mon Sep 17 00:00:00 2001 From: PierreS-alpha <49942080+PierreS-alpha@users.noreply.github.com> Date: Tue, 11 Mar 2025 14:07:21 +0100 Subject: [PATCH 16/68] Add CM2CF option+ note in gnss_run_gipsyx_template.rc --- CODE/shells/gnss/gnss_run_gipsyx_template.rc | 21 ++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/CODE/shells/gnss/gnss_run_gipsyx_template.rc b/CODE/shells/gnss/gnss_run_gipsyx_template.rc index 076aad9a..62a0262d 100644 --- a/CODE/shells/gnss/gnss_run_gipsyx_template.rc +++ b/CODE/shells/gnss/gnss_run_gipsyx_template.rc @@ -68,12 +68,13 @@ REALTIME="" DATA_DELAY="5 min" ###### Processing details management -## activate debug mode +### activate debug mode # verbose mode & temporary folders will not be deleted DEBUG=0 -## Full log record -# Temporary folders are stored in a .fullog.tar.gz file +### Full log record +# Temporary folders are stored in a +# .fullog.7z file (7zip needed) FULLOG=0 ###### Advanced geodetic modes @@ -82,13 +83,25 @@ FULLOG=0 # NFORB option will add '-prodTypeGNSS nf -gdCov' in the GIPSYOPTIONS # and will perform the post-processing re-alignement # leave NFORB=0 if you are not sure of what you are doing +NFORB=0 # *** Detailed Note: # JPL's Fiducial orbits are directly aligned to ITRF. # But the usage of Non-fiducial orbits are recommended by # the JPL and the geodetic community # Coordinates computed with non Fiducial orbits requiries # a re-alignement to the ITRF with external Helmert parameters -NFORB=0 + +### Apply Center-of-Mass > Center-of-Figure transformation +# CM2CF option will add '-gdCov' in the GIPSYOPTIONS +# and will perform a post-processing CM > CF transformation +# Activate CM2CF is recommended, but stays OFF per default +CM2CF=0 +# *** Detailled Note: +# Since August 2024, JPL provides its orbits in +# IGS20 (~ITRF2020) w.r.t. Earth's Center of Mass (CM) +# For volcanological studies, Earth's Center of Figure (CF) +# is a better origin point (no seasonal signal visible) +# Thus, a CM > CF transformation is needed From df7196c00c9f2ec6f6c51ca754ecfe4ce6b0bbb7 Mon Sep 17 00:00:00 2001 From: "ovsgnss, volcalcgnss's tech user" Date: Tue, 11 Mar 2025 15:21:04 +0000 Subject: [PATCH 17/68] CM2CF ready --- CODE/shells/gnss/gnss_run_gipsyx | 29 ++++++++--------------------- 1 file changed, 8 insertions(+), 21 deletions(-) diff --git a/CODE/shells/gnss/gnss_run_gipsyx b/CODE/shells/gnss/gnss_run_gipsyx index 83c6c9da..be9fcaac 100755 --- a/CODE/shells/gnss/gnss_run_gipsyx +++ b/CODE/shells/gnss/gnss_run_gipsyx @@ -168,6 +168,8 @@ fi # boolean for enabling Center-of-Mass > Center-of-Figure # transformation (default value doesn't) if [ -z "$CM2CF" ]; then + echo "WARN: CM2CF option is not set, but Center-of-Mass > Center-of-Figure" + echo " transformation is recommended since IGS20 switch (2024-08)" CM2CF=0 fi @@ -405,27 +407,15 @@ for station in $NODES; do fi # if we use NF orbits, add the necessary options -prodTypeGNSS nf -gdCov - if [ $NFORBLOOP -eq 1 ]; then - NFORBOPTS="-prodTypeGNSS nf -gdCov" - else - NFORBOPTS="" - fi + [ $NFORBLOOP -eq 1 ] && NFORBOPTS="-prodTypeGNSS nf -gdCov" || NFORBOPTS="" # if we use CM2CF transformation, add the necessary option -gdCov - if [[ $CM2CF -eq 1 && $NFORBLOOP -eq 0 ]]; then - CM2CFOPTS="-gdCov" - else - CM2CFOPTS="" - fi + [[ $CM2CF -eq 1 && $NFORBLOOP -eq 0 ]] && CM2CFOPTS="-gdCov" || CM2CFOPTS="" # vvvvvvvvvv RUN GIPSYX HERE vvvvvvvvvv cmd="gd2e.py -rnxFile $rinex -GNSSproducts $ORBITOPT $GIPSYOPTIONS $NFORBOPTS $CM2CFOPTS" echo " $cmd" - if [ $DEBUG -eq 0 ]; then - eval "$cmd > $LOG 2>&1" - else - eval $cmd - fi + [ $DEBUG -eq 0 ] && eval "$cmd > $LOG 2>&1" || eval "$cmd" # ^^^^^^^^^^ RUN GIPSYX HERE ^^^^^^^^^^ rc=$? if [[ $rc == 0 && -s $tdp ]]; then @@ -435,7 +425,8 @@ for station in $NODES; do if [ $CM2CF -eq 1 ]; then echo " Apply Center-of-Mass > Center-of-Figure transformation" cp ${cov} ${cov}_cm - netApplyNonLinear.py ${cov} -cmFile $GOA_VAR/sta_info/IGS20.cm -reverse + cmdcm2cf="netApplyNonLinear.py ${cov} -cmFile $GOA_VAR/sta_info/IGS20.cm -reverse" + [ $DEBUG -eq 0 ] && eval "$cmdcm2cf >> $LOG 2>&1" || eval "$cmdcm2cf" cp ${cov} ${cov}_cf label="${label}.CF" fi @@ -447,11 +438,7 @@ for station in $NODES; do trsprm="$ORBITSDIR/$product/$yyyy/$yyyy-$mm-$dd.x.gz" cmdtrans="netApply.py -t -r -s -i $cov -o ${cov}_trs -x $trsprm" echo " $cmdtrans" - if [ $DEBUG -eq 0 ]; then - eval "$cmdtrans > $LOG 2>&1" - else - eval $cmdtrans - fi + [ $DEBUG -eq 0 ] && eval "$cmdtrans >> $LOG 2>&1" || eval "$cmdtrans" # save nf anf transformed versions, but regular cov is now the transformed mv ${cov} ${cov}_nf cp ${cov}_trs ${cov} From 3e5fd9d476d3a998df8e1275683c77b1c32a1204 Mon Sep 17 00:00:00 2001 From: "ovsgnss, volcalcgnss's tech user" Date: Thu, 13 Mar 2025 16:55:46 +0000 Subject: [PATCH 18/68] remove ugly ifs in download_orbit --- CODE/shells/gnss/download_orbit | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/CODE/shells/gnss/download_orbit b/CODE/shells/gnss/download_orbit index 7bda7336..2c1eae21 100755 --- a/CODE/shells/gnss/download_orbit +++ b/CODE/shells/gnss/download_orbit @@ -60,16 +60,10 @@ for (( i=1; i<=$#; i++)); do k=$((i+1)) ORBIT=( "${!k}" ) # Check correct orbit input - if [ "$ORBIT" != "Ultra" ]; then - if [ "$ORBIT" != "Rapid" ]; then - if [ "$ORBIT" != "Final" ]; then - if [ "$ORBIT" != "Rapid_GE" ]; then - echo "Error : Please enter orbit as Ultra, Rapid, Final, or Rapid_GE" - exit 0 - fi - fi - fi - fi + if [[ "$ORBIT" != "Ultra" && "$ORBIT" != "Rapid" && "$ORBIT" != "Final" && "$ORBIT" != "Rapid_GE" ]]; then + echo "Error: Please enter orbit as Ultra, Rapid, Final, or Rapid_GE" + exit 1 + fi ;; -r) From 86bf2048c5df1e25ac4a45c399a857052621bb78 Mon Sep 17 00:00:00 2001 From: "ovsgnss, volcalcgnss's tech user" Date: Thu, 20 Mar 2025 09:17:29 +0000 Subject: [PATCH 19/68] add --no-check-certificate --- CODE/shells/gnss/download_orbit | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/CODE/shells/gnss/download_orbit b/CODE/shells/gnss/download_orbit index 2c1eae21..44114d90 100755 --- a/CODE/shells/gnss/download_orbit +++ b/CODE/shells/gnss/download_orbit @@ -9,7 +9,10 @@ # **** Updates # ** 2023-08-24 Pierre Sakic # - Download Rapid_GE orbits -# +# ** 2025-03-20 PS +# - Hotfix to solve JPL's sideshow +# certificate issue with wget + if [ $# -lt 2 ]; then echo " Syntax: download_orbit DAYS DEST [options]" echo "Description: downloads best available orbit for chosen dates from the" @@ -37,6 +40,7 @@ ORBIT=("Final" "Rapid" "Ultra" "Rapid_GE") delete="FALSE" verbose="FALSE" quiet="-q" +xtra_opts="--no-check-certificate" # Optionnal parameters for (( i=1; i<=$#; i++)); do @@ -107,13 +111,13 @@ for day in $DAYLIST; do if [ -e "$0.rc" ]; then for f in $(cat "$0.rc"); do - wget $quiet -q -N -P $DEST/$orbit/$year -r -l1 -nd "$URL/$year-$month-$day$f" + wget $xtra_opts $quiet -N -P $DEST/$orbit/$year -r -l1 -nd "$URL/$year-$month-$day$f" if [ $? -ne 0 ]; then break fi done else - wget $quiet -q -N -P $DEST/$orbit/$year -r -l1 -nd $URL -A "$year-$month-$day*" + wget $xtra_opts $quiet -N -P $DEST/$orbit/$year -r -l1 -nd $URL -A "$year-$month-$day*" fi if [ -e $LOCAL ]; then # if download succeed From ed072563c6fce5b4203712894b35bb1e5cdc48b3 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Wed, 30 Jul 2025 19:42:01 +0200 Subject: [PATCH 20/68] add spotgins enu --- CODE/matlab/readfmtdata.m | 2 +- CODE/matlab/readfmtdata_gnss.m | 54 +++++++++++++++++++++++++++++++++- 2 files changed, 54 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/readfmtdata.m b/CODE/matlab/readfmtdata.m index 8964f22b..2bee1e41 100644 --- a/CODE/matlab/readfmtdata.m +++ b/CODE/matlab/readfmtdata.m @@ -65,7 +65,7 @@ case {'miniseed','seedlink','arclink','combined','fdsnws-dataselect'} D(n) = readfmtdata_miniseed(WO,P,N(n),F); - case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-ippp','gamit-pos','pbogps-pos'} + case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-enu','spotgins-ippp','gamit-pos','pbogps-pos'} D(n) = readfmtdata_gnss(WO,P,N(n),F); case {'hyp71sum2k','fdsnws-event','scevtlog-xml'} diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index 08d5cc47..d8765d3b 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -34,7 +34,10 @@ % data format: extract from SmoothFinal.tdp output file (grep "Station.SSSS.State.pos.[XYZ]" lines) % node calibration: no .CLB file or 4 components (East, North, Up) in meters and (Orbit) % -% format 'gins-ippp' +% format 'spotgins-enu' +% ***** complete me ****** +% +% format 'spotgins-ippp' % type: GINS IPPP solutions % filename/url: P.RAWDATA (use $FID to point the right file/url) % data format: yyyymmdd hhmmss yyyy.yyyyyyyyy jjjjj.jj X Y Z dX dY dZ E N V dE dN dV @@ -300,8 +303,57 @@ end %D.ITRF_YEAR = 'ITRF08'; + +% ----------------------------------------------------------------------------- +case 'spotgins-enu' + % format exemple + %#jjjjj.jjjjjjjj _____E _____N _____U ____dE ____dN ____dU yyyymmddHHMMSS yyyy.yyyyyyy Const Dateofexe GinsVersion + % 52670.83876160 0.055822 0.051638 0.005578 0.001263 0.001163 0.004899 20030131200749 2003.0844898 G 250404_185253 VALIDE_24_2 + % 52671.50195600 0.057207 0.054240 -0.004722 0.000705 0.000619 0.002600 20030201120249 2003.0863067 G 250404_185253 VALIDE_24_2 + + fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); + wosystem(sprintf('rm -f %s',fdat),P); + for a = 1:length(F.raw) + fraw = F.raw{a}; + #cmd0 = sprintf('awk ''/^[^!]/ {print}'' >> %s',fdat); % removes header lines + cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines + if strncmpi('http',fraw,4) + s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); + if s ~= 0 + break; + end + else + s = wosystem(sprintf('cat %s | %s',fraw,cmd0),P); + end + if s ~= 0 + fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); + end + end + + + % load the file + if exist(fdat,'file') + dd = load(fdat); + else + dd = []; + end + if ~isempty(dd) + t = dd(:,1) + 678941.5007; % converts MJD to datenum + d = [dd(:,2:4),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),Orbit + e = dd(:,5:7); + e(e Date: Wed, 30 Jul 2025 23:21:22 +0200 Subject: [PATCH 21/68] add spotgins enu --- CODE/etc/rawformats.conf | 1 + 1 file changed, 1 insertion(+) diff --git a/CODE/etc/rawformats.conf b/CODE/etc/rawformats.conf index 7668091e..fc063fb0 100644 --- a/CODE/etc/rawformats.conf +++ b/CODE/etc/rawformats.conf @@ -22,6 +22,7 @@ winston|EARTHWORM|EarthWorm Winston Wave Server data request||host:port gipsy|GNSS|JPL GIPSY-OASIS .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root directory containing YYYY/FID/*.tdp files gipsyx|GNSS|JPL GipsyX .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root directory containing YYYY/FID/*.tdp files globkval|GNSS|MIT GAMIT/GLOBK VAL file||fullpath of directory containing the .VAL file +spotgins-enu|GNSS|SPOTGINS IPPP time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file spotgins-ippp|GNSS|SPOTGINS IPPP time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file gamit-pos|GNSS|MIT GAMIT/GLOBL POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file pbogps-pos|GNSS|PBO GPS POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file From 82ba53fa1379c71d42ab54b126ec5b2037d365a2 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Thu, 31 Jul 2025 16:25:49 +0200 Subject: [PATCH 22/68] change load for dlmread --- CODE/matlab/readfmtdata_gnss.m | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index d8765d3b..d6a6b2dd 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -315,7 +315,6 @@ wosystem(sprintf('rm -f %s',fdat),P); for a = 1:length(F.raw) fraw = F.raw{a}; - #cmd0 = sprintf('awk ''/^[^!]/ {print}'' >> %s',fdat); % removes header lines cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines if strncmpi('http',fraw,4) s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); @@ -333,13 +332,13 @@ % load the file if exist(fdat,'file') - dd = load(fdat); + dd = dlmread(fdat); else dd = []; end if ~isempty(dd) t = dd(:,1) + 678941.5007; % converts MJD to datenum - d = [dd(:,2:4),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),Orbit + d = [dd(:,2:4),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),Orbit e = dd(:,5:7); e(e Date: Thu, 31 Jul 2025 16:56:24 +0200 Subject: [PATCH 23/68] spotgins-enu-v2 --- CODE/etc/rawformats.conf | 2 +- CODE/matlab/readfmtdata_gnss.m | 9 ++++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/CODE/etc/rawformats.conf b/CODE/etc/rawformats.conf index fc063fb0..5755fa24 100644 --- a/CODE/etc/rawformats.conf +++ b/CODE/etc/rawformats.conf @@ -22,7 +22,7 @@ winston|EARTHWORM|EarthWorm Winston Wave Server data request||host:port gipsy|GNSS|JPL GIPSY-OASIS .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root directory containing YYYY/FID/*.tdp files gipsyx|GNSS|JPL GipsyX .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root directory containing YYYY/FID/*.tdp files globkval|GNSS|MIT GAMIT/GLOBK VAL file||fullpath of directory containing the .VAL file -spotgins-enu|GNSS|SPOTGINS IPPP time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file +spotgins-enu-v2|GNSS|SPOTGINS solutions - version 2 (<2025-08)||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file spotgins-ippp|GNSS|SPOTGINS IPPP time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file gamit-pos|GNSS|MIT GAMIT/GLOBL POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file pbogps-pos|GNSS|PBO GPS POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index d6a6b2dd..05c83645 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -34,8 +34,11 @@ % data format: extract from SmoothFinal.tdp output file (grep "Station.SSSS.State.pos.[XYZ]" lines) % node calibration: no .CLB file or 4 components (East, North, Up) in meters and (Orbit) % -% format 'spotgins-enu' -% ***** complete me ****** +% format 'spotgins-enu-v2' +% type: SPOTGINS solutions - version 2 (<2025-08) +% filename/url: P.RAWDATA (use $FID to point the right file/url) +% data format: jjjjj.jj E N V dE dN dV yyyymmddhhmmss yyyy.yyyyyyyyy +% node calibration: no .CLB file or 4 components (East, North, Up) in meters and (Orbit) % % format 'spotgins-ippp' % type: GINS IPPP solutions @@ -305,7 +308,7 @@ % ----------------------------------------------------------------------------- -case 'spotgins-enu' +case 'spotgins-enu-v2' % format exemple %#jjjjj.jjjjjjjj _____E _____N _____U ____dE ____dN ____dU yyyymmddHHMMSS yyyy.yyyyyyy Const Dateofexe GinsVersion % 52670.83876160 0.055822 0.051638 0.005578 0.001263 0.001163 0.004899 20030131200749 2003.0844898 G 250404_185253 VALIDE_24_2 From 2cf1a569df61c67ff81d84c7a998078b4a8ed5dc Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 15:15:53 +0200 Subject: [PATCH 24/68] Add metadata structure for GNSS node details in export --- CODE/matlab/superprocs/gnss.m | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index a07a03b3..ffcbe7dc 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -653,6 +653,21 @@ E.header = [E.header,{'East_treat(m)','North_treat(m)','Up_treat(m)'}]; end E.title = sprintf('%s {%s}',P.GTABLE(r).GTITLE,upper(N(n).ID)); + + E.meta = struct( ... + 'NODE_FID',N(kn(s)).FID, ... + 'NODE_NAME',N(kn(s)).NAME, ... + 'NODE_GNSS_9CHAR',N(kn(s)).GNSS_9CHAR, ... + 'NODE_LATITUDE',sprintf('%1.6f',N(kn(s)).LAT_WGS84), ... + 'NODE_LONGITUDE',sprintf('%1.6f',N(kn(s)).LON_WGS84), ... + 'NODE_ELEVATION',sprintf('%1.2f',N(kn(s)).ALTITUDE), ... + 'PROC_ITRF_REF',sprintf('%s',any2str(P.ITRF_REF)) ... + 'PROC_VELOCITY_REF',sprintf('%s',any2str(P.VELOCITY_REF)) ... + ); + if vrelmode + E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); + end + mkexport(WO,sprintf('%s_%s',N(n).ID,P.GTABLE(r).TIMESCALE),E,P.GTABLE(r)); end end From eed997079bb8ae828e318627113fff9e1a9f101a Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 15:47:19 +0200 Subject: [PATCH 25/68] Add warning messages for unknown formats in readfmtdata function --- CODE/matlab/readfmtdata.m | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CODE/matlab/readfmtdata.m b/CODE/matlab/readfmtdata.m index 37b947d1..33cd49d2 100644 --- a/CODE/matlab/readfmtdata.m +++ b/CODE/matlab/readfmtdata.m @@ -99,7 +99,8 @@ D(n) = readfmtdata_mc3(WO,P,N(n),F); otherwise - D(n).t = []; + fprintf('%s: ** WARNING ** unknown format "%s", will try to read it anyway...\n',wofun,F.fmt); + D(n).t = []; [D(n).d,D(n).CLB] = calib([],[],N(n).CLB); D(n).e = ones(size(D(n).d)); fprintf('%s: ** WARNING ** unknown format "%s". Nothing to do!\n',wofun,F.fmt); From 041fa257a7768c91a3f2e59cf67f3ab6a4ecfd40 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 15:48:08 +0200 Subject: [PATCH 26/68] Fix formatting in GNSS output for ITRF reference --- CODE/matlab/superprocs/gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index ffcbe7dc..f324c989 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,7 +661,7 @@ 'NODE_LATITUDE',sprintf('%1.6f',N(kn(s)).LAT_WGS84), ... 'NODE_LONGITUDE',sprintf('%1.6f',N(kn(s)).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(kn(s)).ALTITUDE), ... - 'PROC_ITRF_REF',sprintf('%s',any2str(P.ITRF_REF)) ... + 'PROC_ITRF_REF',sprintf('%s',any2str(P.ITRF_REF)), ... 'PROC_VELOCITY_REF',sprintf('%s',any2str(P.VELOCITY_REF)) ... ); if vrelmode From 4d9cd173999ed0d40338963b7056eeeb563f9fce Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 15:48:44 +0200 Subject: [PATCH 27/68] Add 'spotgins-enu-v2' format to GNSS data reading cases --- CODE/matlab/readfmtdata.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/readfmtdata.m b/CODE/matlab/readfmtdata.m index 33cd49d2..b553e83f 100644 --- a/CODE/matlab/readfmtdata.m +++ b/CODE/matlab/readfmtdata.m @@ -65,7 +65,7 @@ case {'miniseed','seedlink','arclink','combined','fdsnws-dataselect'} D(n) = readfmtdata_miniseed(WO,P,N(n),F); - case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-enu','spotgins-ippp','gamit-pos','pbogps-pos'} + case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-enu-v2','spotgins-ippp','gamit-pos','pbogps-pos'} D(n) = readfmtdata_gnss(WO,P,N(n),F); case {'hyp71sum2k','fdsnws-event','scevtlog-xml'} From f245b045d976d1d1fcc936521df4d7c2052d9993 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 15:53:59 +0200 Subject: [PATCH 28/68] Fix uistack call to check for function existence before execution --- CODE/matlab/plotorbit.m | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CODE/matlab/plotorbit.m b/CODE/matlab/plotorbit.m index d5307bfd..2ca399c3 100644 --- a/CODE/matlab/plotorbit.m +++ b/CODE/matlab/plotorbit.m @@ -19,7 +19,9 @@ if size(d,2) > 1 set(gca,'Ylim',get(gca,'YLim')) % freezes Y axis (error bars can overflow) h = plot(repmat(t,[1,2])',(repmat(d(:,1),[1,2])+d(:,2)*[-1,1])','-','LineWidth',.1,'Color',.6*[1,1,1]); - uistack(h,'bottom') + if exist('uistack','file') == 2 + uistack(h,'bottom') + end end % overwrites non-final orbits From 75bcebed0f8c8baca1279c09ac47bbf45a6ce949 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 15:56:03 +0200 Subject: [PATCH 29/68] Refactor uistack handling to include Octave compatibility for error bars --- CODE/matlab/plotorbit.m | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/CODE/matlab/plotorbit.m b/CODE/matlab/plotorbit.m index 2ca399c3..7b55c86c 100644 --- a/CODE/matlab/plotorbit.m +++ b/CODE/matlab/plotorbit.m @@ -19,8 +19,14 @@ if size(d,2) > 1 set(gca,'Ylim',get(gca,'YLim')) % freezes Y axis (error bars can overflow) h = plot(repmat(t,[1,2])',(repmat(d(:,1),[1,2])+d(:,2)*[-1,1])','-','LineWidth',.1,'Color',.6*[1,1,1]); - if exist('uistack','file') == 2 + if exist('uistack','file') == 2 % checks if uistack function exists, (only MATLAB, not octave compatible) uistack(h,'bottom') + else % Octave equivalent + set(h, 'HandleVisibility', 'off'); + axes_children = get(gca, 'Children'); + other_children = setdiff(axes_children, h); + set(gca, 'Children', [other_children; h]); + set(h, 'HandleVisibility', 'on'); end end From 2885082a2304b0640b6e8c58da7adb7ef492653e Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 15:56:57 +0200 Subject: [PATCH 30/68] Remove Octave equivalent handling for uistack in plotorbit function --- CODE/matlab/plotorbit.m | 6 ------ 1 file changed, 6 deletions(-) diff --git a/CODE/matlab/plotorbit.m b/CODE/matlab/plotorbit.m index 7b55c86c..c65b4baf 100644 --- a/CODE/matlab/plotorbit.m +++ b/CODE/matlab/plotorbit.m @@ -21,12 +21,6 @@ h = plot(repmat(t,[1,2])',(repmat(d(:,1),[1,2])+d(:,2)*[-1,1])','-','LineWidth',.1,'Color',.6*[1,1,1]); if exist('uistack','file') == 2 % checks if uistack function exists, (only MATLAB, not octave compatible) uistack(h,'bottom') - else % Octave equivalent - set(h, 'HandleVisibility', 'off'); - axes_children = get(gca, 'Children'); - other_children = setdiff(axes_children, h); - set(gca, 'Children', [other_children; h]); - set(h, 'HandleVisibility', 'on'); end end From 801f9ddbef2b538130a3566f0f09112933183c4a Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 16:00:48 +0200 Subject: [PATCH 31/68] Fix metadata assignment in GNSS processing for correct node reference --- CODE/matlab/superprocs/gnss.m | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index f324c989..4731364a 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -655,12 +655,12 @@ E.title = sprintf('%s {%s}',P.GTABLE(r).GTITLE,upper(N(n).ID)); E.meta = struct( ... - 'NODE_FID',N(kn(s)).FID, ... - 'NODE_NAME',N(kn(s)).NAME, ... - 'NODE_GNSS_9CHAR',N(kn(s)).GNSS_9CHAR, ... - 'NODE_LATITUDE',sprintf('%1.6f',N(kn(s)).LAT_WGS84), ... - 'NODE_LONGITUDE',sprintf('%1.6f',N(kn(s)).LON_WGS84), ... - 'NODE_ELEVATION',sprintf('%1.2f',N(kn(s)).ALTITUDE), ... + 'NODE_FID',N(n).FID, ... + 'NODE_NAME',N(n).NAME, ... + 'NODE_GNSS_9CHAR',N(n).GNSS_9CHAR, ... + 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... + 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... + 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... 'PROC_ITRF_REF',sprintf('%s',any2str(P.ITRF_REF)), ... 'PROC_VELOCITY_REF',sprintf('%s',any2str(P.VELOCITY_REF)) ... ); From 0eb87f975b3de8acb91ee5bc3bbbf7e73a74fb84 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 16:03:49 +0200 Subject: [PATCH 32/68] Update ITRF reference formatting in GNSS processing and remove commented velocity reference --- CODE/matlab/superprocs/gnss.m | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 4731364a..b6ca001e 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,9 +661,12 @@ 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... - 'PROC_ITRF_REF',sprintf('%s',any2str(P.ITRF_REF)), ... - 'PROC_VELOCITY_REF',sprintf('%s',any2str(P.VELOCITY_REF)) ... + 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... + %'PROC_VELOCITY_REF',sprintf('%s',any2str(P.VELOCITY_REF)) ... ); + + + if vrelmode E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); end From e990c31a533c10e71233d0b0f872b0eb016ecd18 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 16:04:43 +0200 Subject: [PATCH 33/68] Fix formatting of ITRF reference output in GNSS processing --- CODE/matlab/superprocs/gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index b6ca001e..a7547c02 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,7 +661,7 @@ 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... - 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... + 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))) ... %'PROC_VELOCITY_REF',sprintf('%s',any2str(P.VELOCITY_REF)) ... ); From 939e420f86a2b3f6fd0fc730a5433e631c95b05e Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 16:06:27 +0200 Subject: [PATCH 34/68] Fix velocity reference formatting in GNSS processing --- CODE/matlab/superprocs/gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index a7547c02..200e59da 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -662,7 +662,7 @@ 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))) ... - %'PROC_VELOCITY_REF',sprintf('%s',any2str(P.VELOCITY_REF)) ... + 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ); From 92adc27809c1c3e42a204326a572adf701a0208c Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 16:07:00 +0200 Subject: [PATCH 35/68] Fix formatting of PROC_ITRF_REF and PROC_VELOCITY_REF in GNSS processing --- CODE/matlab/superprocs/gnss.m | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 200e59da..94c4398d 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,8 +661,8 @@ 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... - 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))) ... - 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) + 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... + 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ... ); From 1a9e52dea82e4945d36430f81a3145208378e594 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 16:39:42 +0200 Subject: [PATCH 36/68] Add PROC_VECTORS_REF to metadata in GNSS processing --- CODE/matlab/superprocs/gnss.m | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 94c4398d..b40b682a 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -663,10 +663,9 @@ 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ... + 'PROC_VECTORS_REF',sprintf('%s',any2str(field2str(P,'VECTORS_REF',''))) ); - - if vrelmode E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); end From aba22fc400a61bd8d90f53c62f2ac3b50308bbed Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 16:40:25 +0200 Subject: [PATCH 37/68] Fix formatting of PROC_VELOCITY_REF and PROC_VECTORS_REF in GNSS processing --- CODE/matlab/superprocs/gnss.m | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index b40b682a..e87ebdfc 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -662,8 +662,8 @@ 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... - 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ... - 'PROC_VECTORS_REF',sprintf('%s',any2str(field2str(P,'VECTORS_REF',''))) + 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))), ... + 'PROC_VECTORS_REF',sprintf('%s',any2str(field2str(P,'VECTORS_REF',''))) ... ); if vrelmode From ca3e6feab1953d3b3d72dad5a0c85b70b2a4f3a7 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 17:18:31 +0200 Subject: [PATCH 38/68] CORRECT BUG: meta are now erased after the export --- CODE/matlab/superprocs/gnss.m | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index e87ebdfc..bd2a8087 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -662,15 +662,13 @@ 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... - 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))), ... - 'PROC_VECTORS_REF',sprintf('%s',any2str(field2str(P,'VECTORS_REF',''))) ... ); - if vrelmode E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); end mkexport(WO,sprintf('%s_%s',N(n).ID,P.GTABLE(r).TIMESCALE),E,P.GTABLE(r)); + E.meta = {}; % meta are erased after the export end end @@ -2345,6 +2343,7 @@ E.infos = cat(2,E.infos,sprintf('Time period #%d = %g days (%s)',m,modeltime_period(m),days2h(modeltime_period(m),'round'))); end mkexport(WO,sprintf('%s_VECTORS_%s_%s',summary,lower(N(kn(s)).ID),P.GTABLE(r).TIMESCALE),E,P.GTABLE(r)); + E.meta = {}; % meta are erased after the export end % modeltime results From f4b5da07559fb2ae957083878f90c3eb0860579e Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 17:19:16 +0200 Subject: [PATCH 39/68] Fix formatting of PROC_ITRF_REF in GNSS processing --- CODE/matlab/superprocs/gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index bd2a8087..f28b81ef 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,7 +661,7 @@ 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... - 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... + 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))) ... ); if vrelmode E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); From c23b345b6ca4c9cef87eabc410ebb2bbbc51b122 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 11 Aug 2025 17:27:16 +0200 Subject: [PATCH 40/68] Enhance metadata handling by adding comments for PROC_ITRF_REF and PROC_VELOCITY_REF in GNSS processing --- CODE/matlab/superprocs/gnss.m | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index f28b81ef..d9cab52b 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,9 +661,14 @@ 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... - 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))) ... - ); + % ITRF reference (this is a string displayed on graph title, not functional) + 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... + % Relative velocity reference E,N,U (mm/yr) from ITRF = constant trend + % substracted to all data before any other processing + 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ... + ); if vrelmode + % substracts a reference vector (can be NODE-dependent) E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); end From 1e86197c9218e6e75c8428840a787fd8e7dcb80f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Mon, 18 Aug 2025 14:13:40 +0200 Subject: [PATCH 41/68] add module source code for publication --- .gitignore | 1 - CODE/matlab/superprocs/jerk.m | 522 ++++++++++++++++++++++++++++++++++ 2 files changed, 522 insertions(+), 1 deletion(-) create mode 100644 CODE/matlab/superprocs/jerk.m diff --git a/.gitignore b/.gitignore index 55faf5e2..ea4a5d8f 100644 --- a/.gitignore +++ b/.gitignore @@ -3,7 +3,6 @@ CODE/bin CODE/matlab/bin CODE/matlab/*.mex* CODE/matlab/invmogi.m -CODE/matlab/superprocs/jerk.m CODE/i18n/locales/*/LC_MESSAGES/*.mo DOC/user-manual/* !DOC/user-manual/*.tex diff --git a/CODE/matlab/superprocs/jerk.m b/CODE/matlab/superprocs/jerk.m new file mode 100644 index 00000000..e2436fbe --- /dev/null +++ b/CODE/matlab/superprocs/jerk.m @@ -0,0 +1,522 @@ +function DOUT=jerk(varargin) +%JERK WebObs SuperPROC: Updates graphs/exports of JERK results. +% +% JERK(PROC) makes default outputs of PROC. +% +% JERK(PROC,TSCALE) updates all or a selection of TIMESCALES graphs: +% TSCALE = '%' : all timescales defined by PROC.conf (default) +% TSCALE = '01y' or '30d,10y,'all' : only specified timescales +% (keywords must be in TIMESCALELIST of PROC.conf) +% +% JERK(PROC,[],REQDIR) makes graphs/exports for specific request directory REQDIR. +% REQDIR must contain a REQUEST.rc file with dedicated parameters. +% +% D = JERK(PROC,...) returns a structure D containing all the PROC data: +% D(i).id = node ID +% D(i).t = time vector (for node i) +% D(i).d = matrix of processed data (NaN = invalid data) +% +% JERK will use PROC's parameters from .conf file. Particularily, it +% uses RAWFORMAT and associated NODEs' calibration file channels +% definition. But these nodes must contain 3 channels exactly as follows: +% Channel 1 = LME Eastern mass position (nm/s2) +% Channel 2 = LMN Norther mass position (nm/s2) +% Channel 3 = LKI temperature (optional) +% Channel 4 = LDI atmospheric pressure (optional) +% +% Also, Earth tide prediction program GOTIC2 is used, downloadable at: +% http://www.miz.nao.ac.jp/staffs/nao99/index_En.html +% so the following key in WEBOBS.rc must be defined: +% PRGM_GOTIC2|/opt/nao99b/gotic2/gotic2 +% and NODE's location (latitude,longitude) must be defined and correct. +% +% Additional keys are needed in the PROC configuration. See template PROC.JERK for +% details and comments. +% +% +% +% Authors: F. Beauducel + G. Roult + V. Ferrazzini, WEBOBS/IPGP +% Created: 2014-04-14 at OVPF, La Réunion, Indian Ocean +% Updated: 2025-03-31 + +WO = readcfg; +wofun = sprintf('WEBOBS{%s}',mfilename); + +% --- checks input arguments +if nargin < 1 + error('%s: must define PROC name.',wofun); +end + +procmsg = any2str(mfilename,varargin{:}); +timelog(procmsg,1); + +% gets PROC's configuration, associated nodes for any TSCALE and/or REQDIR +[P,N,D] = readproc(WO,varargin{:}); + +tidemodes = {'Solid+Ocean','Solid','Ocean','none'}; + +% gets PROC's specific parameters +mw = field2num(P,'JERK_WINDOW_SECONDS'); +dt = field2num(P,'JERK_SAMPLING_SECONDS'); +threshold_level1 = 1e9*field2num(P,'JERK_THRESHOLD_LEVEL1_MS3',2e-10); % threshold in nm/s3 +threshold_level2 = 1e9*field2num(P,'JERK_THRESHOLD_LEVEL2_MS3',1e-10); % threshold in nm/s3 +threshold_max = 1e9*field2num(P,'JERK_THRESHOLD_MAX_MS3',1e-8); % max threshold in nm/s3 +rgb_level1 = field2num(P,'LEVEL1_RGB',[0.7,1,0.7]); +rgb_level2 = field2num(P,'LEVEL2_RGB',[1,0.7,0.7]); +zoomdays = field2num(P,'JERK_ZOOM_DAYS',1); +targetlatlon = field2num(P,'JERK_TARGET_LATLON'); +targetangle = field2num(P,'JERK_TARGET_ANGLE_DEG',45); +procazlim = field2num(P,'JERK_AZLIM',[0,180]); +chan_smooth = field2num(P,'CHANNELS_MOVING_AVERAGE_SAMPLES',ones(1,4)); +tidemode = field2num(P,'TIDES_PREDICT_MODE',0); + +cb2 = char(178); % superscript 2 (latin) +cb3 = char(179); % superscript 3 (latin) +cba = char(186); % degree sign (latin) + +tlast = nan(length(N),1); +tfirst = nan(length(N),1); +tfirstall = NaN; + +for n = 1:length(N) + stitle = sprintf('JERK %s: %s',N(n).ALIAS,N(n).NAME); + + t = D(n).t; + d = D(n).d; + for c = 1:size(d,2) + if length(chan_smooth) >= c && chan_smooth(c) > 1 + d(:,c) = mavr(d(:,c),chan_smooth(c)); + end + end + C = D(n).CLB; + nx = N(n).CLB.nx; + %facq = 1; + %maxlags = facq*86400/4; + %ndif = 12*3600; + + + if length(targetlatlon) > 1 + [~,~,tdis,tazm] = greatcircle(N(n).LAT_WGS84,N(n).LON_WGS84,targetlatlon(1),targetlatlon(2),2); + azlim = tazm(1) + targetangle*[-1,1]; + else + azlim = procazlim; + end + + % computes theoretical tides (in nm/s2) + if tidemode + % takes one day before and after the time window of data to allow time shift + T = mktides(WO.PRGM_GOTIC2,tidemode,P.DATELIM+[-1,1],N(n).LAT_WGS84,N(n).LON_WGS84,N(n).ALTITUDE); + end + + + if ~isempty(t) + tlast(n) = rmax(t); + tfirst(n) = rmin(t); + tfirstall = min(tfirstall,tfirst(n)); + else + tlast(n) = now; + tfirst = now-1; + end + + + + % ===================== makes the proc's job + + for r = 1:length(P.GTABLE) + + figure, clf, orient tall + k = find((t >= P.GTABLE(r).DATE1 | isnan(P.GTABLE(r).DATE1)) & (t <= P.GTABLE(r).DATE2 | isnan(P.GTABLE(r).DATE2))); + xlim = [P.GTABLE(r).DATE1,P.GTABLE(r).DATE2]; + if isempty(k) + %k1 = []; + ke = []; + if any(isnan(xlim)) + xlim = P.NOW - [1,0]; + end + acqui = 0; + tk = []; + dk = nan(0,5); + else + %k1 = k(1); + ke = k(end); + if any(isnan(xlim)) + xlim = [tfirst(n),tlast(n)]; + end + acqui = round(100*length(k)*N(n).ACQ_RATE/abs(t(k(end)) - N(n).LAST_DELAY - xlim(1))); + if P.GTABLE(r).DECIMATE > 1 + tk = decim(t(k),P.GTABLE(r).DECIMATE); + dk = decim(d(k,:),P.GTABLE(r).DECIMATE); + else + tk = t(k); + dk = d(k,:); + end + end + + etat = 0; + for i = 1:nx + if any(~isnan(d(k(t(k) >= xlim(2) - N(n).LAST_DELAY),i))) + etat = etat + 1; + end + end + etat = 100*etat/nx; + + if length(zoomdays) == 1 + zd = xlim(2) - [zoomdays,0]; + else + zd = xlim(2) - [max(zoomdays(:)),min(zoomdays(:))]; + end + %[b,a] = butter(2,facq/(12*3600)); + % bandwidth filter 1h - 18h + [b,a] = butter(2,[1/18,1]/3600/.5); + + if tidemode && ~isempty(k) + % adjusts phase and amplitude of tides + tidefit = zeros(3,2); + for c = 1:2 + %d(:,c) = cleanpicks(d(:,c),.5); + %zi = interp1(T.t,T.d(:,c),t); + %k = find(~isnan(d(:,c))); + %di = interp1(t(k),d(k,c),t); + %k = find(~isnan(zi) & ~isnan(di)); + + % a) trying with cross-correlation... does not work with noisy data... + %y = xcorr(diff(zi(k)),diff(di(k)),maxlags); + %y = xcorr(diffn(zi,ndif),diffn(di,ndif),maxlags); + %y = xcorr(filter(b,a,zi),filter(b,a,di),maxlags); + %[cx,i] = max(abs(cleanpicks(y,cpp))); + %tidefit(c,1) = (maxlags-i)/facq/86400; + + % b) computes the phase shift on M2 wave (much more stable) + %PW = doodson('M2'); % gets the exact period of M2 + %[h1,y1] = harmfit(2*pi*t/PW.period,zi); % fits a sinus on tide signal + %[h2,y2] = harmfit(2*pi*t/PW.period,di); % fits a sinus on data signal + %tidefit(c,1) = PW.period*mod((h1(3)-h2(3))/(2*pi) + 1,1); + %keyboard + + %td = interp1(T.t + tidefit(c,1),T.d(:,c),t); + %f = @(x) rsum((d(:,c) - rmean(d(:,c)) - td*x).^2); + %tidefit(c,2) = fminsearch(f,1); + %d(:,3+c) = td*tidefit(c,2); + + % c) inverses both amplitude and time-shift after bandwidth filter (L2 norm) + %dd = d(:,c) - rmean(d(:,c)); + %dd = rdetrend(tk - tk(1),dk(:,c)); + kr = find(~isnan(dk(:,c))); + if ~isempty(kr) + dd = filter(b,a,dk(kr,c) - mean(dk(kr,c))); + %dd = linfilter(t - t(1),d(:,c),ceil(diff(minmax(t))/2)+1); + f = @(x) rsum((dd - filter(b,a,interp1(T.t + x(1),T.d(:,c),tk(kr),'*linear')*x(2))).^2)/length(kr); + tidefit(c,:) = fminsearch(f,[0,1],optimset('Display','off','MaxIter',50)); + end + dk(:,3+c) = interp1(T.t + tidefit(c,1),T.d(:,c),tk,'*linear')*tidefit(c,2); + + %fprintf('WEBOBS{jerk}: adjusted tide component %d = x %g %+d s\n',c,tidefit(c,2),round(tidefit(c,1)*86400)); + + % d) inverses amplitude and rotation angle (L1 or L2 norm) + %dd = rdetrend(tk - tk(1),dk(:,c)); + %f = @(x) rsum((dd - interp1(T.t,T.d(:,2)*cosd(x(1)) + T.d(:,1)*sind(x(1)),tk,'*linear')*x(2)).^2); + %f = @(x) rsum(abs(dd - interp1(T.t,T.d(:,2)*cosd(x(1)) + T.d(:,1)*sind(x(1)),tk,'*linear')*x(2))); + %tidefit(c,:) = fminsearch(f,[90*(c==1),1]); + %dk(:,3+c) = interp1(T.t,T.d(:,2)*cosd(tidefit(c,1)) + T.d(:,1)*sind(tidefit(c,1)),tk)*tidefit(c,2); + + %fprintf('WEBOBS{jerk}: adjusted tide component %d = x %g N%+d\n',c,tidefit(c,2),round(tidefit(c,1))); + fprintf('%s: adjusted tide component %d = x %g %+dh %02.0fm\n',wofun,c,tidefit(c,2),h2hms(24*tidefit(c,1),1)); + end + else + dk(:,4:5) = 0*dk(:,1:2); + end + + fprintf('%s: computes jerk time series... ',wofun); + + x = dk(:,1) - dk(:,4); + y = dk(:,2) - dk(:,5); + ip = mw:dt:length(x); + bx = zeros(length(ip),2); + by = zeros(length(ip),2); + + ii = 1; + for i = ip + k = i + 1 + (-mw:-1); + kk = k(~isnan(x(k))); + bx(ii,:) = polyfit((tk(kk)-tk(1))*86400,x(kk),1); + kk = k(~isnan(y(k))); + by(ii,:) = polyfit((tk(kk)-tk(1))*86400,y(kk),1); + ii = ii + 1; + end + [jth,jerk] = cart2pol(bx(:,1),by(:,1)); + jth = mod(90 - jth*180/pi + 360,360); % azimuth in [0,360] �N range + + if strcmp(P.JERK_THRESHOLD_MODE,'auto') + tf = str2double(P.JERK_THRESHOLD_TIDES_FACTOR); + threshold_level1 = max([max(abs(diff(d(:,3)))),max(abs(diff(dk(:,4))))])/tf; + end + fprintf('done (threshold_level1 = %g).\n',threshold_level1); + + + % title and status + P.GTABLE(r).GTITLE = gtitle(stitle,P.GTABLE(r).TIMESCALE); + P.GTABLE(r).GSTATUS = [P.NOW,etat,acqui]; + N(n).STATUS = etat; + N(n).ACQUIS = acqui; + P.GTABLE(r).INFOS = {''}; + + % loop for each data column + for i = 1:2 + subplot(9,1,(i-1)*2 + (1:2)); extaxes(gca,[.07,.03]) + if ~isempty(k) + plot(tk,dk(:,i),'-','LineWidth',P.GTABLE(r).MARKERSIZE/10,'Color',scolor(1)) + hold on + plot(tk,dk(:,i+3) + rmean(dk(:,i)),'-','LineWidth',P.GTABLE(r).MARKERSIZE/20,'Color',scolor(2)) + plot(tk,dk(:,i) - dk(:,i+3),'-','LineWidth',P.GTABLE(r).MARKERSIZE/5,'Color',scolor(3)) + hold off + end + set(gca,'XLim',xlim,'FontSize',8) + datetick2('x',P.GTABLE(r).DATESTR) + ylabel(sprintf('%s (%s)',C.nm{i},C.un{i})) + if isempty(d) || all(isnan(d(k,i))) + nodata(xlim) + end + end + + % temperature (LKI) + subplot(9,1,5); extaxes(gca,[.07,.03]) + plot(tk,mavr(dk(:,3),chan_smooth(c)),'-','LineWidth',P.GTABLE(r).MARKERSIZE/5,'Color',scolor(4)) + set(gca,'XLim',xlim,'FontSize',8) + ylim = minmax(dk(:,3)); + if any(isnan(ylim)) + nodata(xlim); + else + set(gca,'YLim',ylim) + end + datetick2('x',P.GTABLE(r).DATESTR) + ylabel(sprintf('%s (%s)',C.nm{3},C.un{3})) + + % jerk + subplot(9,1,6:7); extaxes(gca,[.07,.03]) + plot(xlim,repmat(threshold_level2,1,2),'--','Color',rgb_level2,'LineWidth',1) + hold on + plot(xlim,repmat(threshold_level1,1,2),'--','Color',rgb_level1,'LineWidth',1) + plot(tk(ip),jerk,'-','LineWidth',P.GTABLE(r).MARKERSIZE/5,'Color',scolor(1)) + ylim = get(gca,'YLim'); + plot(zd,ylim(2)*([1,1]+.03),'-','LineWidth',2,'Color',.7*ones(1,3),'Clipping','off') % zoom interval + hold off + set(gca,'XLim',xlim,'Ylim',ylim,'FontSize',8) + datetick2('x',P.GTABLE(r).DATESTR) + ylabel(sprintf('Acceleration rate (nm/s%s)',cb3)) + tlabel(xlim,P.GTABLE(r).TZ) + + % jerk zoom + subplot(9,1,8:9); extaxes(gca,[.07,.03]) + pos = get(gca,'Position'); + set(gca,'Position',[.4,pos(2)-.02,pos(3) - .4 + pos(1),pos(4)]); + kz = find(isinto(tk(ip),zd)); + if ~isempty(kz) + plot(zd,repmat(threshold_level2,1,2),'--','Color',rgb_level2,'LineWidth',1) + hold on + plot(zd,repmat(threshold_level1,1,2),'--','Color',rgb_level1,'LineWidth',1) + plot(tk(ip(kz)),jerk(kz),'-','LineWidth',P.GTABLE(r).MARKERSIZE/3,'Color',scolor(1)) + hold off + set(gca,'YLim',[0,max(str2double(P.JERK_ZOOM_MINYLIM_MS3)*1e9,max(jerk(kz)))]) + end + set(gca,'XLim',zd,'FontSize',8); + %datetick2('x','mm/dd HH:MM') + datetick2('x',-1) + ylabel(sprintf('Acceleration rate (nm/s%s)',cb3)) + tlabel(zd,P.GTABLE(r).TZ) + + % plot alerts in background + ka2 = ip(jerkthreshold_level2 & (insector(jth,azlim) | insector(jth-180,azlim))); + if ~isempty(ka2) + plotevt(tk(ka2),'Color',rgb_level2,'LineWidth',2); + end + ka2z = ka2(isinto(tk(ka2),zd)); + if ~isempty(ka2z) + sal2 = sprintf('{\\bf%s} (total {\\bf%1.0f} mn)',datestr(tk(ka2z(end)),'dd-mmm-yyyy HH:MM'),length(ka2z)*dt/60); + else + sal2 = 'none'; + end + ka1 = ip(jerkthreshold_level1 & jerk 1 + title(sprintf('Target: {\\bf %g km}, {\\bfN%1.0f \\pm %g%s}',roundsd(tdis(2),2),mod(tazm(1)+360,360),targetangle,cba)) + end + + if ~isempty(k) + P.GTABLE(r).INFOS = {sprintf('Last data: {\\bf%s} {\\it%+d}',datestr(t(ke)),P.GTABLE(r).TZ)}; + if tidemode + P.GTABLE(r).INFOS = [P.GTABLE(r).INFOS{:},{ ... + sprintf(' Tide predict mode: {\\bf%s}',tidemodes{tidemode}), ... + sprintf(' E-W tide: {\\bf\\times %1.4f, \\Delta{t} = %+dh %02.0fm}', ... + tidefit(1,2),h2hms(24*tidefit(1,1),1)), ... + sprintf(' N-S tide: {\\bf\\times %1.4f, \\Delta{t} = %+dh %02.0fm}', ... + tidefit(2,2),h2hms(24*tidefit(2,1),1)), ... + }]; + else + P.GTABLE(r).INFOS = [P.GTABLE(r).INFOS{:},{ ... + sprintf(' Tide predict mode: {\\bfnode}'), ... + sprintf(' E-W tide: {\\bfnone}'), ... + sprintf(' N-S tide: {\\bfnone}'), ... + }]; + end + P.GTABLE(r).INFOS = [P.GTABLE(r).INFOS{:},{ ... + 'JERK parameters:', ... + sprintf(' Sampling: {\\bf%g s}',dt), ... + sprintf(' Slope window: {\\bf%g s}',mw), ... + sprintf(' Azimuth interval: {\\bfN%g to N%g}',round(mod(azlim+360,360))), ... + ' ', ... + sprintf('Last JERK alert (in zoom window):'), ... + sprintf(' Level1: %s',sal1),sprintf(' Level2: %s',sal2), ' ', ... + }]; + end + + % makes graph + OPT.EVENTS = N(n).EVENTS; + mkgraph(WO,sprintf('%s_%s',lower(N(n).ID),P.GTABLE(r).TIMESCALE),P.GTABLE(r),OPT) + close + + if ~isempty(k) + talarm = tk(ip); + alarm = zeros(size(jerk)); + alarm(jerkthreshold_level1 & (insector(jth,azlim) | insector(jth-180,azlim))) = 1; + alarm(jerkthreshold_level2 & (insector(jth,azlim) | insector(jth-180,azlim))) = 2; + + % exports data + if isok(P.GTABLE(r),'EXPORTS') + E.t = talarm; + E.d = [dk(ip,:),jerk,jth,alarm]; + E.header = { ... + sprintf('%s(%s)',C.nm{1},C.un{1}), ... + sprintf('%s(%s)',C.nm{2},C.un{2}), ... + sprintf('%s(%s)',C.nm{3},C.un{3}), ... + sprintf('EW_Tide(nm/s%s)',cb2), ... + sprintf('NS_Tide(nm/s%s)',cb2), ... + sprintf('Jerk(nm/s%s)',cb3), ... + sprintf('Azimuth(%sN)',cba),'Alarm'}; + E.title = sprintf('%s {%s}',stitle,upper(N(n).ID)); + E.fmt = [repmat({'%f'},1,7),{'%g'}]; + mkexport(WO,sprintf('%s_%s',N(n).ID,P.GTABLE(r).TIMESCALE),E,P.GTABLE(r)); + end + + % email for alerts + if ~P.REQUEST && isfield(P,'NOTIFY_EVENT') && ~isempty(P.NOTIFY_EVENT) + falert = sprintf('%s/alertstatus',P.OUTDIR); + if exist(falert,'file') + alertlast = load(falert); + else + alertlast = [talarm(end),0]; + end + al = [talarm(end),alarm(end)]; + alert = 0; + alertlevel = { ... + 'NORMAL', ... + 'WARNING', ... + 'ALERT', ... + }; + alertstatus = ''; + switch al(2) + case 0 + switch alertlast(2) + case 1 + alertstatus = 'end of warning'; + alert = 1; + case 2 + alertstatus = 'end of alert'; + alert = 1; + end + case 1 + switch alertlast(2) + case 0 + alertstatus = 'start'; + alert = 1; + case 2 + alertstatus = 'end of alert'; + alert = 1; + end + case 2 + switch alertlast(2) + case {0,1} + alertstatus = 'start'; + alert = 1; + end + end + save(falert,'al','-ascii','-double'); + if alert + % root URL + if isfield(WO,'ROOT_URL') + url = WO.ROOT_URL; + else + url = 'http://webobs'; + end + + % makes a comprehensive text message for email notification + msg = sprintf('JERK %s: status %s (%s)',N(n).ALIAS,alertlevel{al(2)+1},alertstatus); + + f = sprintf('%s/mail.txt',P.OUTDIR); + fid = fopen(f,'wt'); + fprintf(fid,'\n\n%s {%s}\n',P.NAME,P.SELFREF); + fprintf(fid,'%s: %s\n\n',N(n).ALIAS,N(n).NAME); + fprintf(fid,'Current status\n\t%s: %s\n',datestr(al(1)),alertlevel{al(2)+1}); + fprintf(fid,'Previous status\n\t%s: %s\n',datestr(alertlast(1)),alertlevel{alertlast(2)+1}); + fprintf(fid,'\n\n'); + fprintf(fid,'%s/cgi-bin/showOUTG.pl?grid=%s&g=%s\n',url,P.SELFREF,lower(N(n).ID)); + fclose(fid); + + notify(WO,P.NOTIFY_EVENT,'!',sprintf('file=%s subject=%s',f,msg)); + end + end + end + end +end + + +if P.REQUEST + mkendreq(WO,P); +end + +timelog(procmsg,2) + + +% Returns data in DOUT +if nargout > 0 + DOUT = D; +end From 4dfeb970e52ee4848e1870dcf7655949f2b6ff87 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 12:17:46 +0200 Subject: [PATCH 42/68] new branch 1st commit --- CODE/matlab/superprocs/gnss.m | 1 + 1 file changed, 1 insertion(+) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index d9cab52b..5e7f8892 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -2385,6 +2385,7 @@ end end + if P.REQUEST mkendreq(WO,P); end From 8c426e47b9820e0dbff2ac2f6419ecb05b989d17 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:08:18 +0200 Subject: [PATCH 43/68] Fix typo in geo variable assignment in GNSS processing --- CODE/matlab/superprocs/gnss.m | 44 +++++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 17 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 5e7f8892..c03f2495 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -81,6 +81,9 @@ cmpnames = split(field2str(P,'COMPONENT_NAMELIST','Relative Eastern,Relative Northern,Relative Vertical'),','); disp_yscale = field2num(P,'DISP_YSCALE_M',0); +export_header_proc_keylist = split(field2str(P,'EXPORT_HEADER_PROC_KEYLIST',''),','); + + % Harmonic correction: period list (day), pairs of sine, cosine (mm) for each component harm_refdate = field2num(P,'HARMONIC_ORIGIN_DATE'); harm_period = field2num(P,'HARMONIC_PERIOD_DAY',0); @@ -306,7 +309,7 @@ modeltime_markersize = pi*(field2num(P,'MODELTIME_MARKERSIZE',10,'notempty')/2)^2; % scatter needs marker size as a surface (πr²) -geo = [cat(1,N.LAT_WGS84),cat(1,N.LON_WGS84),cat(1,N.ALTITUDE)]; +geo = [cat(1,N.LAT_WGS84),cat(1,N.LAT_WGS84),cat(1,N.ALTITUDE)]; V.name = P.NAME; V.velref = itrf; @@ -654,24 +657,31 @@ end E.title = sprintf('%s {%s}',P.GTABLE(r).GTITLE,upper(N(n).ID)); - E.meta = struct( ... - 'NODE_FID',N(n).FID, ... - 'NODE_NAME',N(n).NAME, ... - 'NODE_GNSS_9CHAR',N(n).GNSS_9CHAR, ... - 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... - 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... - 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... - % ITRF reference (this is a string displayed on graph title, not functional) - 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... - % Relative velocity reference E,N,U (mm/yr) from ITRF = constant trend - % substracted to all data before any other processing - 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ... - ); - if vrelmode - % substracts a reference vector (can be NODE-dependent) - E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); + E.meta = {}; + if ~isempty(export_header_proc_keylist) + for iexport = 1:length(export_header_proc_keylist) + E.meta.("NODE." + export_header_proc_keylist{iexport}) = N(n).(export_header_proc_keylist{iexport}); + end end + %E.meta = struct( ... + % 'NODE_FID',N(n).FID, ... + % 'NODE_NAME',N(n).NAME, ... + % 'NODE_GNSS_9CHAR',N(n).GNSS_9CHAR, ... + % 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... + % 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... + % 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... + % % ITRF reference (this is a string displayed on graph title, not functional) + % 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... + % % Relative velocity reference E,N,U (mm/yr) from ITRF = constant trend + % % substracted to all data before any other processing + % 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ... + % ); + %if vrelmode + % % substracts a reference vector (can be NODE-dependent) + % E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); + %end + mkexport(WO,sprintf('%s_%s',N(n).ID,P.GTABLE(r).TIMESCALE),E,P.GTABLE(r)); E.meta = {}; % meta are erased after the export end From c6aebe06cd19e4a49a36b42003f5b0cd063e8203 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:18:11 +0200 Subject: [PATCH 44/68] Refactor meta key assignment in export to use underscore notation for consistency --- CODE/matlab/superprocs/gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index c03f2495..7ab69cd0 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -660,7 +660,7 @@ E.meta = {}; if ~isempty(export_header_proc_keylist) for iexport = 1:length(export_header_proc_keylist) - E.meta.("NODE." + export_header_proc_keylist{iexport}) = N(n).(export_header_proc_keylist{iexport}); + E.meta.(['NODE_', export_header_proc_keylist{iexport}]) = N(n).(export_header_proc_keylist{iexport}); end end From 912b937999a7baab7ee3feaa4461f5e5c3094258 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:21:17 +0200 Subject: [PATCH 45/68] Update metadata assignment in GNSS processing to use PROC_ prefix for consistency --- CODE/matlab/superprocs/gnss.m | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 7ab69cd0..56866074 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -658,9 +658,16 @@ E.title = sprintf('%s {%s}',P.GTABLE(r).GTITLE,upper(N(n).ID)); E.meta = {}; + + if ~isempty(export_header_node_keylist) + for iexport = 1:length(export_header_node_keylist) + E.meta.(['NODE_', export_header_node_keylist{iexport}]) = N(n).(export_header_node_keylist{iexport}); + end + end + if ~isempty(export_header_proc_keylist) for iexport = 1:length(export_header_proc_keylist) - E.meta.(['NODE_', export_header_proc_keylist{iexport}]) = N(n).(export_header_proc_keylist{iexport}); + E.meta.(['PROC_', export_header_proc_keylist{iexport}]) = P(n).(export_header_proc_keylist{iexport}); end end From 757f9ea6cf0760525078f4e19b8b36396f15ad06 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:23:37 +0200 Subject: [PATCH 46/68] Add export header node key list to GNSS processing --- CODE/matlab/superprocs/gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 56866074..5e7bb81f 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -82,7 +82,7 @@ disp_yscale = field2num(P,'DISP_YSCALE_M',0); export_header_proc_keylist = split(field2str(P,'EXPORT_HEADER_PROC_KEYLIST',''),','); - +export_header_node_keylist = split(field2str(P,'EXPORT_HEADER_NODE_KEYLIST',''),','); % Harmonic correction: period list (day), pairs of sine, cosine (mm) for each component harm_refdate = field2num(P,'HARMONIC_ORIGIN_DATE'); From a745c7d07f1ecd3a2ed8af0b51106b7fdcef7e69 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:26:54 +0200 Subject: [PATCH 47/68] Update export meta key assignment to use dot notation for consistency --- CODE/matlab/superprocs/gnss.m | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 5e7bb81f..655a5721 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,13 +661,13 @@ if ~isempty(export_header_node_keylist) for iexport = 1:length(export_header_node_keylist) - E.meta.(['NODE_', export_header_node_keylist{iexport}]) = N(n).(export_header_node_keylist{iexport}); + E.meta.(['NODE.', export_header_node_keylist{iexport}]) = N(n).(export_header_node_keylist{iexport}); end end if ~isempty(export_header_proc_keylist) for iexport = 1:length(export_header_proc_keylist) - E.meta.(['PROC_', export_header_proc_keylist{iexport}]) = P(n).(export_header_proc_keylist{iexport}); + E.meta.(['PROC.', export_header_proc_keylist{iexport}]) = P(n).(export_header_proc_keylist{iexport}); end end From 197c1bf9ca624b6da4ebd33e6c5bcbf6c41e1150 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:32:22 +0200 Subject: [PATCH 48/68] Update export meta key assignments to convert values to string format --- CODE/matlab/superprocs/gnss.m | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 655a5721..073ee1a9 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -661,13 +661,13 @@ if ~isempty(export_header_node_keylist) for iexport = 1:length(export_header_node_keylist) - E.meta.(['NODE.', export_header_node_keylist{iexport}]) = N(n).(export_header_node_keylist{iexport}); + E.meta.(['NODE.', export_header_node_keylist{iexport}]) = any2str(N(n).(export_header_node_keylist{iexport})); end end if ~isempty(export_header_proc_keylist) for iexport = 1:length(export_header_proc_keylist) - E.meta.(['PROC.', export_header_proc_keylist{iexport}]) = P(n).(export_header_proc_keylist{iexport}); + E.meta.(['PROC.', export_header_proc_keylist{iexport}]) = any2str(P.(export_header_proc_keylist{iexport})); end end From 04e0425575119d35bfe33f578784b8e82297550c Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:51:52 +0200 Subject: [PATCH 49/68] Refactor metadata assignment in GNSS processing to consolidate export metadata handling --- CODE/matlab/add_export_metadata.m | 23 +++++++++++++++++++++++ CODE/matlab/superprocs/gnss.m | 8 +++++++- 2 files changed, 30 insertions(+), 1 deletion(-) create mode 100644 CODE/matlab/add_export_metadata.m diff --git a/CODE/matlab/add_export_metadata.m b/CODE/matlab/add_export_metadata.m new file mode 100644 index 00000000..78f63734 --- /dev/null +++ b/CODE/matlab/add_export_metadata.m @@ -0,0 +1,23 @@ +function outstruct = add_export_metadata(NP, export_header_keylist, np_type) +%ADD_EXPORT_METADATA Add metadata to export structure based on node and process parameters +% +% INPUTS: +% NP - Node or Proc configuration structure +% export_header_keylist - Cell array of node/proc field names to export +% np_type - String indicating the type ('NODE' or 'PROC') +% +% OUTPUT: +% outstruct - export structure with added metadata + + % Initialize meta field if it doesn't exist + outstruct = struct(); + + % Add node metadata + if ~isempty(export_header_keylist) + for iexport = 1:length(export_header_keylist) + fieldname = export_header_keylist{iexport}; + outstruct.([np_type,'.', fieldname]) = any2str(NP.(fieldname)); + end + end +end + diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 073ee1a9..12c0b7de 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -658,7 +658,7 @@ E.title = sprintf('%s {%s}',P.GTABLE(r).GTITLE,upper(N(n).ID)); E.meta = {}; - + if ~isempty(export_header_node_keylist) for iexport = 1:length(export_header_node_keylist) E.meta.(['NODE.', export_header_node_keylist{iexport}]) = any2str(N(n).(export_header_node_keylist{iexport})); @@ -671,6 +671,12 @@ end end + E.meta = {}; + meta_n = add_export_metadata(N(n),export_header_node_keylist,"NODE"); + meta_p = add_export_metadata(P,export_header_proc_keylist,"PROC"); + E.meta = [meta_n, meta_p]; + + %E.meta = struct( ... % 'NODE_FID',N(n).FID, ... % 'NODE_NAME',N(n).NAME, ... From 20cdf273a1ef2d4d47fd723f992589aec0312f2b Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 14:58:50 +0200 Subject: [PATCH 50/68] Refactor add_export_metadata function to modify export structure directly and improve metadata handling --- CODE/matlab/add_export_metadata.m | 16 ++++++++++------ CODE/matlab/superprocs/gnss.m | 8 +++----- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/CODE/matlab/add_export_metadata.m b/CODE/matlab/add_export_metadata.m index 78f63734..32d7464c 100644 --- a/CODE/matlab/add_export_metadata.m +++ b/CODE/matlab/add_export_metadata.m @@ -1,23 +1,27 @@ -function outstruct = add_export_metadata(NP, export_header_keylist, np_type) +function E = add_export_metadata(E, NP, export_header_keylist, np_type) %ADD_EXPORT_METADATA Add metadata to export structure based on node and process parameters % % INPUTS: +% E - Export structure to modify % NP - Node or Proc configuration structure % export_header_keylist - Cell array of node/proc field names to export % np_type - String indicating the type ('NODE' or 'PROC') % % OUTPUT: -% outstruct - export structure with added metadata +% E - Modified export structure with added metadata % Initialize meta field if it doesn't exist - outstruct = struct(); + if ~isfield(E, 'meta') + E.meta = struct(); + end % Add node metadata if ~isempty(export_header_keylist) for iexport = 1:length(export_header_keylist) fieldname = export_header_keylist{iexport}; - outstruct.([np_type,'.', fieldname]) = any2str(NP.(fieldname)); + if isfield(NP, fieldname) + E.meta.(['NODE.', fieldname]) = any2str(NP.(fieldname)); + end end end -end - +end \ No newline at end of file diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 12c0b7de..8b40e52f 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -658,7 +658,7 @@ E.title = sprintf('%s {%s}',P.GTABLE(r).GTITLE,upper(N(n).ID)); E.meta = {}; - + if ~isempty(export_header_node_keylist) for iexport = 1:length(export_header_node_keylist) E.meta.(['NODE.', export_header_node_keylist{iexport}]) = any2str(N(n).(export_header_node_keylist{iexport})); @@ -672,11 +672,9 @@ end E.meta = {}; - meta_n = add_export_metadata(N(n),export_header_node_keylist,"NODE"); - meta_p = add_export_metadata(P,export_header_proc_keylist,"PROC"); - E.meta = [meta_n, meta_p]; + E = add_export_metadata(E,N(n),export_header_node_keylist,"NODE"); + E = add_export_metadata(E,P,export_header_proc_keylist,"PROC"); - %E.meta = struct( ... % 'NODE_FID',N(n).FID, ... % 'NODE_NAME',N(n).NAME, ... From 3c40d368cb8f9eafc30558040e332204ce7b5ac7 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 15:01:42 +0200 Subject: [PATCH 51/68] Update export metadata assignment to use dynamic np_type for consistency --- CODE/matlab/add_export_metadata.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/add_export_metadata.m b/CODE/matlab/add_export_metadata.m index 32d7464c..f3dce8af 100644 --- a/CODE/matlab/add_export_metadata.m +++ b/CODE/matlab/add_export_metadata.m @@ -20,7 +20,7 @@ for iexport = 1:length(export_header_keylist) fieldname = export_header_keylist{iexport}; if isfield(NP, fieldname) - E.meta.(['NODE.', fieldname]) = any2str(NP.(fieldname)); + E.meta.([np_type, '.', fieldname]) = any2str(NP.(fieldname)); end end end From 86fa9a5c39b4d1bab00e14857227137fa5bdb021 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 15:06:52 +0200 Subject: [PATCH 52/68] Update function documentation to include author and creation date --- CODE/matlab/add_export_metadata.m | 4 ++++ CODE/matlab/superprocs/gnss.m | 18 ------------------ 2 files changed, 4 insertions(+), 18 deletions(-) diff --git a/CODE/matlab/add_export_metadata.m b/CODE/matlab/add_export_metadata.m index f3dce8af..05927fa9 100644 --- a/CODE/matlab/add_export_metadata.m +++ b/CODE/matlab/add_export_metadata.m @@ -9,6 +9,10 @@ % % OUTPUT: % E - Modified export structure with added metadata +% +% Author: Pierre Sakic / WEBOBS, IPGP +% Created: 2025-08-22 +% Updated: 2025-08-22 % Initialize meta field if it doesn't exist if ~isfield(E, 'meta') diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 8b40e52f..74508a54 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -675,24 +675,6 @@ E = add_export_metadata(E,N(n),export_header_node_keylist,"NODE"); E = add_export_metadata(E,P,export_header_proc_keylist,"PROC"); - %E.meta = struct( ... - % 'NODE_FID',N(n).FID, ... - % 'NODE_NAME',N(n).NAME, ... - % 'NODE_GNSS_9CHAR',N(n).GNSS_9CHAR, ... - % 'NODE_LATITUDE',sprintf('%1.6f',N(n).LAT_WGS84), ... - % 'NODE_LONGITUDE',sprintf('%1.6f',N(n).LON_WGS84), ... - % 'NODE_ELEVATION',sprintf('%1.2f',N(n).ALTITUDE), ... - % % ITRF reference (this is a string displayed on graph title, not functional) - % 'PROC_ITRF_REF',sprintf('%s',any2str(field2str(P,'ITRF_REF',''))), ... - % % Relative velocity reference E,N,U (mm/yr) from ITRF = constant trend - % % substracted to all data before any other processing - % 'PROC_VELOCITY_REF',sprintf('%s',any2str(field2str(P,'VELOCITY_REF',''))) ... - % ); - %if vrelmode - % % substracts a reference vector (can be NODE-dependent) - % E.meta.PROC_VECTORS_VELOCITY_REF = sprintf('%s',any2str(vref)); - %end - mkexport(WO,sprintf('%s_%s',N(n).ID,P.GTABLE(r).TIMESCALE),E,P.GTABLE(r)); E.meta = {}; % meta are erased after the export end From e60bdad9b101cad32275e881e4f895cfc0dbdc23 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Fri, 22 Aug 2025 15:45:28 +0200 Subject: [PATCH 53/68] Refactor export metadata handling to streamline assignment process --- CODE/matlab/superprocs/gnss.m | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index 74508a54..3d7d0f73 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -657,20 +657,6 @@ end E.title = sprintf('%s {%s}',P.GTABLE(r).GTITLE,upper(N(n).ID)); - E.meta = {}; - - if ~isempty(export_header_node_keylist) - for iexport = 1:length(export_header_node_keylist) - E.meta.(['NODE.', export_header_node_keylist{iexport}]) = any2str(N(n).(export_header_node_keylist{iexport})); - end - end - - if ~isempty(export_header_proc_keylist) - for iexport = 1:length(export_header_proc_keylist) - E.meta.(['PROC.', export_header_proc_keylist{iexport}]) = any2str(P.(export_header_proc_keylist{iexport})); - end - end - E.meta = {}; E = add_export_metadata(E,N(n),export_header_node_keylist,"NODE"); E = add_export_metadata(E,P,export_header_proc_keylist,"PROC"); From 38c776f95390649ea668f02471d2be5b47159677 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 22 Sep 2025 12:31:52 +0200 Subject: [PATCH 54/68] add both spotgins v2 & v3 --- CODE/matlab/readfmtdata_gnss.m | 77 ++++++++++++++++++++++++++++++---- 1 file changed, 68 insertions(+), 9 deletions(-) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index 4912f8af..4d4b769e 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -308,17 +308,65 @@ % ----------------------------------------------------------------------------- -case 'spotgins-enu-v2' - % format exemple +case 'spotgins-enu' + % Supports both v2 and v3 SPOTGINS formats + % + % v2 format example: %#jjjjj.jjjjjjjj _____E _____N _____U ____dE ____dN ____dU yyyymmddHHMMSS yyyy.yyyyyyy Const Dateofexe GinsVersion % 52670.83876160 0.055822 0.051638 0.005578 0.001263 0.001163 0.004899 20030131200749 2003.0844898 G 250404_185253 VALIDE_24_2 % 52671.50195600 0.057207 0.054240 -0.004722 0.000705 0.000619 0.002600 20030201120249 2003.0863067 G 250404_185253 VALIDE_24_2 + % + % v3 format example: + %#MJD DispEast DispNorth DispUp SigmaEast SigmaNorth SigmaUp CorrEN CorrEU CorrNU yyyy-mm-ddTHH:MM:SS DecimalYear Const Flag DateOfExe GinsVersion PrairieVersion + % 51668.5 0.080276 -2.058358 0.009854 0.000312 0.000439 0.001339 -0.028963 -0.085824 -0.011884 2000-05-04T12:00:00 2000.340164 G 0 250910_120313 25_1 v56 + % 51669.5 0.077154 -2.057207 0.005923 0.000257 0.000371 0.001109 -0.017412 -0.060937 -0.124317 2000-05-05T12:00:00 2000.342896 G 0 250910_120313 25_1 v56 fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); wosystem(sprintf('rm -f %s',fdat),P); + + % Detect format version from first file + format_version = ''; + if ~isempty(F.raw) + first_raw = F.raw{1}; + if strncmpi('http',first_raw,4) + [s,header] = wosystem(sprintf('curl -s -S "%s" | head -20',first_raw),P); + else + [s,header] = wosystem(sprintf('head -20 %s',first_raw),P); + end + if s == 0 + if contains(header,'SPOTGINS SOLUTION [POSITION] v3') || contains(header,'MJD DispEast') + format_version = 'v3'; + elseif contains(header,'SPOTGINS SOLUTION [POSITION] v2') || contains(header,'jjjjj.jjjjjjjj') + format_version = 'v2'; + else + % Try to detect from data columns (fallback method) + if strncmpi('http',first_raw,4) + [s,sample] = wosystem(sprintf('curl -s -S "%s" | grep -v "^#" | head -1',first_raw),P); + else + [s,sample] = wosystem(sprintf('grep -v "^#" %s | head -1',first_raw),P); + end + if s == 0 && ~isempty(sample) + cols = length(strsplit(strtrim(sample))); + if cols >= 17 % v3 has 17+ columns + format_version = 'v3'; + elseif cols >= 11 % v2 has 11+ columns + format_version = 'v2'; + end + end + end + end + end + + if isempty(format_version) + format_version = 'v2'; % default fallback + fprintf('%s: ** INFO ** Could not detect SPOTGINS format version, assuming v2.\n',wofun); + else + fprintf('%s: ** INFO ** Detected SPOTGINS format %s.\n',wofun,format_version); + end + for a = 1:length(F.raw) fraw = F.raw{a}; - cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines + cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines if strncmpi('http',fraw,4) s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); if s ~= 0 @@ -332,19 +380,30 @@ end end - - % load the file + % load the file if exist(fdat,'file') dd = dlmread(fdat); else dd = []; end + if ~isempty(dd) - t = dd(:,1) + 678941.5007; % converts MJD to datenum - d = [dd(:,2:4),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),Orbit - e = dd(:,5:7); + switch format_version + case 'v3' + % v3 format: MJD DispEast DispNorth DispUp SigmaEast SigmaNorth SigmaUp ... + t = dd(:,1) + 678941.5007; % converts MJD to datenum + d = [dd(:,2:4),zeros(size(dd,1),1)]; % DispEast,DispNorth,DispUp,Orbit => E(m),N(m),U(m),Orbit + e = dd(:,5:7); % SigmaEast,SigmaNorth,SigmaUp + + case 'v2' + % v2 format: jjjjj.jj E N U dE dN dU ... + t = dd(:,1) + 678941.5007; % converts MJD to datenum + d = [dd(:,2:4),zeros(size(dd,1),1)]; % E,N,U,Orbit => E(m),N(m),U(m),Orbit + e = dd(:,5:7); % dE,dN,dU + end + e(e Date: Mon, 22 Sep 2025 12:38:56 +0200 Subject: [PATCH 55/68] add in conf file --- CODE/etc/rawformats.conf | 1 + 1 file changed, 1 insertion(+) diff --git a/CODE/etc/rawformats.conf b/CODE/etc/rawformats.conf index 5755fa24..fb9ad382 100644 --- a/CODE/etc/rawformats.conf +++ b/CODE/etc/rawformats.conf @@ -23,6 +23,7 @@ gipsy|GNSS|JPL GIPSY-OASIS .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root direc gipsyx|GNSS|JPL GipsyX .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root directory containing YYYY/FID/*.tdp files globkval|GNSS|MIT GAMIT/GLOBK VAL file||fullpath of directory containing the .VAL file spotgins-enu-v2|GNSS|SPOTGINS solutions - version 2 (<2025-08)||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file +spotgins-enu|GNSS|SPOTGINS solutions - v2&3||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file spotgins-ippp|GNSS|SPOTGINS IPPP time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file gamit-pos|GNSS|MIT GAMIT/GLOBL POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file pbogps-pos|GNSS|PBO GPS POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file From 2e38f406123d9e146846242af51744cb4438745c Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 22 Sep 2025 12:39:10 +0200 Subject: [PATCH 56/68] add header spotgins 2&3 --- CODE/matlab/readfmtdata_gnss.m | 81 ++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index 4d4b769e..15e76fe2 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -40,6 +40,13 @@ % data format: jjjjj.jj E N V dE dN dV yyyymmddhhmmss yyyy.yyyyyyyyy % node calibration: no .CLB file or 4 components (East, North, Up) in meters and (Orbit) % +% format 'spotgins-enu' +% type: SPOTGINS solutions - supports v2 and v3 formats (auto-detection) +% filename/url: P.RAWDATA (use $FID to point the right file/url) +% data format v2: jjjjj.jj E N V dE dN dV yyyymmddhhmmss yyyy.yyyyyyyyy +% data format v3: MJD DispEast DispNorth DispUp SigmaEast SigmaNorth SigmaUp CorrEN CorrEU CorrNU yyyy-mm-ddTHH:MM:SS DecimalYear Const Flag DateOfExe GinsVersion PrairieVersion +% node calibration: no .CLB file or 4 components (East, North, Up) in meters and (Orbit)READFMTDATA_GNSS subfunction of readfmtdata.m +% % format 'spotgins-ippp' % type: GINS IPPP solutions % filename/url: P.RAWDATA (use $FID to point the right file/url) @@ -501,6 +508,80 @@ e = []; end +% ----------------------------------------------------------------------------- +case 'ies-neu' + % format example: + % Time dN eN dE eE dU eU + % 2008.65846986 -0.00502209 0.00647 0.193237 0.01492 0.0314239 0.01846 + + fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); + wosystem(sprintf('rm -f %s',fdat),P); + for a = 1:length(F.raw) + fraw = F.raw{a}; + cmd0 = sprintf('awk ''{ if (NR!=1) {print}}'' >> %s',fdat); + if strncmpi('http',fraw,4) + s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); + if s ~= 0 + break; + end + elseif exist(fraw,'file') + % extracts necessary data + wosystem(sprintf('cat %s | %s',fraw,cmd0),P); + else + fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); + end + end + + % load the file + if exist(fdat,'file') + dd = load(fdat); + else + dd = []; + end + if ~isempty(dd) + t = datenum(dd(:,1),1,1,0,0,0); % date is decimal year + d = [dd(:,[4,2,6]),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),O +0501 2012.3322 3.3 -79.2 -19.6 rrr 3.5 5.8 16.0 -0.2535 Agung.20120501.stacov.point-2017/10/02-13:45:58 + + fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); + wosystem(sprintf('rm -f %s',fdat),P); + for a = 1:length(F.raw) + fraw = F.raw{a}; + if strncmpi('http',fraw,4) + s = wosystem(sprintf('curl -s -S "%s" | awk ''{print $1,$3,$4,$5,$6,$7,$8,$9}'' | sed -e ''s/rrr/0/g;s/ppp/1/g'' >> %s',fraw,fdat),P); + if s ~= 0 + break; + end + elseif exist(fraw,'file') + % extracts necessary data and replaces orbit with 0 (rrr) and 1 (ppp) + wosystem(sprintf('awk ''{print $1,$3,$4,$5,$6,$7,$8,$9}'' %s | sed -e ''s/rrr/0/g;s/ppp/1/g'' >> %s',fraw,fdat),P); + else + fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); + end + end + + % load the file + if exist(fdat,'file') + dd = load(fdat); + else + dd = []; + end + if ~isempty(dd) + ty = floor(dd(:,1)/1e4); + tm = floor(dd(:,1)/1e2) - ty*1e2; + td = dd(:,1) - ty*1e4 - tm*1e2; + t = datenum(ty,tm,td,12,0,0); % date is YYYYMMDD and we force time to 12:00:00 + d = [dd(:,[3,2,4])/1e3,dd(:,5)]; % North(mm),East(mm),Up(mm),Orbit => E(m),N(m),U(m),O + e = dd(:,[7,6,8])/1e3; + e(e Date: Mon, 22 Sep 2025 12:41:53 +0200 Subject: [PATCH 57/68] indentation --- CODE/matlab/readfmtdata_gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index 15e76fe2..effa28ba 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -421,7 +421,7 @@ % ----------------------------------------------------------------------------- case 'spotgins-ippp' - % From J.S. - ITES Strasbourg + % From J.S. - ITES Strasbourg % format example % !yyyymmdd hhmmss yyyy.yyyyyyyyy jjjjj.jj X_position Y_position Z_position dX dY dZ E N V dE dN dV % 20160723 65619 2016.558521561 57592.29 4182067.152057 570976.439258 4765940.539811 0.000611 0.000218 0.000673 -0.006574 -0.008848 -0.014844 0.000205 0.000307 0.000859 From 4772fb39c36fd8c6b4ff5ca8c4836e4c2799e244 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 22 Sep 2025 16:59:13 +0200 Subject: [PATCH 58/68] update comment for clarity in readfmtdata_gnss function --- CODE/matlab/readfmtdata_gnss.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index effa28ba..6a8fa4d9 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -541,7 +541,7 @@ if ~isempty(dd) t = datenum(dd(:,1),1,1,0,0,0); % date is decimal year d = [dd(:,[4,2,6]),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),O -0501 2012.3322 3.3 -79.2 -19.6 rrr 3.5 5.8 16.0 -0.2535 Agung.20120501.stacov.point-2017/10/02-13:45:58 + % 0501 2012.3322 3.3 -79.2 -19.6 rrr 3.5 5.8 16.0 -0.2535 Agung.20120501.stacov.point-2017/10/02-13:45:58 fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); wosystem(sprintf('rm -f %s',fdat),P); From aabfb30d1b29cd4d9d00775303e67c2271c1e104 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 22 Sep 2025 17:04:55 +0200 Subject: [PATCH 59/68] correct usgs-rneu --- CODE/matlab/readfmtdata_gnss.m | 74 ---------------------------------- 1 file changed, 74 deletions(-) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index 6a8fa4d9..5bb40e3b 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -508,80 +508,6 @@ e = []; end -% ----------------------------------------------------------------------------- -case 'ies-neu' - % format example: - % Time dN eN dE eE dU eU - % 2008.65846986 -0.00502209 0.00647 0.193237 0.01492 0.0314239 0.01846 - - fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); - wosystem(sprintf('rm -f %s',fdat),P); - for a = 1:length(F.raw) - fraw = F.raw{a}; - cmd0 = sprintf('awk ''{ if (NR!=1) {print}}'' >> %s',fdat); - if strncmpi('http',fraw,4) - s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); - if s ~= 0 - break; - end - elseif exist(fraw,'file') - % extracts necessary data - wosystem(sprintf('cat %s | %s',fraw,cmd0),P); - else - fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); - end - end - - % load the file - if exist(fdat,'file') - dd = load(fdat); - else - dd = []; - end - if ~isempty(dd) - t = datenum(dd(:,1),1,1,0,0,0); % date is decimal year - d = [dd(:,[4,2,6]),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),O - % 0501 2012.3322 3.3 -79.2 -19.6 rrr 3.5 5.8 16.0 -0.2535 Agung.20120501.stacov.point-2017/10/02-13:45:58 - - fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); - wosystem(sprintf('rm -f %s',fdat),P); - for a = 1:length(F.raw) - fraw = F.raw{a}; - if strncmpi('http',fraw,4) - s = wosystem(sprintf('curl -s -S "%s" | awk ''{print $1,$3,$4,$5,$6,$7,$8,$9}'' | sed -e ''s/rrr/0/g;s/ppp/1/g'' >> %s',fraw,fdat),P); - if s ~= 0 - break; - end - elseif exist(fraw,'file') - % extracts necessary data and replaces orbit with 0 (rrr) and 1 (ppp) - wosystem(sprintf('awk ''{print $1,$3,$4,$5,$6,$7,$8,$9}'' %s | sed -e ''s/rrr/0/g;s/ppp/1/g'' >> %s',fraw,fdat),P); - else - fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); - end - end - - % load the file - if exist(fdat,'file') - dd = load(fdat); - else - dd = []; - end - if ~isempty(dd) - ty = floor(dd(:,1)/1e4); - tm = floor(dd(:,1)/1e2) - ty*1e2; - td = dd(:,1) - ty*1e4 - tm*1e2; - t = datenum(ty,tm,td,12,0,0); % date is YYYYMMDD and we force time to 12:00:00 - d = [dd(:,[3,2,4])/1e3,dd(:,5)]; % North(mm),East(mm),Up(mm),Orbit => E(m),N(m),U(m),O - e = dd(:,[7,6,8])/1e3; - e(e Date: Mon, 22 Sep 2025 17:12:22 +0200 Subject: [PATCH 60/68] add support for 'spotgins-enu-v2' format in readfmtdata_gnss function --- CODE/matlab/readfmtdata_gnss.m | 45 ++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index 5bb40e3b..9dfa905b 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -313,6 +313,51 @@ end %D.ITRF_YEAR = 'ITRF08'; +% ----------------------------------------------------------------------------- +case 'spotgins-enu-v2' + % format exemple + %#jjjjj.jjjjjjjj _____E _____N _____U ____dE ____dN ____dU yyyymmddHHMMSS yyyy.yyyyyyy Const Dateofexe GinsVersion + % 52670.83876160 0.055822 0.051638 0.005578 0.001263 0.001163 0.004899 20030131200749 2003.0844898 G 250404_185253 VALIDE_24_2 + % 52671.50195600 0.057207 0.054240 -0.004722 0.000705 0.000619 0.002600 20030201120249 2003.0863067 G 250404_185253 VALIDE_24_2 + + fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); + wosystem(sprintf('rm -f %s',fdat),P); + for a = 1:length(F.raw) + fraw = F.raw{a}; + cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines + if strncmpi('http',fraw,4) + s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); + if s ~= 0 + break; + end + else + s = wosystem(sprintf('cat %s | %s',fraw,cmd0),P); + end + if s ~= 0 + fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); + end + end + + + % load the file + if exist(fdat,'file') + dd = dlmread(fdat); + else + dd = []; + end + if ~isempty(dd) + t = dd(:,1) + 678941.5007; % converts MJD to datenum + d = [dd(:,2:4),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),Orbit + e = dd(:,5:7); + e(e Date: Mon, 22 Sep 2025 17:15:43 +0200 Subject: [PATCH 61/68] add 'spotgins-enu' format support in readfmtdata function --- CODE/matlab/readfmtdata.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODE/matlab/readfmtdata.m b/CODE/matlab/readfmtdata.m index b553e83f..e9f35f96 100644 --- a/CODE/matlab/readfmtdata.m +++ b/CODE/matlab/readfmtdata.m @@ -65,7 +65,7 @@ case {'miniseed','seedlink','arclink','combined','fdsnws-dataselect'} D(n) = readfmtdata_miniseed(WO,P,N(n),F); - case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-enu-v2','spotgins-ippp','gamit-pos','pbogps-pos'} + case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-enu','spotgins-enu-v2','spotgins-ippp','gamit-pos','pbogps-pos'} D(n) = readfmtdata_gnss(WO,P,N(n),F); case {'hyp71sum2k','fdsnws-event','scevtlog-xml'} From 84300540985ddd3c43abd859cca9253a40296410 Mon Sep 17 00:00:00 2001 From: PiSa on TPX1 Date: Mon, 22 Sep 2025 17:18:12 +0200 Subject: [PATCH 62/68] refactor comments for clarity and consistency in spotgins format handling --- CODE/matlab/readfmtdata_gnss.m | 50 +++++++++++++++++----------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index 9dfa905b..b088bd4a 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -315,16 +315,16 @@ % ----------------------------------------------------------------------------- case 'spotgins-enu-v2' - % format exemple - %#jjjjj.jjjjjjjj _____E _____N _____U ____dE ____dN ____dU yyyymmddHHMMSS yyyy.yyyyyyy Const Dateofexe GinsVersion - % 52670.83876160 0.055822 0.051638 0.005578 0.001263 0.001163 0.004899 20030131200749 2003.0844898 G 250404_185253 VALIDE_24_2 - % 52671.50195600 0.057207 0.054240 -0.004722 0.000705 0.000619 0.002600 20030201120249 2003.0863067 G 250404_185253 VALIDE_24_2 - + % format exemple + %#jjjjj.jjjjjjjj _____E _____N _____U ____dE ____dN ____dU yyyymmddHHMMSS yyyy.yyyyyyy Const Dateofexe GinsVersion + % 52670.83876160 0.055822 0.051638 0.005578 0.001263 0.001163 0.004899 20030131200749 2003.0844898 G 250404_185253 VALIDE_24_2 + % 52671.50195600 0.057207 0.054240 -0.004722 0.000705 0.000619 0.002600 20030201120249 2003.0863067 G 250404_185253 VALIDE_24_2 + fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); wosystem(sprintf('rm -f %s',fdat),P); for a = 1:length(F.raw) fraw = F.raw{a}; - cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines + cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines if strncmpi('http',fraw,4) s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); if s ~= 0 @@ -337,16 +337,16 @@ fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); end end - - - % load the file + + + % load the file if exist(fdat,'file') dd = dlmread(fdat); else dd = []; end if ~isempty(dd) - t = dd(:,1) + 678941.5007; % converts MJD to datenum + t = dd(:,1) + 678941.5007; % converts MJD to datenum d = [dd(:,2:4),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),Orbit e = dd(:,5:7); e(e Date: Mon, 22 Sep 2025 17:33:14 +0200 Subject: [PATCH 63/68] refactor spotgins format handling: update descriptions for clarity and remove v2 case --- CODE/etc/rawformats.conf | 5 ++-- CODE/matlab/readfmtdata.m | 2 +- CODE/matlab/readfmtdata_gnss.m | 46 ---------------------------------- 3 files changed, 3 insertions(+), 50 deletions(-) diff --git a/CODE/etc/rawformats.conf b/CODE/etc/rawformats.conf index fb9ad382..34d189e5 100644 --- a/CODE/etc/rawformats.conf +++ b/CODE/etc/rawformats.conf @@ -22,9 +22,8 @@ winston|EARTHWORM|EarthWorm Winston Wave Server data request||host:port gipsy|GNSS|JPL GIPSY-OASIS .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root directory containing YYYY/FID/*.tdp files gipsyx|GNSS|JPL GipsyX .tdp file|ANTENNA,RECEIVER,XYZ|fullpath of root directory containing YYYY/FID/*.tdp files globkval|GNSS|MIT GAMIT/GLOBK VAL file||fullpath of directory containing the .VAL file -spotgins-enu-v2|GNSS|SPOTGINS solutions - version 2 (<2025-08)||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file -spotgins-enu|GNSS|SPOTGINS solutions - v2&3||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file -spotgins-ippp|GNSS|SPOTGINS IPPP time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file +spotgins-enu|GNSS|SPOTGINS ENU solutions - v2&3||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file +spotgins-ippp|GNSS|SPOTGINS IPPP time series (ITES)||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file gamit-pos|GNSS|MIT GAMIT/GLOBL POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file pbogps-pos|GNSS|PBO GPS POS time series||fullpath of file(s) with bash wildcard facilities, possible $FID, or URL to single file usgs-rneu|GNSS|USGS RNEU text file||fullpath of file(s) with bash wildcard facilities diff --git a/CODE/matlab/readfmtdata.m b/CODE/matlab/readfmtdata.m index e9f35f96..33cd49d2 100644 --- a/CODE/matlab/readfmtdata.m +++ b/CODE/matlab/readfmtdata.m @@ -65,7 +65,7 @@ case {'miniseed','seedlink','arclink','combined','fdsnws-dataselect'} D(n) = readfmtdata_miniseed(WO,P,N(n),F); - case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-enu','spotgins-enu-v2','spotgins-ippp','gamit-pos','pbogps-pos'} + case {'globkval','gipsy','gipsyx','gipsy-tdp','usgs-rneu','ies-neu','ogc-neu','ingv-gps','sbe37-ascii','spotgins-enu','spotgins-ippp','gamit-pos','pbogps-pos'} D(n) = readfmtdata_gnss(WO,P,N(n),F); case {'hyp71sum2k','fdsnws-event','scevtlog-xml'} diff --git a/CODE/matlab/readfmtdata_gnss.m b/CODE/matlab/readfmtdata_gnss.m index b088bd4a..e8ce6611 100644 --- a/CODE/matlab/readfmtdata_gnss.m +++ b/CODE/matlab/readfmtdata_gnss.m @@ -313,52 +313,6 @@ end %D.ITRF_YEAR = 'ITRF08'; -% ----------------------------------------------------------------------------- -case 'spotgins-enu-v2' - % format exemple - %#jjjjj.jjjjjjjj _____E _____N _____U ____dE ____dN ____dU yyyymmddHHMMSS yyyy.yyyyyyy Const Dateofexe GinsVersion - % 52670.83876160 0.055822 0.051638 0.005578 0.001263 0.001163 0.004899 20030131200749 2003.0844898 G 250404_185253 VALIDE_24_2 - % 52671.50195600 0.057207 0.054240 -0.004722 0.000705 0.000619 0.002600 20030201120249 2003.0863067 G 250404_185253 VALIDE_24_2 - - fdat = sprintf('%s/%s.dat',F.ptmp,N.ID); - wosystem(sprintf('rm -f %s',fdat),P); - for a = 1:length(F.raw) - fraw = F.raw{a}; - cmd0 = sprintf('awk ''/^[^#]/ {print}'' >> %s',fdat); % removes header lines - if strncmpi('http',fraw,4) - s = wosystem(sprintf('curl -s -S "%s" | %s',fraw,cmd0),P); - if s ~= 0 - break; - end - else - s = wosystem(sprintf('cat %s | %s',fraw,cmd0),P); - end - if s ~= 0 - fprintf('%s: ** WARNING ** Raw data "%s" not found.\n',wofun,fraw); - end - end - - - % load the file - if exist(fdat,'file') - dd = dlmread(fdat); - else - dd = []; - end - if ~isempty(dd) - t = dd(:,1) + 678941.5007; % converts MJD to datenum - d = [dd(:,2:4),zeros(size(dd,1),1)]; % North(mm),East(mm),Up(mm) => E(m),N(m),U(m),Orbit - e = dd(:,5:7); - e(e Date: Fri, 5 Dec 2025 08:27:27 +0000 Subject: [PATCH 64/68] Add funding informations --- README.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/README.md b/README.md index a636bc5c..e76fbf59 100644 --- a/README.md +++ b/README.md @@ -48,3 +48,9 @@ This program is free software: you can redistribute it and/or modify it under th This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . + +## Fundings + +This program benefits from fundings from IPGP and CNRS + +It has been realized with the support of the Ministère de la transition écologique et de la cohésion des territoires From e57939309480b7816fbf7687f61f6e528a4656d6 Mon Sep 17 00:00:00 2001 From: Jean-Marie Saurel Date: Fri, 5 Dec 2025 08:30:14 +0000 Subject: [PATCH 65/68] Add IRD in funding --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index e76fbf59..8e93e54b 100644 --- a/README.md +++ b/README.md @@ -51,6 +51,6 @@ You should have received a copy of the GNU General Public License along with thi ## Fundings -This program benefits from fundings from IPGP and CNRS +This program benefits from fundings from IPGP, CNRS and IRD It has been realized with the support of the Ministère de la transition écologique et de la cohésion des territoires From 994d912794da23eb01c0dbf8c86329009b746631 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Fri, 5 Dec 2025 13:10:55 +0400 Subject: [PATCH 66/68] update README.md --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 8e93e54b..98a5e940 100644 --- a/README.md +++ b/README.md @@ -51,6 +51,6 @@ You should have received a copy of the GNU General Public License along with thi ## Fundings -This program benefits from fundings from IPGP, CNRS and IRD +This program benefits from fundings from the IPGP, the CNRS and the IRD. -It has been realized with the support of the Ministère de la transition écologique et de la cohésion des territoires +It has been realized with the support of the Ministère de la transition écologique et de la cohésion des territoires. From 0fa5ddf8cba16fa2b22805a5664aac587af1e5fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Fri, 6 Mar 2026 10:36:23 +0400 Subject: [PATCH 67/68] forces the dev version of CODE/perl/lib/Users.pm --- CODE/perl/lib/Users.pm | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/CODE/perl/lib/Users.pm b/CODE/perl/lib/Users.pm index 16f48c73..05b6744e 100644 --- a/CODE/perl/lib/Users.pm +++ b/CODE/perl/lib/Users.pm @@ -666,16 +666,6 @@ sub htpasswd_uncomment { return 0; } - # Adds or update a login/password in the htpasswd file. - # Returns 0 if success, non-zero otherwise. - my $login = shift; # the login to create - my $pass = shift; # the new password to set - my $htpw_opt = _get_htpasswd_encryption_opt(); # options for htpasswd - my $output; # a reference for the output - - # Call htpasswd with the selected option - return htpasswd($htpw_opt, $WEBOBS{'HTTP_PASSWORD_FILE'}, $login, $pass, \$output); -} =head2 htpasswd_verify From 683293aea705ec140519cb1a6caf34a21b9ef996 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Beauducel?= Date: Tue, 10 Mar 2026 11:06:53 +0400 Subject: [PATCH 68/68] fix an issue with horizontal only option for network relative mode (gnss.m) --- CODE/matlab/superprocs/gnss.m | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/CODE/matlab/superprocs/gnss.m b/CODE/matlab/superprocs/gnss.m index dfbacbe3..c234b23e 100644 --- a/CODE/matlab/superprocs/gnss.m +++ b/CODE/matlab/superprocs/gnss.m @@ -40,7 +40,7 @@ % Authors: François Beauducel, Aline Peltier, Patrice Boissier, Antoine Villié, % Jean-Marie Saurel / WEBOBS, IPGP % Created: 2010-06-12 in Paris (France) -% Updated: 2026-03-02 +% Updated: 2026-03-10 WO = readcfg; wofun = sprintf('WEBOBS{%s}',mfilename); @@ -549,9 +549,11 @@ voffset = zeros(1,3); if vrelmode if numel(sstr2num(vref)) == 3 + % fixed mode: E,N,U voffset = sstr2num(vref)*P.trendfact/365250; mode = 'fixed'; else + % network mode: reference station list [kvref,knref] = ismemberlist(split(vref,','),{N.FID}); if ~isempty(vref) && all(kvref) mode = vref; @@ -565,13 +567,15 @@ mode = sprintf('invalid reference "%s"',vref); end else - % auto relative mode: horizontal only (or not) + % auto mode: all network mean mode = 'auto'; - voffset = [mvv(1:2),(~vrelhorizonly)*mvv(3)]; + voffset = mvv; end + % horizontal only (or not) + voffset(3) = voffset(3)*(~vrelhorizonly); end tr = tr - repmat(voffset,numel(N),1); - fprintf('---> Relative mode "%s" - velocity reference = %1.2f, %1.2f, %1.2f %s\n',mode,voffset,P.trendunit); + fprintf('---> Relative mode "%s"%s - velocity reference = %1.2f, %1.2f, %1.2f %s\n',mode,repmat(' (horiz. only)',vrelhorizonly),voffset,P.trendunit); end % --- per node plots
                ⇐$displayMoisCalendrier⇒
                ⇐$displayMoisCalendrier⇒
                ".join("",split(/,/,"$__{'hebdo_weekday_first_letter'}"))."