Index: trunk/pstamp/scripts/pstamp_results_file.pl
===================================================================
--- trunk/pstamp/scripts/pstamp_results_file.pl	(revision 18537)
+++ trunk/pstamp/scripts/pstamp_results_file.pl	(revision 18537)
@@ -0,0 +1,293 @@
+#!/bin/env perl
+
+# program to create a fits binary table with EXTNAME PS1_PS_RESULTS
+
+use warnings;
+use strict;
+
+use Astro::FITS::CFITSIO qw( :constants );
+Astro::FITS::CFITSIO::PerlyUnpacking(1);
+use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt );
+use Pod::Usage qw( pod2usage );
+use Math::Trig;
+use Data::Dumper;
+
+use constant EXTNAME => 'PS1_PS_RESULTS'; # Extension name for output table
+use constant EXTVER =>  1;
+
+my ( $input,			# Name of input Detectabilty Query table
+     $output,			# Name of output table
+     $save_temps,		# Save temporary files?
+     );
+
+GetOptions(
+	   'input|i=s'    => \$input,
+	   'output|o=s'   => \$output,
+	   'save-temps'   => \$save_temps,
+) or pod2usage( 2 );
+
+pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV;
+pod2usage( -msg => "Required options: --input --output",
+           -exitval => 3)
+    unless defined $input 
+    and defined $output;
+
+
+# The header kewords
+my $header = [
+        { name =>  'REQ_NAME', 
+                    writetype => TSTRING, 
+                    comment => 'Postage Stamp Request Name',
+                    value => undef
+        },
+        { name =>  'REQ_ID', 
+                    writetype => TULONG, 
+                    comment => 'Postage Stamp Server Request id',
+                    value => undef
+        },
+];
+
+# Specification of columns to write
+my $columns = [ 
+        # rownum from original request
+        { name => 'ROWNUM',   type => '20A', writetype => TSTRING }, 
+        # error code from processing this image
+        { name => 'ERROR_CODE',type => 'V',  writetype => TULONG }, 
+        # name of the postage stamp image
+        { name => 'IMG_NAME', type => '64A', writetype => TSTRING }, 
+        # job_id that produced this result
+        { name => 'JOB_ID',   type => 'V',   writetype => TULONG }, 
+        ### metadata from stamp
+        #
+        # coordinate at center of stamp, in degrees
+        { name => 'RA_DEG',  type => 'D',   writetype => TDOUBLE },
+        # coordinate at center of stamp, in degrees
+        { name => 'DEC_DEG', type => 'D',   writetype => TDOUBLE },
+
+        ### metdata from parent exposure
+
+        # actual start time of exposure
+        { name => 'MJD_OBS',  type => 'D',   writetype => TDOUBLE },
+        # field center at midpoint of expsure, in degrees
+        { name => 'RA_OBS',  type => 'D',   writetype => TDOUBLE },
+        # field center at midpoint of expsure, in degrees
+        { name => 'DEC_OBS', type => 'D',   writetype => TDOUBLE },
+        # actual filter
+        { name => 'FILTER',  type => '16A', writetype => TSTRING }, 
+        # exposure time of parent image
+        { name => 'EXPTIME', type => 'D',   writetype => TDOUBLE },
+        # original FPA_ID used at ingest
+        { name => 'FPA_ID',  type => '20A', writetype => TSTRING }, 
+
+        # the following are copied from the original pstamp request
+
+        # image selection parameters
+        { name => 'JOB_TYPE',   type => '16A', writetype => TSTRING },     
+        { name => 'PROJECT',    type => '16A', writetype => TSTRING }, 
+        { name => 'IMG_TYPE',   type => '16A', writetype => TSTRING },       
+        { name => 'ID',         type => '16A', writetype => TSTRING },            
+        { name => 'CLASS_ID',   type => '16A', writetype => TSTRING },    
+
+        # request type stamp, get_image, or list_uri
+        { name => 'REQ_TYPE',   type => '16A', writetype => TSTRING },        
+
+        # output parameters
+        { name => 'STAMP_NAME', type => '16A', writetype => TSTRING },  
+        { name => 'OPTION_MASK',type => 'J', writetype   => TULONG },     
+
+        { name => 'DATE_MIN',   type => 'D', writetype   => TDOUBLE },
+        { name => 'DATE_MAX',   type => 'D', writetype   => TDOUBLE },       
+        { name => 'REQFILT',    type => '16A', writetype => TSTRING },
+
+        # 2 bits in COORD_MASK indicate what units of roi coords are
+        { name => 'COORD_MASK', type => 'J', writetype => TULONG },  
+        { name => 'CENTER_X',   type => 'D', writetype => TDOUBLE },    
+        { name => 'CENTER_Y',   type => 'D', writetype => TDOUBLE },   
+        { name => 'WIDTH',      type => 'D', writetype => TDOUBLE },   
+        { name => 'HEIGHT',     type => 'D', writetype => TDOUBLE },  
+];
+
+my $in;
+if ($input eq '-') {
+    $in = \*STDIN;
+} else {
+    open $in, "<$input" or die "cannot open $input for reading";
+}
+
+my @colData;
+foreach (@$columns) {
+    push @colData, [];
+}
+
+
+my $numRows = read_data_for_table($in,'\|', \@colData, $header); 
+if (!$numRows) {
+    print STDERR "no data in $input\n";
+    exit 1;
+}
+
+my $status = make_fits_table($output, EXTNAME, $numRows, \@colData, $columns, $header);
+
+exit $status;
+
+# TODO: put this in a module
+
+# two utility functions that may be used to create a FITS binary
+# table from hashes describing the header keywords and columns
+
+# read_table_description reads the data for a table from a simple text file
+# make_fits_table writes out the table to a named file
+
+
+# A function to build a fits binary table from supplied data 
+# 
+sub make_fits_table {
+        my $output = shift;     # name of output file
+        my $extname = shift;    # extension name
+        my $numRows = shift;    # number of rows in the table
+        my $colData = shift;    # ref to array of arrays containing the data for each column
+        my $columns = shift;    # ref to array of column descriptions (each a hash)
+                                # with keys: name, type, and writetype
+        my $header = shift;     # ref to array of header keyword descriptions - each a hash
+                                # with keys: name, name, writetype, comment, and value
+        my $status = 0;
+
+        die "incorrect arguments" if !defined($columns);
+        # note $header can be nil
+
+        # build arrays for cfitsio
+        my @colNames;			# Names of columns
+        my @colTypes;			# Types of columns
+        my @colWriteType;               # type to use to write
+
+        foreach my $colSpec ( @$columns) {
+            push @colNames, $colSpec->{name};
+            push @colTypes, $colSpec->{type};
+            push @colWriteType, $colSpec->{writetype};
+        }
+
+        if (-e $output) {
+            unlink "$output" or die "failed to remove existing $output";
+        }
+
+        my $outFits = Astro::FITS::CFITSIO::create_file( $output, $status ); # Output file handle
+        check_fitsio( $status );
+
+        $outFits->create_img( 16, 0, undef, $status );
+        check_fitsio( $status );
+
+        # Create the table
+
+        $outFits->create_tbl( BINARY_TBL(), $numRows, scalar @colNames,
+                                \@colNames, \@colTypes, undef, $extname, $status );
+        check_fitsio( $status );
+
+        # if header keyword descriptions were provided add them
+        if ($header) {
+            foreach my $headerword ( @$header ) {
+                my $value = $headerword->{value};
+                unless (defined $value) {
+                    print "Can't find header keyword $headerword\n";
+                    next;
+                }
+                # zap quotation marks
+                $value =~ s/\'//g;
+                my $name    = $headerword->{name};
+                my $type    = $headerword->{writetype};
+                my $comment = $headerword->{comment};
+                $outFits->write_key( $type, $name, $value, $comment, $status );
+                check_fitsio( $status );
+            }
+        }
+
+
+        for (my $i = 0; $i < scalar @colNames; $i++) {
+            my $writeType = $colWriteType[$i];
+            $outFits->write_col( $writeType, $i + 1, 1, 1, $numRows, $colData->[$i], $status );
+            check_fitsio( $status );
+        }
+
+        $outFits->close_file( $status );
+
+        return 0;
+
+} # end of sub make_fits_table
+
+
+
+# read the table contents from a file
+#
+# input text file format:
+#   lines that begin with '#' are comment lines and are skipped.
+#   other lines are data. Each data line is split into fields with the
+#   provided separator
+#
+# if $header is not null header the first non-commented line is read to
+# fill the value for each header keyword. The number of fields must match
+# the number of keywords.
+#
+# Following the optional header data, each data line contains data for each
+# row in the table. The number of fields must match the number of column
+# arrays provided.
+
+sub read_data_for_table {
+    my $in      = shift;    # input file handle
+    my $sep     = shift;    # string containing field separator
+    my $colData = shift;    # reference to an array of arrays for the data
+    my $header  = shift;    # rerence to array of header keyword descriptions
+
+    my $line_num = 0;
+
+    # read data for header if any data is expected
+    if ($header) {
+        my $nhead = @$header;
+        while (my $line = <$in>) {
+            $line_num++;
+            next if ($line =~ /^#/);    # skip comment lines
+            chomp $line;
+            my @vals = split /$sep/, $line;
+            my $nvals = @vals;
+            die "number of header columns in input $nvals does not equal expected number of header words $nhead"
+                    if (@vals != @$header);
+
+            for (my $i=0; $i < @$header; $i++) {
+                $header->[$i]->{value} = $vals[$i];
+            }
+
+            last; # only one header line
+        }
+    }
+
+    my $row_num = 0;
+    my $ncols = @$colData;
+    while (my $line = <$in>) {
+        $line_num++;
+        next if ($line =~ /^#/);    # skip comment lines
+        chomp $line;
+
+        my @vals = split /$sep/, $line;
+        my $nvals = @vals;
+        die "number of columns $nvals in input does not equal expected number of header "
+                . " words $ncols on line $line_num" if ($nvals != $ncols);
+
+        for (my $col = 0; $col < @$colData; $col++) {
+            $colData->[$col]->[$row_num] = $vals[$col];
+        }
+        $row_num++;
+    }
+
+    # we return the number of rows read
+    return $row_num;
+}
+
+# From Astro::FITS::CFITSIO demo
+sub check_fitsio
+{
+    my $status = shift;		# Status of FITSIO calls
+
+    if ($status != 0) {
+	my $msg;		# Message to output
+	Astro::FITS::CFITSIO::fits_get_errstatus( $status , $msg );
+	die "CFITSIO error: $msg\n";
+    }
+}
Index: trunk/pstamp/scripts/pstamp_revert_request.pl
===================================================================
--- trunk/pstamp/scripts/pstamp_revert_request.pl	(revision 18537)
+++ trunk/pstamp/scripts/pstamp_revert_request.pl	(revision 18537)
@@ -0,0 +1,118 @@
+#!/bin/env perl
+
+# pstamp_finish.pl
+
+use warnings;
+use strict;
+
+use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt );
+use Pod::Usage qw( pod2usage );
+
+use Sys::Hostname;
+use IPC::Cmd 0.36 qw( can_run run );
+use File::Temp qw( tempfile );
+use File::Copy;
+
+use PS::IPP::Metadata::Config;
+use PS::IPP::Metadata::Stats;
+use PS::IPP::Metadata::List qw( parse_md_list );
+
+use PS::IPP::Config qw($PS_EXIT_SUCCESS
+		       $PS_EXIT_UNKNOWN_ERROR
+		       $PS_EXIT_SYS_ERROR
+		       $PS_EXIT_CONFIG_ERROR
+		       $PS_EXIT_PROG_ERROR
+		       $PS_EXIT_DATA_ERROR
+		       $PS_EXIT_TIMEOUT_ERROR
+		       metadataLookupStr
+		       metadataLookupBool
+		       caturi
+		       );
+
+
+my ( $req_id, $dbname, $verbose, $save_temps );
+
+GetOptions(
+	   'req_id=s'   => \$req_id,
+	   'dbname=s'   => \$dbname,
+	   'verbose'    => \$verbose,
+	   'save-temps' => \$save_temps,
+) or pod2usage( 2 );
+
+pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV;
+
+my $missing_tools;
+
+my $pstamptool  = can_run('pstamptool')  or (warn "Can't find pstamptool"  and $missing_tools = 1);
+my $dsreg  = can_run('dsreg')  or (warn "Can't find dsreg"  and $missing_tools = 1);
+
+if ($missing_tools) {
+    warn("Can't find required tools.");
+    exit ($PS_EXIT_CONFIG_ERROR);
+}
+
+my $ipprc = PS::IPP::Config->new(); # IPP Configuration
+
+my $outputDataStoreRoot = metadataLookupStr($ipprc->{_siteConfig}, 'DATA_STORE_ROOT');
+exit ($PS_EXIT_CONFIG_ERROR) unless defined $outputDataStoreRoot; # lookup failure outputs a message
+
+my $mdcParser = PS::IPP::Metadata::Config->new; # Parser for metadata config files
+
+my $req;
+{
+    my $command = "$pstamptool -listreq -req_id $req_id";
+    $command   .= " -dbname $dbname" if $dbname;
+    my ( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
+        run(command => $command, verbose => $verbose);
+    unless ($success) {
+        die("Unable to perform $command error code: $error_code");
+    }
+    my $output = join "", @$stdout_buf;
+    if (!$output) {
+        if ($verbose) {
+            print STDERR "no requests found\n"
+        }
+        exit 0;
+    }
+    my $metadata = $mdcParser->parse($output) or die("Unable to parse metdata config doc");
+
+    my $requests = parse_md_list($metadata);
+
+    $req = $requests->[0];
+
+    die "request $req_id not found in metadata config doc" if !$req;
+}
+
+my $product = $req->{outProduct};
+
+my $req_name = $req->{name};
+
+# set the output fileset's name to the request name.
+my $fileset = $req_name;
+
+# Here we invoke the assumption that the output for the request is placed in the
+# fileset directory directly
+my $out_dir = "$outputDataStoreRoot/$product/$fileset";
+
+print STDERR "product: $product  REQ_NAME: $req_name $out_dir\n" if $verbose;
+
+if ($product and $fileset) {
+    my $command = "$dsreg --del $fileset --product $product --rm --force";
+    $command .= " --dbname $dbname" if $dbname;
+    my ( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
+        run(command => $command, verbose => $verbose);
+    unless ($success) {
+        die "Unable to perform $command error code: $error_code";
+    }
+}
+
+
+{
+    my $command = "$pstamptool -revertreq -req_id $req_id";
+    $command   .= " -dbname $dbname" if $dbname;
+    my ( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
+        run(command => $command, verbose => $verbose);
+    unless ($success) {
+        die("Unable to perform $command error code: $error_code");
+    }
+}