#!/usr/bin/perl -w # # Name: $OPTHOME/optbin/download-4 # Purpose: part of JGOFS data download package # split data into smaller files, get info file # pkg data and info for download # Dec 98.clc. under development. # # Modification history: $version = "download-4 version 3.4 11 Aug 2016"; # 11 Aug 16 WJS # History file entries for start/end of rename attempt # 17 Jul 15 WJS # User spec of character to replace # in "multiple small file" file names # [begin download-4 v 3.4] # 6 Sep 14 WJS # Try to do a BETTER job of "clean up object specs that had prepended commas", esp # since it's this code that made most of them! # [begin download-4 v 3.3a] # 26 Dec 12 WJS # Mod check_data into a line counter. See its text for more # 3 Dec 12 WJS # Finish recode to reflect removal of do_shell_command from # wjs_web_perl_utilities.pl. Interesting that we didn't do all of them when # we did the first (18 mos ago). Also interesting that such a problem (non-existent # subroutine) doesn't get diagnosed by the code. Not perl's fault - it sends # a message to stderr. Yet a whole new level of error checking that's not done ... # Did some work to clean up object specs that had prepended commas in sel/proj list, # double sel/proj lists, empty sel/proj lists, etc # Got rid of mysterious "using extended URL" message that printed in httpd logs # and did NOT include a nice string like "TESTING" # Don't include server port number in "From:" email address # 4 Feb 12 WJS # Move fundamental checks (eg, existence) for various utilities from # here to download-1. Among other things, this allows us to compensate # for removal of non-gzip compression utility on gb11 # Yet another try at letting env vars drive matlab choices # 27 Dec 11 WJS # Bug fix: 16 Oct 10 fix (probably) introduced new error due # to the $maxlev stuff described next. Try to fix the new thing # while keeping the old thing fixed # download-3 passed a confusing parameter called $maxlev that # wasn't actually needed. Re-create its meanings from the other # info it duplicated (or so I intend!). Comments may still refer to # maxlev. Note that $maxlev NEVER meant "number of JGOFS # levels" or "maximum JGOFS level" (although it meant one of those # in download-2 and part of download-3. Elsewhere, after its meaning # changed to those described below, it may well # have coincidentally matched one of the JGOFS level numbers) # Here are the meanings (I hope!) # $maxlev == 0 User asked for "onebigfile". # Get from bulk formvar # $maxlev > 0 User asked for "moresmallfiles" and was # offered a per-level menu for all levels except the # "bottom" level. Menu items were variables at that level. # Thus, given an N-level object, the user was offered N-1 # menus. User may have picked any subset of these N-1. # The empty subset is rejected before it gets here. # $maxlev is the size of the subset; thus 1<= $maxlev <= N-1. # Get from size of @determine array # Since these variables determine the splitting, they are # referred to as the "determinants" # $maxlev == 1 is a special case in the splitting logic. # I have not studied any of the splitting logic to see why it needs to # be special. # Get rid of some global variables # Fix bug: @array eq "" does NOT check for empty array # [begin download-4 v 3.3] # 10 Aug 11 WJS # Change "Plotting and ..." to "Download and ..." # 24 Jul 11 WJS # Per-var-value file names need to be protected against containing # shell chars since the var-values can contain shell chars. # Directory names that theoretically have the same problem don't, because # the code uses the perl mkdir function, which does not go to the shell. # Not sure about cleanup of said directories, done w/some perl library # function called rmtree . # While in here, remove do_shell_command in favor of backtick # [begin download-4 v 3.2b] # 16 Oct 10 # Bug fixes to sub getallvalues for the case of a l-level object # Problem first noticed (but not fixed!) in 2004, apparently # [begin download-4 v 3.2a] # 7 Feb 10 WJS # Code to handle info= field # Code to call info with a data= extended URL # Better form var check # Don't report success for info download in various places if # in fact the attempt to download failed # 14 Jan 10 WJS # Put user-supplied file extensions on packaged files. Since # that will now be coming from download-3, have download-3 pass us # .matlab and .netcdf if appropriate, and remove that code from here # Put in code that will use an info= extended URL field and which # will pass a data=extended URL field to that info. The former should # have been happening all along; latter might help out BCO-DMO info # source. Since nobody is supplying an extended URL at the moment, # we can experiment. As part of this, $getinfo referred to in previous # comments has been better named to $OOserverinfo # Check for user-supplied file name/extension consisting of all # whitespace (previous logic checked for empty string) # 25 Apr 09 WJS # Mod of 17 Jan left all refs to $getinfo unused except its # defining reference. This gave an "only used once" error. # In case we eventually want to go back and use $getinfo, just put # in dummy command to get rid of err msg # [begin download-4 v 3.2] # 21 Jan 09 WJS # Clean up an unused branch after 17 Jan mod # 17 Jan 09 WJS # Directory that info was using had been altered to point to relevant # jgofsopt subdirectory. Accordingly, info never found anything. # 28 Nov 08 WJS # 1 Nov mods in download-1 can destroy dobjext. Add code # 1 Nov 08. WJS # Parametrize tracefile but leave it pointed to STDERR # Allow for possibility that dobject has appended arg list # [begin download-4 v 3.1] # 9 Aug 08. WJS # Issue non-terminating diagnostic if we can tell email addr bad # Replace split in scalar context - gives diagnostic # [begin download-4 v 3.0a] # 9 May 08. WJS # Many typos, which makes me suspect testing of previous versions! # Log with $version rather than script name # Change listm_user to list_options # Change version to 3.0 to match other pieces of download which are # getting a version for the first time. See download-3 comments # for why 3.0 # [begin download-4 v 3.0] # [older comments removed to download-X_tmp.comments Jul 15] # [older comments removed to download-X_tmp.comments Dec 04] # # ===================================================================== require "cgi-lib.pl"; require "wjs_web_perl_utilities.pl"; use File::Copy; use File::Path; use FileHandle; use LWP::Simple; MAIN: { # Set stdout to flush after every record. Should allow user # to wait for download or leave while it's running autoflush STDOUT; # Run bulk of program as a child process. Idea is that httpd # server kills cgi process it started when server discovers browser # has broken connection. However, it does not kill that process' # children. This (which is the heart of the deferred download # idea) is based strictly on observation of the behavior of the # Apache web server on gb1 in Dec '04 $! = $? = 0; $child_pid = open (CHILD_HANDLE,"-|"); defined($child_pid) || &uh_oh ("Could not run download as child process\n\$!=$!;\$?=$?\n"); if ($child_pid != 0) { # Parent process - copy whatever we get to STDOUT $! = 0; while ( defined($rec = ) ) { print $rec; } $status = $!; # Not going to worry about status of close close CHILD_HANDLE; ($status == 0) || &uh_oh ("Error reading from download child process $child_pid\n" . "\$!=$!\n"); exit; } &printheader(); # Set up environment. Assume .pl routine is in our directory $build_opt_env = "./build-opt-env.pl"; &check_r_access($build_opt_env); do $build_opt_env; $tracefile = "STDERR"; $objarg_sep = ','; # # set up some variables # $protocol = "http://"; $logfilename = "README"; # download status log file $historyfilename = "HISTORY"; # another log file w/more emphasis on # processing & less on data $pid = $$; $dwnld_id_stamp = "DWNLD_$pid"; $dwnld_err_stamp = $dwnld_id_stamp . "_ERR"; # color palette $credhi = "indianred"; $chdrbar1 = "skyblue"; $cgobar = "mediumaquamarine"; $dbasemgr = "$ENV{'SERVER_ADMIN'}"; # env var defined in web server setup, # not JGOFS system print $tracefile " $dwnld_id_stamp: using script: $version \n"; $now = localtime() . "\n"; print $tracefile " $dwnld_id_stamp: $now \n"; # # These variables set by makefile from ENVars at install time # $jgtopdir = $ENV{'JGOFSDIR'}; # top of JGOFS tree $jgscdir = $ENV{"JGSCRIPTDIR"}; # where are CGI scripts? $webimages = $ENV{'BUTTONIMAGESDIR'}; # where are web images? $OOserverinfo = $ENV{"INFOSERVER"}; # data doc file retrieval system # Note that this is the info for the OOserver itself # It is NOT the info for the data object being dealt with $tempdir = $ENV{"USETEMPDIR"}; $jgtopdir = &abs_filespec($ENV{'JGOFSDIR'},"Env var JGOFSDIR"); $jgbindir = "$jgtopdir/bin"; # # # which archive and compression (tar,compress,zip) programs to use # $bundle = "$ENV{'TARPROG'} cf"; $pkgtype = ".tar"; $comp = $ENV{'UNIXCOMPRESS'}; $compext = ".Z"; $compgz = $ENV{'GNUCOMPRESS'}; $compgzext = ".gz"; $pcbundle = "$ENV{'ZIPPROG'} -r"; $pcpkgtype = ".zip"; $pccomp = ""; $list = "$jgbindir/list"; # which list program to use $renamer_script = $ENV{'OPTHOME'} . '/' . $ENV{'OPTRUNDIR'} . "/repl_char_in_filenames_via_rename.pl"; # matlab & netcdf image files defined where used $email_sender = $ENV{"MAIL_SENDER"}; # Note that ENV{"OPTIONSERVER"} is NOT necessarily the same as below # It might be the production server and the stuff below will return # value for a test server if that's what's running at the moment $jg_url = "http://$ENV{'MYADDR'}$ENV{'JGSCRIPTDIR'}"; $optsmenu = "$jg_url/otheropt"; $download_inquiry_url = "$jg_url/download_inquiry.pl"; $no_goback_url = "http://" . $ENV{"MYADDR"} . "/no_download_goback.html"; ############################################################# # # Read in all the variables set by the form # &ReadParse(*form_info); # # get information passed in form_info hash # Note that this amounts to env vars from build # $dobject = &get_form_var('dobject','REQ','OBJSPEC'); $dobjext = &get_form_var('dobjext','REQ','OBJSPEC'); # jgofs object string with extension $dispobj = &get_form_var('dispobj','REQ','OBJSPEC'); # jgofs object+(QS) for display $urlobjx = &get_form_var('urlobjx','REQ','OBJSPEC'); $subsels = &get_form_var('subsels','OPT','NOCHECK'); $subsdisp = &get_form_var('subsdisp','OPT','NOCHECK'); $dobj_infoserver = &get_form_var('dobj_infoserver','OPT','OBJSPEC'); $format = &get_form_var('format','REQ'); $filesize = &get_form_var('bulk','REQ'); $compress = &get_form_var('compress','REQ'); $pkgname = &get_form_var('pkgname','REQ'); $customname = &get_form_var('customname','OPT'); $datafile_ext = &get_form_var('datafile_ext','OPT'); $custom_datafile_ext = &get_form_var('custom_datafile_ext','OPT'); $varvalsepchar = &get_form_var('varvalsepchar','OPT'); $defvarvalsep = &get_form_var('defvarvalsep','REQ'); $email_address = &get_form_var('email','OPT','NOCHECK'); # email address ($status,$objnode,$objdir,$objnameonly,$objargs) = &parse_object_spec($dobject); ($status eq "OK") || &uh_oh ("Problem parsing obj spec $dobject\n" . "Problem = $objnode"); $orig_objdir = $objdir; if ($objargs) { # Undo whole qs adjusting thing in case we have a do-over from the # beginning. $orig_subsels = $objargs; $subsels && ($orig_subsels .= $objarg_sep . $subsels); $objnsels = $dobject; chop $objnsels; $objnsels .= $objarg_sep . $subsels; } else { $orig_subsels = $subsels; $objnsels = "$dobject($subsels"; # object(sub,sels ; no final paren } $user_confirm = &get_form_var('confirm','REQ'); $list_options = &get_form_var('list_options','OPT','SPACEOK'); $tempdir = $ENV{'USETEMPDIR'}; $utility = "download"; # tmp = tmpdir/client_host/download # # make full options menu specifier with data object [and subsels] # $back_to_opts = ($dobjext eq "NO_VALID_DOBJEXT") ? $no_goback_url : "$optsmenu"."$dobjext"."?"."$subsels"; print < Data download - final form.

Data download - final form

Current object is: $dispobj

If you wish, you may leave this page and come back later for your download.
Use the download inquiry link on the "Download and Other Operations" menu at that time.
The process ID for this download is $pid

ENDOFTOP if ($email_address) { $status = &pre_validate_email($email_address); ($status eq "OK") || print " *** WARNING: will not be able to send email because of ". "following problem
\n\t$status
\n" . " ... Continuing with download
\n"; } # get user selected name for packaged datafile $customname && ($pkgname = $customname); $n_underscores = ($pkgname =~ s/\s+/_/g); # get user supplied file extension for files being packaged $custom_datafile_ext && ($datafile_ext = $custom_datafile_ext); $n_ext_underscores = ($datafile_ext =~ s/\s+/_/g); # The # under discussion is used in get0values et al. It has been hardcoded in here # "since the beginning". In fear of what would happen if we change it, we leave it in, # and, after the fact, change the filenames that contain it (if user asked, of course) # $defvarvalsep is a sanity check. It's set in download-3 ($defvarvalsep eq '#') || &uh_oh ("Internal inconsistency: \$defvarvalsep must be #. Its value is -->$defvarvalsep<--"); ($varvalsepchar eq "") && ($varvalsepchar = $defvarvalsep); $renaming_files = ($filesize eq "moresmall") && ($varvalsepchar ne $defvarvalsep); if ($user_confirm eq "yes") { # # user selections have been made and confirmed ... let's do it ... # print $tracefile " $dwnld_id_stamp: Working on object: $dispobj \n"; print $tracefile " $dwnld_id_stamp: dobject: $dobject \n"; print $tracefile " $dwnld_id_stamp: dispobj: $dispobj \n"; print $tracefile " $dwnld_id_stamp: objnsels: $objnsels \n"; # # if user has assigned a value to the level, use it # $levelparams = &get_form_var('levelparams','OPT','NOCHECK'); @determine = split("%",$levelparams); # # make a new directory tree # flag determines if we remove this directory tree if it already exists # $flag="no"; $hostdir = make_directory($tempdir,$utility,$flag); $flag="yes"; $objdir = make_directory($hostdir,$objnameonly,$flag); $flag="no"; $url_of_objdir = $ENV{'USETEMPADDR'} . "/$utility/$objnameonly"; # # create README & HISTORY files to keep track of progress during processing # $logfile = "$objdir/$logfilename"; $historyfile = "$objdir/$historyfilename"; # $badcreate is TRUE if we fail to create file ($badcreate = &create_readme) && print $tracefile " $dwnld_err_stamp: could not create $logfile: $badcreate \n"; ($badcreate = &create_history) && print $tracefile " $dwnld_err_stamp: could not create $historyfile: $badcreate \n"; &add_history ("PID",$pid, "OBJECT",$dobject, "OBJECT_W_SELECTIONS",$dispobj, "OPTIONS",join(',',$format,$filesize,$compress)); $url_of_logfile = "$url_of_objdir/$logfilename"; # # Need to, as it says, fool w/library path some time if we're doing matlab # Why not do it now? # if (($format eq "matlab") || ($format eq "matlab5")) { $library_path_name = "LD_LIBRARY_PATH"; # List of possible matlab libs just in case multiple ones are in # LD_LIBRARY_PATH. No big deal if this not kept up to date (tried to # have this come from build-env.pl, but just not worth it - Aug 05) $ENV{'MATLABLIBDIR'} && push (@matlablib_list, $ENV{'MATLABLIBDIR'}); $ENV{'MATLAB5LIBDIR'} && push (@matlablib_list, $ENV{'MATLAB5LIBDIR'}); $lib_env_var = uc($format) . "LIBDIR"; $lib_file = ($ENV{$lib_env_var}) ? $ENV{$lib_env_var} : ""; if ($lib_file) { ($status1,$status2,$new_lib_path) = &add_file_to_path_string($library_path_name, $lib_file, @matlablib_list); } else { $status1 = "NG"; $status2 = "UNDEFINED_" . $lib_env_var; } if ($status1 eq "OK") { $ENV{$library_path_name} = $new_lib_path; } else { &add_note ("", " Cannot seem to find $format library $lib_file", " Possible problem: $status2", " Proceeding in case correct library has been defaulted somehow", " Check resulting matlab file for version, if appropriate", ""); } } # # The number of determinant parameter levels (maxlev) controls flow. # If there are 0 levels, user wants all data in one single file, so # we just drop right down to make_files subroutine. # However, for multiple levels, we need to get parameter lists: # If only 1 level, force one call to getallvalues . # If 2 levels, only need to getallvalues once. # If more than 2 levels, do getallvalues (#levels - 1) times # We must get all values at each user-selected level, but # we do level 0 and level 1 in first pass, level 1 and 2 next # and so on, so #passes = #levels-1 or maxlev-1 # Note: I could probably create a %filename{$selection} of filenames # indexed by selection string, but this could be done later # As we progress, build param#value strings # &add_note ("Locating data files. Report any errors here: "); @listovals = (); if ($filesize eq "moresmall") { # user wants data divided into multiple (moresmall) files # get a list of all values at [determinant] level 0 (not JGOFS level 0) @listovals = &get0values; # # Abort if we don't have a list of values; no point in continuing if (@listovals == 0) { &add_note ("\nSorry, unable to find any data for $dispobj"); &uh_oh ("Unable to find any data for $dispobj"); } $thislev=1; # See commented out reference to $pvalkey, below. Until we have the # guts to throw that out, we need to keep the next line around # $param=$zp; if ( @determine == 1 ) { # number of [determinant] levels = 1 # so we force thislev to be zero because we only have one level, # getallvalues and nullify the higher level selection criteria # [As of v 3.3, don't need to getallvalues. Use the &get0values # listovals set above. $thislev=0; } else { # number of levels > 1 while ( (@determine - $thislev) > 0 ) { @nextvals = (); foreach $val (@listovals) { # make subdirectories as we go through selection list $temp = $val; ($datadir = $temp) =~ tr/+/\//; &make_directory($objdir,$datadir,$flag); # [Note: orig code, below, saved return val of make_directory but did # not use it here or in production OOserver. WJS 12 Dec 04] # $fulldirec = &make_directory($objdir,$datadir,$flag); @newvals=&getallvalues($val); # if @newvals is null (due to problem in &getallvalues) skip ahead # to next $val in @listovals if (@newvals) { @nextvals = (@nextvals,@newvals); } } $thislev++; @listovals = @nextvals; } } # # Check whether we have data to process; if not, note in log and abort # if (@listovals == 0) { &add_note ("\nSorry, unable to find any data for $dispobj"); &uh_oh ("Unable to find any data for $dispobj"); } } # # All seems OK - make the data file(s) # # should give user a progress report of data packaging status; frame? # Something like: # Creating individual files for $objnameonly data, please wait . . . # Packaging ... # &add_note ("\nOK ... START MAKING DATA FILES ... "); $renaming_files && &add_note ("(Note: the first # in the file names below will be changed to " . "$varvalsepchar in the names of the downloaded files)"); $data_status = &make_files; if ($data_status) { $status_msg = $data_status; $err_warning = "WARNING: data retrieval error"; } else { $err_warning = $status_msg = ""; } ($msg = $status_msg) && ($msg = "ERROR: $status_msg"); &add_history("END_DATA_EXTRACTION",$msg); # # # # # # # # All data files have been processed. # # # # # # # # copy the documentation info file for this data object # ($infostatus,$infoURL) = ©_data_doc; $selection = ""; &add_note(" "); $msg = ($infostatus eq "OK") ? "Documentation info file written." : "*** Could not get documentation from $infoURL"; &add_note($msg); # # bundle up all the files for this object # &add_note("$dispobj data download request completed:"); &add_note(scalar localtime()); &add_history("B4BUNDLE_CALL",""); $datapkgfilename = &bundle_em_up; $url_of_datapkg = "$url_of_objdir/$datapkgfilename"; &add_history ("END_OF_BUNDLING_AND_COMPACTION","", "DOWNLOADURL",$url_of_datapkg, "READMEURL",$url_of_logfile, "INFOURL",$infoURL); # Would prefer to have next bunch of stuff after web display of # download URL. In particular, this would mean that finish time # would be time after user actually got data. However, in deferred # case (where STDOUT is no longer available), it appears that this # process dies during attempt to do web display, and therefore does # not write the "normal conclusion" message we expect. (This despite # tests that made it appear that writing to a non-existent STDOUT # made no difference - sigh) # tell user to download packaged file via email $email_address && &add_history("EMAIL_ATTEMPT", &send_email($email_address, "Download of $objnameonly data available at URL below", "$download_inquiry_url?process_id=$pid") ); $now = localtime() . "\n"; print $tracefile "\nData $dwnld_id_stamp: $dispobj request completed\n"; print $tracefile "Data $dwnld_id_stamp: at $now \n"; print $tracefile "Data $dwnld_id_stamp: === end of script $0 === \n\n"; &add_history("EOJ"); # # tell user to download packaged file # $pkgname_warning = ($n_underscores == 0) ? "" : "Note: whitespace in package name was replaced by underscores
"; $file_ext_warning = ($n_ext_underscores == 0) ? "" : "Note: whitespace in file extensions was replaced by underscores
"; print <

Download your packaged $objnameonly data now.

$pkgname_warning $file_ext_warning

$err_warning

$status_msg ENDOFTEXT1 if ($infostatus eq "OK") { print < information file for your data set is included in package
ENDOFTEXT2 } print < README file associated with your data set is included in package

Return to Download and Other Options menu


This is a trial system. Please help us improve it by giving us some feedback. We would like to know what you liked/didn't like, what worked/failed. Please consider sending us some mail. Thank you. ENDOFTEXT3 } else { # # user confirm indicated a problem ... find out what they want to do # &bad_confirmation } # # Close html file cleanly. # print &HtmlBot; # Avoid "1 time use" diagnostic for various unused but seemingly # innocuous variables. Deliberately not addressing this problem # for more suspicious variables. undef $chdrbar1; undef $cgobar; undef $webimages; undef $OOserverinfo; exit; } sub get0values { my ($status,$clean_obj_spec,$save_rec_sep); # # $objnsels comes in w/an unclosed (. If there's nothing after that # (, get rid of it (for the call to &get_column). If there IS something # after it, add a closing ) # $clean_obj_spec = $objnsels; $save_rec_sep = $/; $/ = '('; ((chomp $clean_obj_spec) == 0) && ($clean_obj_spec .= ')'); $/ = $save_rec_sep; $zp = $determine[0]; ($status,@zerovals) = &get_column($list,$clean_obj_spec,$zp); ($status eq "OK") || &uh_oh($zerovals[0]); # # Remove duplicates from zerovals array # @zerovals = &unique_vals(@zerovals); # # # Build selection list # Add a param#value pair to selection list for every item in the list # foreach $item (@zerovals) { $paramlist = "$zp"."#"; push(@sel_list,"$paramlist"."$item"); } return (@sel_list); } sub getallvalues { # the previous selection list of parameters is passed in, one at a time my $presel=pop @_; ######## if ( $maxlev == 1 ) { ######## @vallist = @zerovals; ######## return (@vallist); ######## } # change parameter list from param#value back into # param0=val0,param1=val1 format # [Note: $presel possibly undefined in some circumstances as of 12 Dec 04] # [Regarding note: getallvalues called w/null arg list in 1-level case # Presumably that was the undefined; hence the code move here... and # a diagnostic for the future. 16 Oct 10 # ] # [Note regarding note regarding note: Nice idea, but a bug. zerovals is # just data; required return is set of var#datum strings or some such. # Most recent, presumably better, analysis is that "1-level case" need not # come in here at all. BTW, it never was "1 JGOFS level" anyway; it was # "user picked 1 'split by' variable, although offered a 'split by' variable # for each level excluding the 'bottom' level. WJS 26 Dec 10] $presel || &uh_oh("Internal error: empty selection list in multi-level download"); ($selection = $presel) =~ tr/#+/=,/ ; # # OK ... maxlev is > 1, so we still need to get more info # remember to remove all leading whitespace from params (don't know where # this is done. Addition of -z to list command (in get_column), however, # removes any whitespace previously added by list. WJS Apr 04) # $d=$determine[$thislev]; ($status,@vallist) = &get_column($list,"$objnsels,$selection)",$d); &uh_oh($vallist[0]) unless ($status eq "OK"); # # Remove duplicates from vallist array # @vallist = &unique_vals(@vallist); # # keep the values for each parameter in a hash of lists (arrays) # Need to make a hash of vallist arrays. See Camel book pg 266-268 # Note: key modified to be param+value (ie. leg+1 = leg1) otherwise # if duplicate value found at different level, higher level # would replace previous level at that value (station1 over leg1) # Also, need to save selection list from each level parameter # How do I build param_list for lev 0 -> maxlev-2 when maxlev > 2 ? # # Next 2 lines commented out. As of 12 Dec 04, # $which undefined, here & in production server # However, $keep is unused, which might explain why $which not # causing trouble! # $pvalkey = "$param"."_"."$which"; # $keep{$pvalkey} = [ @vallist ]; # # Build selection list # Add a param#value pair to selection list for every item in the list # $paramlist = "$presel"."+"."$d"."#"; @sel_list = (); foreach $item (@vallist) { push(@sel_list,"$paramlist"."$item"); } return (@sel_list); } sub make_files { @all_selections = @listovals; if ( $filesize eq "onebig" ) { # # This can probably be combined into one operation regardless of # one vs multifile, but for initial testing phase, keep em separate ... (clc) # user requests all data in single data file # $filename = "$objnameonly"; ($datafile_ext ne "EMPTY_FILE_EXTENT") && ($filename .= '.' . $datafile_ext); $errfilename = "$objnameonly.err"; $fullfile = "$objdir/$filename"; $fullerrfile = "$objdir/$errfilename"; print $tracefile " $dwnld_id_stamp: create $filesize data file: $fullfile \n"; print $tracefile " $dwnld_id_stamp: for $dispobj \n"; # # write the data to a file & log # lines into download log # &write_data ( &make_complete_obj_spec_1($objnsels,""), $fullfile,$fullerrfile); &add_note ("... counting records in $fullfile"); &add_note ("... " . &count_lines($fullfile) . " lines of data in $fullfile. \n"); } else { # user requests data divided into multiple (moresmall) data files; # make data files (directory hierarchy already exists) # foreach $selection (@all_selections) { $selection =~ s/^\+//; # remove leading + (maxlev=1) $temp = $selection; # make filename and selection list from param#value pairs ($filename = $temp) =~ tr/+/\//; # replace + with / $selection =~ tr/#+/=,/; # replace # with = and + with , ($datafile_ext ne "EMPTY_FILE_EXTENT") && ($filename .= '.' . $datafile_ext); $fullfile = "$objdir/$filename"; $fullerrfile = "$objdir/$filename.err"; $obj_spec = &make_complete_obj_spec_1($objnsels,$selection); print $tracefile " $dwnld_id_stamp: list $obj_spec \n"; print $tracefile " $dwnld_id_stamp: to $fullfile \n"; # # write the data to a file & log # lines into download log # &write_data ($obj_spec,$fullfile,$fullerrfile); &add_note ("... " . &count_lines($fullfile) . " lines of data in $filename. \n"); } } return; } sub write_data { my ($listobj,$datafile,$errfile) = @_; my ($command); my ($results,$exit_status,@status_info); # # Use the list program to get data listing (or use matlab/netcdf conversion # program to get a matlab/netcdf file) # list doesn't return bad status if &x error, # but it does exit list [list 1.6 (assumed in download 1.2) should return bad # status for all errors]. # Errors go to STDOUT [also to -errout destination as of list 1.6. # However, parsing errors due to malformed list command do # NOT go to -errout (nor do they contain &x)]. # Must capture errs to a file # otherwise they cause a "malformed header from script" error that generates # an httpd "500 Internal Server Error" preventing download-4 screen from being # displayed. Send STDOUT to $datafile too, so error msg ends up in file and # user is aware there was an error. (Not sure if this is true if one # uses CgiDie (via quit). I think that program prints enough html to # avoid 500 errors in all circumstances) # &add_note ("... creating: $filename"); &add_note ("... for: $listobj"); # If we are doing a per-var-value download, file names include var # values, which can include shell chars. Enclose them in quotation marks # Obj specifier has always had this problem $datafile = '"' . $datafile . '"'; $errfile = '"' . $errfile . '"'; $listobj = '"' . $listobj . '"'; if ( ($matlab_version) = ($format =~ /^matlab(.*)/) ) { $makemat = $jgbindir . "/makemat" . $matlab_version; &check_x_access($makemat); $command = "$makemat $listobj > $datafile 2> $errfile"; } elsif ($format eq "netcdf") { $makenetcdf = $jgbindir . "/makenetcdf"; &check_x_access($makenetcdf); $command = "$makenetcdf -maxwidth $listobj $datafile > $errfile 2> $errfile"; } else { $command = "$list -errout $errfile $list_options $listobj > $datafile"; } ($results,$exit_status,@status_info) = &backtick($command); ($exit_status == 0) && return; # Sigh. "It" didn't work. Orig code used do_shell_command and # do_shell_command would just quit, so, for now, let's just do that # Considering all the stdout and stderr redirection in $command, don't # see how we would get much back in $results ($results) ? &uh_oh (&format_backtick_return_status ($command,$exit_status,@status_info, "return from command = $results") ) : &uh_oh (&format_backtick_return_status ($command,$exit_status,@status_info) ); # Not that we will be here to return ... return; } sub count_lines { # # check file for errors; report total number of data records in file # Now (download 3.3) just a record counter, since all the data writers # (list, makemat, makenetcdf) exit w/error status, and write_data # (above) will exit as a result). Rewrite to return record count as # function value and die if error in calculating the count. # Other issues: # 1) 2nd parameter ($errfile) never used # 2) Old, bad read error processing replaced (MUST use perl eof function # to distinguish between EOF & read error ... but after 5+ years of # being wrong about this, feel free to investigate the new assertion) # 3) $prevln not initialized, but it's not in here any more # 4) Reported $? in case of a close error # 5) Sometimes ID'ed things w/global file name instead of file name received as # argument # my ($datafile,$dummy) = @_; my ($nrec); ($datafile && (! $dummy)) || &uh_oh("Internal error: count_lines called w/wrong # args"); open (FLIN, "< $datafile") || &uh_oh ("Error opening $datafile for read : $!"); $nrec = 0; while ( ! eof(FLIN) ) { $! = 0; if (defined ()) { $nrec ++; } else { &uh_oh ("... Error reading $datafile after record $nrec : $!"); } } $! = 0; close (FLIN) || &uh_oh ("... Error closing $datafile after record $nrec : $!"); # return $nrec; } sub unique_vals { my @list = @_; # Remove duplicates from an array, order doesn't matter; # see Perl Cookbook (Bighorn Sheep book) pg. 102 # Extracting unique elements from a list (straightforward method - # slower but more easily understood) %seen = (); @uniq = (); foreach $item (@list) { unless ( $seen{$item} ) { # we have a unique one; keep it $seen{$item} = 1; push(@uniq, $item); } } return @uniq; } sub make_directory { my ($parent, $dirname, $cleanup) = @_; my ($dir); umask(022); # # check that the parent string has no slash at end $tmp = $/; $/ = '/'; chomp $parent; $/ = $tmp; $dir = "$parent/$dirname"; # # if it's cleanup time and this directory already exists, # get rid of it and entire tree. rmtree is in "File::Path" # Treatment of errors unknown. In particular it does NOT return a status if ( ($cleanup eq "yes") && (-d $dir) ) { eval { rmtree($dir) }; $@ && print $tracefile "$dwnld_err_stamp: rmtree $dir failed: $@\n"; } # # mode used by mkdir looks at lowest 9 bits (-e $dir) || mkdir ($dir,493) || print $tracefile " $dwnld_err_stamp: mkdir $dir failed: $!\n"; return $dir; } sub bundle_em_up { chdir "$objdir"; # Change #s in names of downloaded files if user asked if ($renaming_files) { &add_history("BEGIN_FILE_RENAME",""); ((-e $renamer_script) && (-r _)) || &uh_oh ("No access to $renamer_script - either file does not exist or cannot be read"); $command = "perl -w $renamer_script $varvalsepchar"; ($results,$exit_status,@status_info) = &backtick("$command"); print $tracefile " $dwnld_id_stamp: doing: $command \n"; if ($exit_status != 0) { # Don't expect anything in $results. Don't expect to come back here to # die, either. ($results) ? &uh_oh (&format_backtick_return_status ($command,$exit_status,@status_info,"return from command = $results") ) : &uh_oh (&format_backtick_return_status($command,$exit_status,@status_info) ); die ("Unexpected return from &uh_oh after failed download-4 moresmallfiles renaming"); } &add_history("END_FILE_RENAME",""); } # # determine which archiving and compression routines to use # if ( index($compress,"tar") > -1 ) { # use UNIX type utilities # UNIX compress selected by default (use ./* to avoid warning msg) $all = "./*"; if ( $compress eq "targz" ) { $comp = "$compgz"; $compext = "$compgzext"; } else { ($compress eq "tar" ) && ($comp = ""); } } else { # use PC/Mac type utilities $all = "."; $bundle = "$pcbundle"; $pkgtype = "$pcpkgtype"; $comp = "$pccomp"; } # # OK ... do bundle and optional compression # $tarfile = "$pkgname"."$pkgtype"; $command = "$bundle $tarfile $all"; print $tracefile " $dwnld_id_stamp: doing: $command \n"; &add_history("BUNDLE_COMMAND",$command); # stdout redirect is not supposed to have anything useful, I guess. Output file # is not referenced again in any OOserver perl file (incl this one). File is not # always empty. For example, it may include per-file zipping commentary. Output file # IS included in what's finally sent to user ($results,$exit_status,@status_info) = &backtick("$command > bundle.out"); &add_history("BUNDLE_STATUS",$exit_status); if ($exit_status != 0) { # Don't expect anything in $results. Don't expect to come back here to # die, either. ($results) ? &uh_oh (&format_backtick_return_status ($command,$exit_status,@status_info, "return from command = $results") ) : &uh_oh (&format_backtick_return_status ($command,$exit_status,@status_info) ); die ("Unexpected return from &uh_oh after failed download-4 bundling"); } $fnlpkg = "$tarfile"; # compress archive file if user requested it if ($comp) { $command = "$comp $tarfile"; $compfile = "$tarfile"."$compext"; print $tracefile " $dwnld_id_stamp: doing: $command to make $compfile \n"; # Comment above about "bundle.out" is also valid for "compress.out" ($results,$exit_status,@status_info) = &backtick("$command > compress.out"); if ($exit_status != 0) { # Don't expect anything in $results. Don't expect to come back here to # die, either. ($results) ? &uh_oh (&format_backtick_return_status ($command,$exit_status,@status_info, "return from command = $results") ) : &uh_oh (&format_backtick_return_status ($command,$exit_status,@status_info) ); die ("Unexpected return from &uh_oh after failed download-4 compression"); } $fnlpkg = "$compfile"; } print $tracefile " $dwnld_id_stamp: pkgd data: $objdir/$fnlpkg \n"; return $fnlpkg; } sub copy_data_doc { my ($status,$ext_URL); # copy the info (documentation) file for this data object # Note this cannot be done in general. No reason that # info for object lives on node that serves its data. Need # infoserver part of extended URL, lost by time we get to OOserver. chdir "$objdir"; $docfile="$objnameonly".".htm"; # Feb '10 info, etc status # There are 2 sets of problems. First, which info to use; and 2nd, # what to pass it. OOserver was never designed to use info, but downloader # did. At first, it used INFOSERVER, which is the OOserver's own info # program, which might work if OOserver and data server are on # same box. (? Not if data and OOservers had different roots ... # how DID the original download succesfully get info?!) At some point, the # host associated with the data was used to access the info, as well as the # data. This was OK as long as there was no INFOSERVER associated with # the data. There's a problem if there WAS an INFOSERVER, since outer # never passed the extended URL to the OOserver. outer 3.3 will pass the # extended URL to the OOserver. otheropt 2.2f will pass it to the # downloader. download-1, 2, & 3 (each v 3.2 will) get that information # here (download-4 v 3.2). # The 2nd issue is what arguments to feed to info. Original infos # (v1s - csh version; v2s - perl conversion of last v1 plus enhancements) # took an object spec from PATH_INFO. Not sure if that spec could include # a remote host, since info ran strictly on the offset from jgofs_root/objects # where jgofs_root/htmlbin is where info lived. info v3s (BCO-DMO hook) # wanted host information. Somebody noticed that the link generated by # outer included a "data=" portion of the extended URL. The assumption was # made that that would always be there. The OOserver in general and # the downloader in particular never provided that portion of the URL. # download4 v 3.2 will honor a data= in the extended URL (outer 3.3 # does NOT send it). If not present, a data= extended URL will be # constructed from env var URLOBJX (which is why outer 3.3 doesn't need # to send it). One could argue that life would be easier if each of # outer, dir and info send a full {dir=,info=,data=}. Stay tuned ... # Note that info v 3 et seq are still stuck with what to do if # they do NOT have an extended URL passed to them. Go talk to the info # people ... (lots of people speak about themselves in 3rd person - # I get to be 4th and 5th, etc person, too!) # In case we happen to want OOserver's own infoserver # $objserver = "$protocol"."$OOserverinfo" # Build an extended URL to pass to whatever info we end up calling # Old info's should ignore it. Newer info's should be happy! # Remove any leading http:// or // or whatever. Could rely on # doc but this is easier. Note that object specs that include jg/serv # can't have embedded //s. Gee, I ought to write an object that does # NOT get invoked via serv, just to see what happens $ext_URL = ($ENV{'PATH_INFO_data'}) ? $ENV{'PATH_INFO_data'} : $urlobjx; ($dummy1,$dummy2,$dummy3) = (split m"//",$ext_URL,-1); if ($dummy3) { print $tracefile " $dwnld_err_stamp: Error copy_file_doc: " . "embedded // in object spec $ext_URL. " . "Trying to get doc w/o extended URL \n"; $ext_URL = ""; } else { ($ext_URL = $dummy2) || ($ext_URL = $dummy1); $ext_URL = "{data=$ext_URL}"; } if ($infofile = $dobj_infoserver) { $infofile = "http://" . $infofile; } else { # must handle local and remote objects differently # $objnode & $orig_objdir set up via parse_object_spec up top $host = ($objnode) ? $objnode : "$ENV{'SERVER_NAME'}"; $objserver = "$protocol"."$host"."/jg/info"; $infofile = "$objserver/$orig_objdir/$objnameonly"; } $infofile .= $ext_URL; print $tracefile " $dwnld_id_stamp: getting $infofile \n"; $status = "NG"; if (head("$infofile")) { # OK, we found the info file, so retrieve and print it to a local file # (well, would be better if we actually looked at http status ...) getstore "$infofile","$docfile"; $status = "OK"; } else { # # does it make sense to re-try with a statically defined INFOSERVER # (I don't think so. WJS 21 Jan 09) # $infofile = "$protocol"."$OOserverinfo"."$objpath"; # if (head("$infofile")) { # getstore "$infofile","$docfile"; # $status = "OK"; # } else { print $tracefile " $dwnld_err_stamp: Error copy_file_doc: $dobject info file not found \n"; # } } return $status,$infofile; } sub get_column # Input: file name of list executable # object spec (form where sel/proj list is parenthesized after obj name) # name of var to extract from obj # Output: status string ("OK" or something else); followed by # EITHER array of desired data (if status string = "OK") # OR status message (if status string != "OK") { my ($list,$object,$key) = @_; my ($tmp,$command,$obj,$varlist,@varlist,$key_col); my ($LIST_FH) = "LIST_IN"; # Apostrophes in next line to take care of empty string $list (I hope) (-e $list) || return "NON-EXISTENT_EXE","Could not find executable \'$list\'"; (-x $list) || return "NON-EXECUTABLE_EXE","No x access for executable $list"; # Be sure $key is in projection list of $object. ($obj) = ($object =~ /^\s*(.+)\)\s*$/); if ($obj) { $obj .= ",$key)"; } else { $obj = "$object($key)"; ($obj eq "($key)") && return "EMPTY_OBJECT","No non-whitespace characters in object spec"; } # Need -t in case data has embedded blanks or commas. -z is a performance # win. -forceheader in case all the data get selected out. -l for # potential long (>4096 byte) records $command = "$list -t -f -c -forceheader -z -l \"$obj\""; $! = 0; (open ($LIST_FH, "$command |")) || return $!,"Could not open pipe to command \'$command\'"; # First line of output is the tab-separated varlist. Find the $key variable # in this varlist. Most of the time, there will be no list - what comes back # from list will be the single column resulting from the projection of $key. # However, this could change if the object spec includes projections and/or # the object defn includes projections. First, there is a bug in the logic # that combines projection lists such that "sub-projections" are ignored, so # that if the object spec includes a non-$key variable, the resulting list # output will always include that variable. Second, even if that bug gets # fixed, it's possible the object spec projection list will NOT include $key # (because that data is not wanted in the results). In such a case, we # should throw out all the object spec projections, but that would involve # separating the projections from the selections in the object spec. # (Note that we cannot just throw out the whole sel/proj list - the selections # make a difference to the output of this routine) Accordingly, we bite the # bullet and set up to process a whole list # NB: potential white-space-in-varname issues are ignored. Informal JGOFS # spec says embedded whitespace is illegal. Don't know what it says about # leading/trailing. Because of this, we don't fool w/ $key either. ($status,$rec,@err_array) = &get_JGOFS_record($LIST_FH); ($status eq "OK") || return "READ_PROBLEM",&format_get_JGOFS_record_return_status($command,@err_array); chomp $rec; @varlist = split /\t/,$rec; for ($key_col = 0; $key_col < @varlist; $key_col++) { ($varlist[$key_col] eq $key) && last; } ($key_col == @varlist) && return "KEY_NOT_FOUND", "Could not find expected variable $key in object list $rec"; $nvals = 0; ($status,$rec,@err_array) = &get_JGOFS_record($LIST_FH); while ($status eq "OK") { chomp $rec; # Special-case the normal, 1-column situation # For the general case (and maybe the special, too), could probably build # a regex to pick the data without splitting. However, too lazy to # tangle w/the issue of empty fields, etc. Besides, this logic is # actually easy to understand. if (@varlist == 1) { # Don't know why there's a trailing tab, but seems to be... # Reason: bug in list; fixed in list 1.6c $tmp = $/; $/ = "\t"; chomp $rec; $/ = $tmp; $column[$nvals++] = $rec; } else { @var_vals = split /\t/,$rec; $column[$nvals++] = $var_vals[$key_col]; } ($status,$rec,@err_array) = &get_JGOFS_record($LIST_FH); } ($status eq "EOF") || return "READ_PROBLEM",&format_get_JGOFS_record_return_status($command,@err_array); return "OK",@column; } sub bad_confirmation { # user was unhappy with selections, and did not confirm them # what do they want to do now? if ($user_confirm eq "help") { # user gives up and has asked for help $button="Help"; $submit_msg=" to submit a request for assistance, "; print <OK ... let's give up on this one ...

ENDOFTEXT foreach $item (sort keys %form_info) { print qq| \n|; } } else { # user wants to bo back and try again if ($dobjext eq "NO_VALID_DOBJEXT") { print <Sorry, we have lost our return checkpoint
Please use the browser back button and/or history to find a restart position ENDOFTEXT } else { $button="Try again"; $submit_msg=" to go back and remake $objnameonly selections, "; print <OK ... let's go back and try working on the $objnameonly data again ... Press $submit_msg ENDOFTEXT } } # # also give them the option of returning to a previous location # print <... or perhaps you would like to go back to the Download and Other Options menu and start over again or use your browser's 'Go' menu to return and relocate the data object. ENDOFTEXT } sub create_readme { # make a README logfile for this data request # my ($save_stat); # $! = 0; (open (LOGF, "> $logfile")) || (return $!); # $! = 0; print LOGF "README file for requested data object: $dispobj \n"; print LOGF (scalar localtime()),"\n \n"; $save_stat = $!; # close LOGF; return $save_stat; } sub create_history { # make a HISTORY for this data request # $! = 0; (open (LOGH, "> $historyfile")) || (return $!); close LOGH; return 0; } sub add_note { my (@comment)= @_; # # add comment to the log file if ( -w "$logfile" ) { open (LOGF, ">> $logfile"); print LOGF "@comment \n"; close LOGF; } } sub add_history { my (@tagged_comments)= @_; my ($hist_sep_string) = ' | '; my ($now,$i); # # add timestamped, tagged comment to the history file $now = localtime(); if ( -w "$historyfile" ) { open (LOGH, ">> $historyfile"); $i = 0; while (defined $tagged_comments[$i]) { print LOGH $now,$hist_sep_string; print LOGH $tagged_comments[$i++],$hist_sep_string; (defined $tagged_comments[$i]) && (print LOGH $tagged_comments[$i++]); print LOGH "\n"; } close LOGH; } } sub mis_match { my ($det_act, $det_exp)= @_; # # $det_act is the actual parameter name found by list # $det_exp is the user-specified parameter we expected to match # # We need to notify user of a problem. # annotate an error log file for user if ( -w "$logfile" ) { open (ERRTXT, ">>"."$logfile") ; print ERRTXT "Working on: $selection \n"; print ERRTXT " unable to process request due to parameter mismatch: \n"; print ERRTXT " user selected parameter [ $det_exp ] is not equal to\n"; print ERRTXT " [ $det_act ] the actual parameter found in the data object\n"; close ERRTXT; } } sub send_email { my ($recipient,$subject,$message) = @_; my ($command,$status,$host_wo_port); # Can do job w/email client name, or can connect to port 25 of local # host or another host, or ??? $status = &pre_validate_email($recipient); ($status eq "OK") || return $status; ($host_wo_port) = split /\:/,$ENV{"MYADDR"}; $host_wo_port || ($host_wo_port = $ENV{"MYADDR"}); $! = $? = 0; # From: before Subject: or you will live in interesting times # This stuff works empirically only. Did not, for example, work with # mailx mail client $! = $? = 0; $mail_pid = open (MAIL_HANDLE,"| $email_sender $recipient"); defined ($mail_pid) || return "open_failure__\$!=$!;__\$?=$?"; $! = 0; print MAIL_HANDLE 'From: download@' . $host_wo_port . "\n"; ($! == 0) || return "print_failure__\$!=$!"; print MAIL_HANDLE 'Subject: ' . $subject . "\n"; ($! == 0) || return "print_failure__\$!=$!"; print MAIL_HANDLE "\n"; ($! == 0) || return "print_failure__\$!=$!"; print MAIL_HANDLE $message . "\n"; ($! == 0) || return "print_failure__\$!=$!"; close MAIL_HANDLE; return (($! == 0) && ($? == 0)) ? "OK" : "close_failure__\$!=$!;__\$?=$?"; } sub pre_validate_email { my ($recipient) = @_; ((-e $email_sender) && (-x _)) || return "existence/access_problem_with_$email_sender"; (($recipient =~ tr/@//) == 1) || return "badly_formatted_email_address_$recipient"; return "OK"; } sub make_complete_obj_spec_1 # Given 2 pieces of an object spec, make a good one # Named _1 since there may be more of these # In this one, piece 1 is of the form # objname( # or # objname(sel_proj # Piece 2 is a projection, possibly empty { my ($piece1,$piece2,$dummy) = @_; my ($piece1_frag1,$piece1_frag2,$complete_objspec); ((defined $piece2) && ( ! (defined $dummy))) || &uh_oh("Internal error: make_clean_obj_spec_1 called w/wrong # args"); $piece1 || &uh_oh("Internal inconsistency: make_clean_obj_spec_1 expects X( or X(Y; got empty string (or 0)"); # Note that a selection can have (s in it, so we cannot test for only 1 ( ($piece1_frag1,$piece1_frag2) = split /\(/,$piece1; (defined $piece1_frag2) || &uh_oh("Internal inconsistency: make_clean_obj_spec_1 expects X( or X(Y; got $piece1"); $piece1_has_sel_proj = ($piece1_frag2 ne ""); if ($piece2 eq "") { $complete_objspec = ($piece1_has_sel_proj) ? $piece1 . ')' : $piece1_frag1; } else { $complete_objspec = ($piece1_has_sel_proj) ? $piece1 . ',' . $piece2 . ')' : $piece1 . $piece2 . ')'; } return $complete_objspec; } sub uh_oh { # # We encountered a fatal error. Inform user with copy of # error message, close the html page and exit this program. # @errmsg = @_ ; $errsta = "0"; print $tracefile " $dwnld_err_stamp: Download Fatal Error Condition: \n"; print $tracefile " $dwnld_err_stamp: @errmsg \n"; &add_note ("Fatal error msg: @errmsg"); $msg1 = ($dispobj) ? "processing the $dispobj data" : ""; print < @errmsg

ENDOFSUB1 (-e $logfile) && print "There may be additional " . "information " . "about the processing status.
"; print <

Please return to the Download and Other Options menu or try using your browser's 'Go' menu to return and relocate the data object.

  or press to submit a request for assistance.

ENDOFSUB # # Close html file cleanly and exit this program. # print &HtmlBot; exit; }