pjs/webtools/doctor/Doctor.pm

#!/usr/bin/perl -w

package Doctor;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(%CONFIG);  # symbols to export on request

use strict;

use File::Temp qw(tempfile tempdir);
use Template;
use AppConfig qw(:expand :argcount);
use CGI;
use Cwd qw(getcwd);

# Create an AppConfig object and populate it with parameters defined
# in the configuration file.
# Note: Look in the configuration file for descriptions of each parameter.
our $config = AppConfig->new({ 
    CASE    => 1,
    CREATE  => 1 , 
    GLOBAL  => { ARGCOUNT => ARGCOUNT_ONE }
});
$config->file("doctor.conf");
our %CONFIG = $config->varlist(".*");

# Create the global template object that processes templates and specify
# configuration parameters that apply to templates processed in this script.
my $_template;
sub template {
    my $class = shift;
    # INCLUDE_PATH is a colon-separated list of directories containing templates.
    $_template ||= Template->new({INCLUDE_PATH => getcwd() . "/templates",
                                  PRE_CHOMP    => 1,
                                  POST_CHOMP   => 1});
    return $_template;
}

my $_cgi;
sub cgi {
    my $class = shift;
    $_cgi ||= new CGI();
    return $_cgi;
}

sub system_capture {
    # Runs a command and captures its output and errors.  This should be using
    # in-memory files, but they require that we close STDOUT and STDERR
    # before reopening them on the in-memory files, and closing and reopening
    # STDERR causes CVS to choke with return value 256.
  
    my ($command, @args) = @_;
  
    my ($rv, $output, $errors);
  
    # Back up the original STDOUT and STDERR so we can restore them later.
    open(OLDOUT, ">&STDOUT") or die "Can't back up STDOUT to OLDOUT: $!";
    open(OLDERR, ">&STDERR") or die "Can't back up STDERR to OLDERR: $!";
    use vars qw( *OLDOUT *OLDERR ); # suppress "used only once" warnings
  
    # Close and reopen STDOUT and STDERR to in-memory files, which are just
    # scalars that take output and append it to their value.
    # XXX Disabled in-memory files in favor of temp files until in-memory issues
    # can be worked out.
    #close(STDOUT);
    #close(STDERR);
    #open(STDOUT, ">", \$output) or die "Can't open STDOUT to output var: $!";
    #open(STDERR, ">", \$errors) or die "Can't open STDERR to errors var: $!";
    my $outfile = tempfile();
    my $errfile = tempfile();
    # Perl 5.6.1 filehandle duplication doesn't support the three-argument form
    # of open, so we can't just open(STDOUT, ">&", $outfile); instead we have to
    # create an alias OUTFILE and then do open(STDOUT, ">&OUTFILE").
    local *OUTFILE = *$outfile;
    local *ERRFILE = *$errfile;
    use vars qw( *OUTFILE *ERRFILE ); # suppress "used only once" warnings
    open(STDOUT, ">&OUTFILE") or open(STDOUT, ">&OLDOUT")
                                 and die "Can't dupe STDOUT to output file: $!";
    open(STDERR, ">&ERRFILE") or open(STDOUT, ">&OLDOUT")
                                 and open(STDERR, ">&OLDERR")
                                 and die "Can't dupe STDERR to errors file: $!";
  
    # Run the command.
    $rv = system($command, @args);
  
    # Grab output and errors from the temp files.  In a block to localize $/.
    # XXX None of this would be necessary if in-memory files was working.
    {
        local $/ = undef;
        seek($outfile, 0, 0);
        seek($errfile, 0, 0);
        $output = <$outfile>;
        $errors = <$errfile>;
    }

    # Restore original STDOUT and STDERR.
    close(STDOUT);
    close(STDERR);
    open(STDOUT, ">&OLDOUT") or die "Can't restore STDOUT from OLDOUT: $!";
    open(STDERR, ">&OLDERR") or die "Can't restore STDERR from OLDERR: $!";

    return ($rv, $output, $errors);
}

1;  # so the require or use succeeds