#! /usr/bin/perl -w # # # main for SAS perl tasks. # require 5; use strict; use Getopt::Long; Getopt::Long::Configure ("pass_through"); use SAS::error; ## At build time the following strings (enclosed in --, that is ## -string-) are replaced: ## sasperl -> This is taken from the PERL variable defined by configure ## taskname ## version ## release ## aka ## Make sure they do not occur anywhere else in main.pl unless you ## want them to be replaced. ## taskname also occurs at the end of main.pl ## my $name = "colimchain"; SAS::error::client($name); my $VERSION = "1.8"; my $RELEASE = "xmmsas_20160201_1833-15.0.0"; my $AKA = "15.0.0"; ## ## Standard options: these follow taskmain. ## ## -a|--ccfpath [:...] --> SAS_CCFPATH ## -f|--ccffiles [...] --> cannot be implemented ## -c|--noclobber --> SAS_CLOBBER ## -d|--dialog --> tool(sasdialog) ## -h|--help --> tool(listparams) ## -i|--ccf --> SAS_CCF ## -m|--manpage --> sashelp ## -o|--odf --> SAS_ODF ## -V|--verbosity -- SAS_VERBOSITY ## -v|--version --> local implementation ## ## Getopt::Long provides support for short versions with single "-" except for -v. ## Therefore all short versions were automatically included either with first letter ## or via an alias as for -a, -i, -o and -V. ## ## -v deserves special care due to the existence of support for $version within the ## Getopt module. Therefore -v is treated specially. my ($ccfpath, $noclobber, $dialog, $help, $ccf, $manpage, $odf, $verbosity, $version); exit(1) unless GetOptions("ccfpath|a=s" => \$ccfpath, "noclobber" => \$noclobber, "dialog" => \$dialog, "help" => \$help, "ccf|i=s" => \$ccf, "manpage" => \$manpage, "odf|o=s" => \$odf, "verbosity|V=i" => \$verbosity, "version" => \$version, ); my $arg; foreach $arg (@ARGV) { $version=1 if ( $arg =~ "-v" ); } $ENV{SAS_CCFPATH} = $ccfpath if($ccfpath); $ENV{SAS_CLOBBER} = 0 if($noclobber); $ENV{SAS_CCF} = $ccf if($ccf); $ENV{SAS_ODF} = $odf if($odf); $ENV{SAS_VERBOSITY} = $verbosity if($verbosity); use SAS::param; if($version){ print "$name-$VERSION [$RELEASE-$AKA]\n"; exit(0); } if($manpage){ system("sashelp --doc=$name"); my $x = $? >> 8; # perldoc -f system exit($x); } if($help){ system("listparams $name"); my $x = $? >> 8; exit($x); } if($dialog){ system("sasdialog $name"); my $x = $? >> 8; exit($x); } &colimchain(); #!/usr/local/bin/perl -w # # NAME: colimchain # VERSION: 1.5 # # Developer: Ian Stewart SSC-LUX # # TODO: # - Replace prints by SAS::message. In all other perl tasks too. # - Check that .lyt file works. # ######################################################################### my ($testflag, %obs_list); my ($i, $band_num, $filename, $maskfile, $template_band_num, $command, $infile, $at_least_one_not_flat, @input_filepaths); my ($colimplot_pgdev, $colimplot_op_file, $x_offset, $y_offset, $line1, $line2, $all_line, $x_size, $y_size, $status, $temp_ppm_file, $taskname, $xi, $yi, $a_redval, $a_bluval, $a_grnval, $b_redval, $b_bluval, $b_grnval, $b_index, $read_index, $last_index, $max_buf_len, @read_vector, $write_index, $buf, @write_vector, $log_name, $write_log); sub colimchain { use SAS; no strict 'refs'; $taskname = "colimchain"; my $apm = $SAS::AppMsg; my $vbs = $SAS::VerboseMsg; my $nsy = $SAS::NoisyMsg; # my (%params, $ccf_path); # my (%obs_list, $band_num, $filename, %filenames, @input_filepaths); # my ($infile, $opfile, $command, $i, $maskfile, $status, $colimplot_op_file, $colimplot_pgdev, $clobber, @chunks, $junk, $max); # my ($x_offset, $y_offset, $line1, $line2, @lines, $x_size, $y_size); # # my $log_name = 'log'; # Prints all output to stderr: select(STDERR); my $frame_gif_file = "frame.gif"; my $frame_ppm_file = "frame.ppm"; my $coms_file = "chain_coms.dat"; my $whole_ppm_file = 'whole.ppm'; my $image_ppm_file = 'image.ppm'; my $thumblist_file = 'links.lis'; # Vars used by &write_byte and &read_byte: # my $max_buf_len = 16384; my $max_buf_len = 16; my $read_index = 0; my $write_index = 0; my $last_index = 0; # %params = &getParams; my $num_entries = parameterCount('bandlist'); SAS::error('tooFewBands', "Too few images - can't make a colour plot.") if ($num_entries <= 1); my @band_nums = (); foreach $i (0 .. $num_entries-1) { $band_nums[$i] = intParameter('bandlist', $i) } @band_nums = sort(@band_nums); # $clobbertemps = booleanParameter('clobbertemps'); my $clobberprods = booleanParameter('clobberprods'); my $prod_dir = stringParameter('prodsdir'); my $output_file = stringParameter('plotfile'); my $pgdev = stringParameter('pgdev'); my $thumbnail_dir = stringParameter('thumbnaildir'); my $inst_lc = stringParameter('instrument'); ### instexpid?? my $idtype = stringParameter('idtype'); my $obsindex = intParameter('obsindex'); my $expindex = intParameter('expindex'); my $obsid = stringParameter('obsid'); my $expid = stringParameter('expid'); my $do_smooth = booleanParameter('smooth'); my $maxwidth = realParameter('maxwidth'); my $nconvolvers = intParameter('nconvolvers'); my $desiredsnr = realParameter('desiredsnr'); my $withthumbnails = booleanParameter('withthumbnails'); my $expandtomask = booleanParameter('expandtomask'); my $rebinimage = booleanParameter('rebinimage'); my $newnxbins = intParameter('newnxbins'); my $newnybins = intParameter('newnybins'); my $cutoff = realParameter('cutoff'); my $weirdness = realParameter('weirdness'); my $heat = realParameter('heat'); my $heatspread = realParameter('heatspread'); my $gainstyle = stringParameter('gainstyle'); my $gain = realParameter('gain'); #*** change it to usergain in line with colimplot? my $add_to_frame = booleanParameter('withframe'); $testflag = booleanParameter('astest'); if ($testflag) {SAS::warning('inTestMode',"The --astest parameter is set: " ."you will get no real output.");} my $template_name = 'asmooth_template.ds'; ### pass template set name as command-line parameter. # my $testflag = &boolTranslate($params{astest}); # my $clobbertemps = &boolTranslate($params{clobbertemps}); # my $clobberprods = &boolTranslate($params{clobberprods}); # my $prod_dir = $params{prodsdir}; # my $write_log = &boolTranslate($params{writelog}); # my $add_to_frame = &boolTranslate($params{withframe}); # my $output_file = $params{plotfile}; # my $pgdev = $params{pgdev}; # my $thumbnail_dir = $params{'thumbnaildir'}; # $ccf_path = $params{ccfpath}; # if (!defined($ccf_path) || $ccf_path eq '') { if (!defined($ENV{'SAS_CCF'})) { #&quit("You must set SAS_CCF before running $taskname.", 1); SAS::error('noCifSpecified', "You must set SAS_CCF before running $taskname."); # } else { # $ccf_path = $ENV{'SAS_CCF'}; } # } else { # $ENV{'SAS_CCF'} = $ccf_path; # } #...................................................................... # Main processing: #&quit("Directory $prod_dir not found.", 2) if (!-e "$prod_dir"); SAS::error('noProductSubdirectory', "Directory $prod_dir not found.") if (!-d "$prod_dir"); if (-e "$output_file" && !$clobberprods) { #&quit("Output file $output_file exists, $taskname not run.", 3); SAS::error('outputExists', "Output file $output_file exists, $taskname not run."); } # my $inst_uc = uc($params{instrument}); my $inst_uc = uc($inst_lc); if ($inst_uc eq 'OM') { #&quit("Sorry, can't do OM yet.", 4); SAS::error('notYetSupported', "Sorry, can't do OM yet."); } elsif ($inst_uc ne 'M1' && $inst_uc ne 'M2' && $inst_uc ne 'PN') { #&quit("Unrecognised instrument.", 5); SAS::error('badInstrument', "Unrecognised instrument $inst_uc."); } # $params{bandlist} =~ s/^\s+//; # $params{bandlist} =~ s/\s+$//; # my @band_nums = sort(split(/\s+/, $params{bandlist})); #&quit("Too few images to make a colour plot.", 6) if (@band_nums < 2); # if ($params{idtype} eq 'index') { if ($idtype eq 'index') { &makeHashTreeEpic($prod_dir); my @obss = sort(keys(%obs_list)); if (@obss > 1) { # &tell("Products directory contains more than 1 observation."); print "Products directory contains more than 1 observation.\n"; SAS::message($vbs, "Products directory contains more than 1 observation."); } # if ($#obss < $params{obsindex}) { if ($#obss < $obsindex) { # &warn("The number of observations is fewer than the required obsindex. " # ."Last observation being used."); SAS::warning('tooFewObs', "The number of observations is fewer than " ."the required --obsindex. Last observation is being used instead " ."of --obsindex."); $obsid = $obss[$#obss]; } else { # $obsid = $obss[$params{obsindex}]; $obsid = $obss[$obsindex]; } my $exp_list_name = ${${$obsid}{$inst_uc}}; my @exps = sort(keys(%{$exp_list_name})); if (@exps > 1) { # &tell("There is more than 1 exposure for this instrument."); print "There is more than 1 exposure for this instrument.\n"; } # if ($#exps < $params{expindex}) { if ($#exps < $expindex) { # &warn("The number of exposures is fewer than the required expindex. " # ."Last exposure being used."); SAS::warning('tooFewExposures', "The number of exposures is fewer than " ."the required --expindex. Last exposure is being used instead " ."of --expindex."); $expid = $exps[$#exps]; } else { # $expid = $exps[$params{expindex}]; $expid = $exps[$expindex]; } } else { # assume idtype = 'full': # my $obsid = $params{obsid}; # my $expid = $params{expid}; } my $not_all_files_found = 0; my %filenames = (); foreach $band_num (@band_nums) { $filename = "P$obsid$inst_uc$expid"."IMAGE_$band_num"."000.FIT"; if (-e "$prod_dir/$filename") { # &tell("File $filename found."); print "File $filename found.\n"; } else { # &warn("File $filename not found."); SAS::warning('imageNotFound', "File $filename not found."); $not_all_files_found = 1; } $filenames{$band_num} = $filename; } if ($not_all_files_found) { #&quit("Not all the files were found - can't proceed.", 7); SAS::error('someImagesNotFound', "Not all the files were found - can't proceed."); } my $withmaskset = 'yes'; # Find an exposure map to use for a mask: my @files = `ls -1 $prod_dir`; my $no_exp_map_found = 1; # default foreach (@files) { if (/^P($obsid$inst_uc$expid)EXPMAP\d000.FIT/i) { $no_exp_map_found = 0; $maskfile = $_; last; } } if ($no_exp_map_found) { # &warn("No exposure map found for this observation+instrument+exposure."); SAS::warning('expMapNotFound', "No exposure map was found for this observation+instrument+exposure."); $withmaskset = 'no'; } else { chomp($maskfile); #&quit("Mask $prod_dir/$maskfile is all zero. Can't do smoothing.", 9) SAS::error('maskAllZeros', "Mask $prod_dir/$maskfile is all zero. Can't do smoothing.") if (&image_is_zero("$prod_dir/$maskfile")); } #...................................................................... # Smoothing: my $filelist = ''; # if (&boolTranslate($params{smooth})) { if ($do_smooth) { # Make template: if ($no_exp_map_found) { #&quit("Can't usefully run asmooth - no exposure map found to use as a mask.",10); SAS::error('expMapNotFound', "Can't usefully run asmooth - no exposure map found to use as a mask."); } $template_band_num = $band_nums[0]; #&quit("Template input image is flat. Can't smooth.", 10.1) SAS::error('templateImageIsFlat', "Template input image is flat. Can't smooth.") if (&image_is_flat("$prod_dir/$filenames{$template_band_num}")); # Make template from the lowest energy band (this will have strongest # sources and weakest background): my $opfile = "smoothed_"."$template_band_num".".ds"; ### should pass this as a command-line parameter. $command = "asmooth " ."inset=$prod_dir/$filenames{$template_band_num} " ."outset=$opfile " ."widthliststyle=log " ."maxwidth=$maxwidth " ."nconvolvers=$nconvolvers " ."desiredsnr=$desiredsnr " ."templateset=$template_name " ### pass template set name as command-line parameter. ."normalize=yes " ### shouldn't be necessary with full use of param-2.0, because it should be default for adaptive smoothing. ."withweightset=yes " ."weightset=$prod_dir/$maskfile " ."withoutmaskset=yes " ."outmaskset=$prod_dir/$maskfile " ; # if (&run($clobbertemps, $opfile, $command, "asmooth output $opfile " # ."already exists. asmooth not run.")) { #&quit("Couldn't run asmooth.", 11); # } SAS::error('templateAsmoothFailed', "Couldn't do first asmooth.") if (&run("$command")); @input_filepaths = (); $at_least_one_not_flat = 0; # default foreach $band_num (@band_nums) { $opfile = "smoothed_"."$band_num".".ds"; push @input_filepaths, $opfile; next if ($band_num eq $template_band_num); $infile = "$prod_dir/$filenames{$band_num}"; if (&image_is_flat($infile)) { # if (&run($clobbertemps, $opfile, "cp $infile $opfile", "Couldn't cp " # ."to $opfile, it already exists.")) { #&quit("Couldn't cp $infile $opfile.", 11.1); $command = "cp $infile $opfile"; SAS::error('cpFailed', "Couldn't $command.") if (&run("$command")); # } #fimgstat next; } $at_least_one_not_flat = 1; $command = "asmooth " ."inset=$infile " ."outset=$opfile " ."widthliststyle=log " ."maxwidth=$maxwidth " ."nconvolvers=$nconvolvers " ."desiredsnr=$desiredsnr " ."readtemplateset=yes " ."writetemplateset=no " ."templateset=$template_name " ### pass template set name as command-line parameter. ."normalize=yes " ### shouldn't be necessary with full use of param-2.0, because it should be default for adaptive smoothing. # ."withweightset=yes " # ."weightset=$prod_dir/$maskfile " ."withoutmaskset=yes " ."outmaskset=$prod_dir/$maskfile " ; ; # if (&run($clobbertemps, $opfile, $command, "asmooth output $opfile " # ."already exists. asmooth not run.")) { #&quit("Couldn't run asmooth.", 12); # } SAS::error('asmoothFailed', "Couldn't run asmooth.") if (&run("$command")); } # next $band_num #&quit("No non-flat asmooth input files.", 12.1) if (!$at_least_one_not_flat); SAS::error('allImagesFlat', "No non-flat asmooth input files.") if (!$at_least_one_not_flat); } else { # don't smooth: # Compose filename list $filelist: @input_filepaths = (); foreach(sort(values(%filenames))) { push @input_filepaths, "$prod_dir/$_"; } } my $at_least_one_not_zero = 0; # default foreach(@input_filepaths) { if(!&image_is_zero($_)) { $at_least_one_not_zero = 1; last; } } #&quit("No non-zero colimplot input files.", 12.2) if (!$at_least_one_not_zero); SAS::error('allImagesZero', "No non-zero input images.") if (!$at_least_one_not_zero); $filelist = join(' ', @input_filepaths); $filelist = "'$filelist'"; #........................................................................ # Colimplot: if ($pgdev eq '/png') { $colimplot_pgdev = '/ppm'; $colimplot_op_file = $image_ppm_file; # $clobber = $clobbertemps; } else { $colimplot_pgdev = $pgdev; $colimplot_op_file = $output_file; # $clobber = $clobberprods; } $command = "colimplot " . "insets=$filelist " ."expandtomask=$expandtomask " . "rebinimage=$rebinimage " . "newnxbins=$newnxbins " . "newnybins=$newnybins " . "cutoff=$cutoff " . "weirdness=$weirdness " . "heat=$heat " . "heatspread=$heatspread " . "gainstyle=$gainstyle " . "usergain=$gain " . "pgdev=$colimplot_pgdev " . "plotfile=$colimplot_op_file " . "withframe=$add_to_frame " ; if ($no_exp_map_found) { $command .= '' ."maskstyle=self " } else { $command .= '' . "withmask=$withmaskset " ."maskstyle=user " . "maskset=$prod_dir/$maskfile " } # if (&run($clobber, $colimplot_op_file, $command, "colimplot output " # ."$colimplot_op_file already exists. colimplot not run.")) { #&quit("Couldn't run colimplot.", 13); # } SAS::error('colimplotFailed', "Couldn't run colimplot.") if (&run("$command")); if ($pgdev eq '/png') { # then colimplot has written its image # output to a file called $image_ppm_file. if ($add_to_frame) { # Convert the frame file to ppm and add it # to $image_ppm_file to give $whole_ppm_file: $command = "giftoppm $frame_gif_file > $frame_ppm_file"; # if (&run($clobbertemps, $frame_ppm_file, $command, "giftoppm output " # ."$frame_ppm_file already exists. giftoppm not run.")) { #&quit("Couldn't run pnmtopng.", 14); # } SAS::error('pnmtopngFailed', "Couldn't run pnmtopng.") if (&run("$command")); $x_offset = 0; $y_offset = 0; if (-e "$coms_file") { open(COMS, "$coms_file"); if (defined($line1 = ) && defined($line2 = )) { $all_line = $line1.$line2; if ($all_line =~ /^\s*(\d+)\s+(\d+)\s+(\d+)\s*\n\s*(\d+)\s+(\d+)\s+(\d+)\s*$/) { $x_offset = int(($1 + $2) / 2.0); $y_offset = int(($4 + $5) / 2.0); my @lines = `cat $image_ppm_file`; #&quit("Bad $image_ppm_file file", 15) if (!defined($lines[4])); # 4 header lines plus at least 1 pixel. SAS::error('badPpmFile', "Bad $image_ppm_file file.") if (!defined($lines[4])); # 4 header lines plus at least 1 pixel. chomp($lines[0]); #&quit("Bad $image_ppm_file file", 16) if ($lines[0] ne 'P3'); SAS::error('badPpmFile', "Bad $image_ppm_file file.") if ($lines[0] ne 'P3'); chomp($lines[1]); if ($lines[1] =~ /^\s*(\d+)\s*$/) { $x_size = $1; } else { #&quit("Bad $image_ppm_file file", 17) ; SAS::error('badPpmFile', "Bad $image_ppm_file file."); } chomp($lines[2]); if ($lines[2] =~ /^\s*(\d+)\s*$/) { $y_size = $1; } else { #&quit("Bad $image_ppm_file file", 18) ; SAS::error('badPpmFile', "Bad $image_ppm_file file."); } $x_offset -= int($x_size / 2.0); $y_offset -= int($y_size / 2.0); } } close(COMS); } # if (! -e "$whole_ppm_file") {# || $clobbertemps) { if (!$testflag) { # &tell("Adding image to frame file."); print "Adding image to frame file.\n"; if (-e "$whole_ppm_file") {unlink("$whole_ppm_file");} $status = &add_ppm($frame_ppm_file, $image_ppm_file, $x_offset , $y_offset, $whole_ppm_file); if ($status != 0) { #&quit("Couldn't add $frame_ppm_file to $image_ppm_file: add_ppm status $status", 19); SAS::error('badAddPpmStatus', "Couldn't add $frame_ppm_file to $image_ppm_file: add_ppm status $status."); } } # } else { # &warn("$whole_ppm_file already exists, not overwritten."); # } $temp_ppm_file = $whole_ppm_file; } else { # don't add the frame file to the colour image: $temp_ppm_file = $image_ppm_file; } # end if $add_to_frame $command = "pnmtopng $temp_ppm_file > $output_file"; # if (&run($clobberprods, $output_file, $command, "pnmtopng output " # ."$output_file already exists. pnmtopng not run.")) { #&quit("Couldn't run pnmtopng.", 20); # } SAS::error('pnmtopngFailed', "Couldn't run pnmtopng.") if (&run("$command")); # if (&boolTranslate($params{'withthumbnails'})) { if ($withthumbnails) { my $thumbnail_file = $output_file.".small"; $command = "pnmsmooth $temp_ppm_file | pnmscale 0.1 " ."| ppmquant 256 | pnmtopng > $thumbnail_file"; # if (&run($clobberprods, $thumbnail_file, $command, "Thumbnail file " # ."$thumbnail_file already exists. Not overwritten.")) { #&quit("Couldn't make thumbnail.", 21); # } SAS::error('makeThumbnailFailed', "Couldn't make thumbnail.") if (&run("$command")); $command = "mv $thumbnail_file $thumbnail_dir/"; # if (&run($clobberprods, "$thumbnail_dir/$thumbnail_file", $command # ,"Thumbnail file $thumbnail_dir/$thumbnail_file already exists. " # ."Not overwritten.")) { #&quit("Couldn't mv thumbnail.", 22); # } SAS::error('moveThumbnailFailed', "Couldn't mv thumbnail.") if (&run("$command")); if (-e "$thumblist_file") { open(LLIS, ">>$thumblist_file"); } else { open(LLIS, ">$thumblist_file"); } print LLIS "$output_file\t$thumbnail_dir/$thumbnail_file\n"; close(LLIS); } } # end if ($params{'pgdev'} eq '/png'). exit 0; } #--------------------------------------------------------------------- sub getParams { #--------------------------------------------------------------------- # This routine is shared with all chains. Should therefore be in a # separate module. my ($possible_key, $actual_key, $value, $no_match_found , $unmatched_pars_found); my %params = &getParamDefaults; # Look for '-v': foreach (@ARGV) { if ($_ eq '-v') { &getVersionThenQuit(); } } # Look for '-h(elp)': foreach (@ARGV) { if (/^-h(|elp)/) { &printParamsThenQuit(); } } $unmatched_pars_found = 0; foreach (@ARGV) { if ($_ =~ /^(\w+)(=+)/) { $actual_key = $1; $value = $'; $no_match_found = 1; foreach $possible_key (keys(%params)) { if ($possible_key eq $actual_key) { $params{$possible_key} = $value; $no_match_found = 0; last; } } if ($no_match_found) { $unmatched_pars_found = 1; &warn("Unrecognised parameter: $actual_key"); } } } &quit("Unmatched parameters found.", -1) if ($unmatched_pars_found); return %params; } #--------------------------------------------------------------------- sub getParamDefaults { #--------------------------------------------------------------------- # Loading default parameter values: my %params = ( ccfpath => '', prodsdir => '.', clobbertemps => 'no', clobberprods => 'no', writelog => 'no', astest => 'no', withthumbnails => 'no', thumbnaildir => './thumbnails', instrument => 'm1', idtype => 'index', obsindex => 0, expindex => 0, obsid => '', expid => '', bandlist => "2 3 4", smooth => 'yes', maxsigma => 20.0, desiredsnr => 7.0, ngauss => 30, rebinimage => 'no', newnxbins => 250, newnybins => 250, weirdness => -0.7, heat => 0.0, heatspread => 0.3, cutoff => 0.05, gainstyle => 'auto', gain => 8.0, pgdev => '/png', expandtomask => 'yes', plotfile => 'temp.png', withframe => 'no', ); return %params; } #--------------------------------------------------------------------- sub getVersionThenQuit { #--------------------------------------------------------------------- # Adapted from &getVersion in emchain. my $ccom = ''; print "\n" ; chomp(my $sasdir = `which $taskname`) ; ##### $ENV{'SAS_DIR'} better??? my $ii = index($sasdir,"/bin/$taskname"); if ($ii == -1) { print "Sorry, directory structure of $taskname $sasdir " . "could not be recognised.\n" ; } else { $sasdir = substr($sasdir,0,$ii) ; $ccom = `find $sasdir -name VERSION | grep $taskname` ; if ( length($ccom) == 0 ) { print "Sorry, version number of $taskname " . "could not be found in $sasdir \n" } else { chomp(my $version = `cat $ccom`) ; $ccom = $sasdir . "/RELEASE" ; my $release = "" ; if ( -e $ccom ) { chomp($release = `cat $ccom`) } print "$taskname $version [$release] \n" ; } } # Write the version of the constituent tasks print "\n" ; print "You are using the following task versions : \n" ; my $task = ''; foreach $task ("asmooth", "colimplot") { $ccom = $task . " -v \n" ; print `$ccom` ; } print "\n" ; exit 0; } #--------------------------------------------------------------------- sub printParamsThenQuit { #--------------------------------------------------------------------- my %params = &getParamDefaults; foreach (keys(%params)) { print "$_,\tdefault = $params{$_}\n"; } exit 0; } #--------------------------------------------------------------------- sub boolTranslate { #--------------------------------------------------------------------- my ($inStr) = @_; my $out; if ($inStr =~ /^\w+$/) { $inStr = lc($inStr); if ($inStr eq 'y' || $inStr eq 'yes' || $inStr eq 't' || $inStr eq 'true') { $out = 1; } elsif ($inStr eq 'n' || $inStr eq 'no' || $inStr eq 'f' || $inStr eq 'false') { $out = 0; } else { &quit("Non-boolean variable $inStr treated as boolean.", -2); } } elsif ($inStr ne '0' && $inStr ne '1') { &quit("Non-boolean variable $inStr treated as boolean.", -3); } return($out); } #--------------------------------------------------------------------- sub makeHashTreeEpic { #--------------------------------------------------------------------- # Construct a hash tree of revolution, observation, exposure, instrument, # ccd, in which each hash value is a name of the next hash down. The easiest # way to compose unambiguous hash names is to use the rev, obs etc numbers # themselves. no strict 'refs'; my ($filename, $obs, $ins, $typ, $exp, $img); my ($prod_dir) = @_; my @filenames = `ls -1 $prod_dir`; my $total_matching_files = 0; foreach $filename (@filenames) { chomp($filename); if ($filename =~ /^P(\d{10})(\w\w)(S|U)(\d{3})IMAGE_(\d)000.FIT/i) { ++$total_matching_files; $obs = $1; $ins = $2; $typ = $3; $exp = $4; $img = $5; chomp($filename); # Observation list: $obs_list{$obs} = "$obs"; # Instrument list for each observation: ${${$obs}{$ins}} = "$obs$ins"; # Exposure list for each instrument: ${${"$obs$ins"}{"$typ$exp"}} = "$obs$ins$typ$exp"; # No more hash levels below this, so it is convenient to store the # filename in the hash value instead: ${${"$obs$ins$typ$exp"}{"$img"}} = "$filename"; } } if ($total_matching_files == 0) { #&quit("No matching files in $prod_dir.", -4); SAS::error('noProdFiles', "No matching files in $prod_dir."); } } #---------------------------------------------------------------------- sub image_is_flat { #---------------------------------------------------------------------- my ($junk, $stddev); my ($image) = @_; my $command = "fimgstat $image outfile=STDOUT " ."threshlo=INDEF threshup=INDEF | grep deviation"; print "\ninvoke $command\n\n"; my @chunks = `$command`; SAS::error('badFimgstat', "Couldn't get sensible result from fimgstat to get stddev of $image.") if (!defined($chunks[0])); my $bad_fimgstat_call = 1; # default foreach(@chunks) { if (/deviation/) { $bad_fimgstat_call = 0; ($junk, $stddev) = split('='); chomp($stddev); } #&quit("Couldn't get sensible result from fimgstat to get dev of $image.", -4.1) SAS::error('badFimgstat', "Couldn't get sensible result from fimgstat to get stddev of $image.") if ($bad_fimgstat_call); } if ($stddev <= 0) { return 1; } else { return 0; } } #---------------------------------------------------------------------- sub image_is_zero { #---------------------------------------------------------------------- my ($junk, $max); my ($image) = @_; my $command = "fimgstat $image outfile=STDOUT " ."threshlo=INDEF threshup=INDEF | grep 'The maximum'"; print "\ninvoke $command\n\n"; my @chunks = `$command`; SAS::error('badFimgstat', "Couldn't get sensible result from fimgstat to get max of $image.") if (!defined($chunks[0])); my $bad_fimgstat_call = 1; # default foreach(@chunks) { if (/^The maximum of selected image/) { $bad_fimgstat_call = 0; ($junk, $max) = split('='); chomp($max); } #&quit("Couldn't get sensible result from fimgstat to get max of $image.", -4.2) SAS::error('badFimgstat', "Couldn't get sensible result from fimgstat to get max of $image.") if ($bad_fimgstat_call); } if ($max <= 0) { return 1; } else { return 0; } } #---------------------------------------------------------------------- sub add_ppm { #---------------------------------------------------------------------- # Adds ppm files $a_file to $b_file, leaving the result in $c_file. $b_file # is assumed to be an ordinary ppm with 1 pixel per row, $a_file a byte- # -stored ppm. The result, $c_file, is a byte-stored ppm. my ($a_x_size, $a_y_size, $a_hue_resoln, $b_x_size, $b_y_size, $b_hue_resoln, $line); # my $x_offset = 0; # my $y_offset = 0; my $status = 0; my ($a_file, $b_file, $x_offset, $y_offset, $c_file) = @_; my @b_lines = `cat $b_file`; return -1 if (!defined($b_lines[4])); # 4 header lines plus at least 1 pixel. chomp($b_lines[0]); return -2 if ($b_lines[0] ne 'P3'); chomp($b_lines[1]); if ($b_lines[1] =~ /^\s*(\d+)\s*$/) { $b_x_size = $1; } else { return -3; } chomp($b_lines[2]); if ($b_lines[2] =~ /^\s*(\d+)\s*$/) { $b_y_size = $1; } else { return -4; } chomp($b_lines[3]); if ($b_lines[3] =~ /^\s*(\d+)\s*$/) { $b_hue_resoln = $1; } else { return -5; } return -6 if (@b_lines != $b_x_size * $b_y_size + 4); # &tell("Loaded colour image into memory."); print "Loaded colour image into memory.\n"; open(A, "$a_file"); return -7 if (!defined($line = )); chomp($line); return -8 if ($line ne 'P6'); return -9 if (!defined($line = )); chomp($line); if ($line =~ /^\s*(\d+)\s+(\d+)\s*$/) { $a_x_size = $1; $a_y_size = $2; } else { return -10; } return -13 if (!defined($line = )); chomp($line); if ($line =~ /^\s*(\d+)\s*$/) { $a_hue_resoln = $1; return -14 if ($a_hue_resoln != 255); } else { return -15; } open(C, ">$c_file"); print C "P6\n"; print C "$a_x_size $a_y_size\n"; print C "$a_hue_resoln\n"; foreach $yi (1 .. $a_y_size) { foreach $xi (1 .. $a_x_size) { ($status, $a_redval) = &read_byte(\*A); return -16 if ($status < 0); ($status, $a_grnval) = &read_byte(\*A); return -16 if ($status < 0); ($status, $a_bluval) = &read_byte(\*A); return -16 if ($status < 0); if ($xi - $x_offset >= 1 && $xi - $x_offset <= $b_x_size && $yi - $y_offset >= 1 && $yi - $y_offset <= $b_y_size) { # add the # relevant pixel value from $b_file: $b_index = 3 + ($yi - $y_offset - 1) * $b_x_size + $xi - $x_offset; chomp($b_lines[$b_index]); if ($b_lines[$b_index] =~ /^\s*(\d+)\s+(\d+)\s+(\d+)\s*$/) { $b_redval = int(256 * ($1 / $b_hue_resoln)); $b_grnval = int(256 * ($2 / $b_hue_resoln)); $b_bluval = int(256 * ($3 / $b_hue_resoln)); } else { return -17; } $a_redval = $a_redval + $b_redval; if ($a_redval > 255) {$a_redval = 255} $a_grnval = $a_grnval + $b_grnval; if ($a_grnval > 255) {$a_grnval = 255} $a_bluval = $a_bluval + $b_bluval; if ($a_bluval > 255) {$a_bluval = 255} } else { #print " "; } return -18 if (&write_byte(\*C, $a_redval, 0)); return -18 if (&write_byte(\*C, $a_grnval, 0)); return -18 if (&write_byte(\*C, $a_bluval, 0)); } } return -19 if (&write_byte(\*C, 0, 1)); close(C); close(A); return $status; } #---------------------------------------------------------------------- sub read_byte { #---------------------------------------------------------------------- # $read_index and $last_index should both be initialised to 0 in the calling # routine, and not altered between calls to read_byte. $max_buf_len should # also be assigned a value. my ($buf, $byte_val); my ($filehandle) = @_; if (!defined($read_index) || (defined($read_index) && $read_index >= $last_index)) { if (defined($last_index = read $filehandle, $buf, $max_buf_len)) { @read_vector = unpack "C*", $buf; if (!defined($read_vector[0])) { return (-1, 0); } $read_index = 0; } else { return (-2, 0); } } $byte_val = $read_vector[$read_index]; ++$read_index; return (0, $byte_val); } #---------------------------------------------------------------------- sub write_byte { #---------------------------------------------------------------------- # $write_index should be initialised 0 in the calling routine, and # not altered between calls to write_byte. After write_byte has been called # with the last byte to write, it should be called again with $end = 1 # to actually write the last buffer to file. my ($filehandle, $byte_val, $end) = @_; if ($end || (defined($write_index) && $write_index >= $max_buf_len)) { $buf = pack "C*", @write_vector; return -1 if(!print $filehandle $buf); $write_index = 0; @write_vector = (); } elsif (!defined($write_index)) { $write_index = 0; @write_vector = (); } $write_vector[$write_index] = $byte_val; ++$write_index; return 0; } # #--------------------------------------------------------------------- # sub run { # #--------------------------------------------------------------------- # # my ($clobber, $output, $command, $warning) = @_; # # my $status = 0; # if (! -e "$output" || $clobber) { # &tell("invoke $command"); # if (!$testflag) { # if (-e "$output") {unlink("$output");} # $status = system($command); # } # } else { # &warn($warning); # } # # return $status; # } #--------------------------------------------------------------------- sub run { #--------------------------------------------------------------------- # $testflag should be defined globally. my ($command) = @_; my $status = 0; print "\ninvoke $command\n\n"; if (!$testflag) { $status = system($command); } return $status; } #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ sub tell { open(LOG, ">> $log_name") if ($write_log); foreach (@_) { print "$taskname:- $_\n\n"; print LOG "$taskname:- $_\n\n" if ($write_log); } close(LOG) if ($write_log); } #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ sub warn { open(LOG, ">> $log_name") if ($write_log); foreach (@_) { print "** $taskname: warning, $_\n\n"; print LOG "** $taskname: warning, $_\n\n" if ($write_log); } close(LOG) if ($write_log); } #---------------------------------------------------------------------- sub quit { #---------------------------------------------------------------------- # Expects $taskname, $log_name and $write_log to be defined, but doesn't # complain if they are not. my ($message, $status) = @_; my $whole_message = "** "; if (defined($taskname)) { $whole_message .= "$taskname: "; } $whole_message .= "ERROR! $message\n\n"; print $whole_message; if (defined($log_name) && defined($write_log) && $write_log) { open(LOG, ">> $log_name"); print LOG $whole_message; close(LOG); } exit $status; }