cgimake #5

#!/usr/bin/perl

#
# cgimake for Safari
# Copyright (c) 1999 by Barrie Slaymaker, [email protected]
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#

use File::Basename ;
use File::Path ;
use Cwd ;
use Fcntl qw( LOCK_EX LOCK_UN ) ;

#
# Set $debug = 1 to force debugging output. Some web servers don't like to
# see both PATH_INFO and QUERY_STRING data, so this allows you to debug when
# using PATH_INFO if that describes your web server.
#
$debug = 0 ;
$debug_make = 0 ;
$force = 0 ;
$dump_env = 0 ;
$log_debug = 0 ;

#
# These subs needed in BEGIN
#
sub print_debug {
   return unless $debug || $log_debug ;

   my $name = shift ;
   my $value ;

   if ( ref( $_[ 0 ] ) eq 'ARRAY' ) {
      $value = join( '", "', @{$_[ 0 ]} ) ;
   }
   else {
      $value = join( "\n", @_ ) ;
   }

   my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
   my $time_stamp = sprintf( "%04d/%02d/%02d %02d:%02d:%02d", 
      $year + 1900, $mon, $mday, $hour, $min, $sec ) ;

   $name = defined( $name ) ? ( $cgi->b( $name ) . ': ' ) : '' ;

   print( LOG $time_stamp, ' ', $name, '"', $value, "\"\n" )
      if $log_debug ;

   $value =~ s/&/&/g ;
   $value =~ s/</&lt;/g ;
   $value =  sprintf( qq{%s %-25s "%s"}, $time_stamp, $name, $value ) ;
   $value =~ s/ /&nbsp;/g ;   
   $value = "<TT>$value</TT>\n" ;
   $value =~ s/\n/<BR>\n/g ;

   print( $value )
      if $debug ;

}


sub read_config {
   my $file = shift ;
   return unless -f $file ;
   if (  ! exists( $configs{$file} )
      || -M $file < $configs{$file}->{mtime}
      ) {
      print_debug( 
	 "Reading", 
	 sprintf( 
	    "$file (%f < %f)", 
	    -M $file, 
	    ( %{$configs{$file}} && defined $configs{$file}->{mtime} ) ?
	    $configs{$file}->{mtime} :
	    'undef'
	 )
      ) ;
      open( CONF, "<$file" ) || 
	 die( "$!: open $file" );
      # Skip lines that are all comment, since there are often so many.
      $conf = join( '', grep( /^\s*[^#\s]/, <CONF> ) ) ;
      close( CONF ) ;
      $configs{$file}->{mtime} = -M $file ;
      $configs{$file}->{conf}  = "$conf" ;
   }
   print_debug( "eval()ing", "$file" ) ;
#   print_debug( "eval()ing", $configs{$file}->{conf} ) ;
   eval( $configs{$file}->{conf} ) ;
   die( "Error evaluating $file: $@" )
      if $@ ;
}


#
# Do some things only once under mod_perl
#
BEGIN {
   # Auto-detect if we are running under mod_perl or CGI.
   $USE_MOD_PERL = ( (exists $ENV{'GATEWAY_INTERFACE'}
      and $ENV{'GATEWAY_INTERFACE'} =~ /CGI-Perl/)
      or exists $ENV{'MOD_PERL'} ) ? 1 : 0;

   $progname = basename( $0 ) ;

   #
   # $cnfig_dir sets where to look for the config files that are determined
   # by the QUERY_STRING term 'project=<project_name>' or by the script's
   # name (ie basename $0 ) if there's no such string in QUERY_STRING.
   # either way a .conf gets appended to it.
   #
   $config_dir= '/home/barries/src/safari/conf' ;

   $debug = 0 ;
   $log_debug = 0 ;
   read_config( "$config_dir/$progname.conf" ) ;
}


# Note: we don't use -w or 'use strict', for speed and for compatibility with
# older perls.  This script is pretty simple so that should be OK.

#############################################################################
#
# Setup processing.  This is done before config options are set to allow 
# access to $debug and @targets while setting the config options.
#

$in_error = 0 ;

#
# Prevent CGI.pm from going in to command line mode, then set it's
# parameters to those in ARGV. This lets users say things like
# "cd project ; cgimake http/somthing" if need be.
#

use CGI qw( -no_debug ) ;

$progname = basename( $0 ) ;

#
# Grab command line parameters and use them if we're not in a cgi environment
#
my $query_string ;
$query_string = join( '&', @ARGV )
   if @ARGV && ! defined $ENV{REQUEST_METHOD} ;
$cgi = CGI->new( $query_string ) ;

$debug ||= ( $cgi->param( 'debug' ) || grep( /^debug$/i, $cgi->keywords() ) ) ;

$debug_make ||= ( $cgi->param( 'debug_make' ) || grep( /^debug_make$/i, $cgi->keywords() ) ) ;

$dump_env ||= $cgi->param( 'dump_env' ) || grep( /^dump_env$/i, $cgi->keywords() );

$debug ||= $dump_env ;
   
print( $cgi->header, $cgi->start_html( "$progname debug output" ), "<P>\n" )
   if $debug ;

$log_debug ||= (
   $cgi->param( 'log_debug' ) || 
   grep( /^log_debug$/i, $cgi->keywords() ) || 
   $debug
) ;

$force ||= $cgi->param( 'force' ) || grep( /^force$/i, $cgi->keywords() ) ;
print_debug( 'force', 'yes' ) if $force ;

$project = $cgi->param( 'project' ) ;
print_debug( 'project', $project ) ;

#
# Acquire targets
#
@targets = () ;
@targets = split( /\s*,\s*/, $cgi->param( 'targets' ) )
   if defined $cgi->param( 'targets' ) ;

@targets = 
   grep( ! /^((log_)?debug|debug_make|force|dump_env)$/i, $cgi->keywords() )
   unless @targets ;

my $path_info = $cgi->path_info() ;
@targets = ( $path_info ) 
   if length( $path_info ) && ! @targets ;

#
# If no project specified yet, see if the first dirname in the first
# target matches the name of a subdir (ie project name) under the config dir.
# If it does, then that's our project name, so peel it off.
# Assume all targets begin with project name in this case, and that
# all targets are in the same project. Should be an error if targets
# are in different project.
#
if ( ! defined $project && @targets && length( $targets[0] ) ) {
   my ( $first_target_dir ) = $targets[0] =~ m@^/([^/]*)/@ ;
   if ( length( $first_target_dir ) && -d "$config_dir/$first_target_dir" ) {
      $project = $first_target_dir ;
      for ( @targets ) { 
         s@^/([^/]*)@@ ;
         my $other_project = $1 ;
         error( "Targets in different projects: $project and $other_project" )
            unless $other_project eq $project ;
      }
      print_debug( 'project', $project ) ;
   }
}

print_debug( 'Raw Targets', \@targets ) ;


$result_mode = lc( $cgi->param( 'result' ) )
   if ( 
      defined( $cgi->param( 'result' ) ) && 
      $cgi->param( 'result' ) =~ /^(make|targets?)$/i
   ) ;

if ( $dump_env ) {
   for ( sort keys %ENV ) {
      print_debug( $_, $ENV{$_} ) ;
   }
}

configure() ;

#
#
#############################################################################
#############################################################################
#
# The main body
#

#
# Let mod_perl send things as soon as we print them
#
local $| = 1 ;

open( LOG, ">>/home/httpd_mod_perl/logs/cgimake.$$" ) ;

$orig_cwd = cwd() ;
chdir( $work_root ) ;

map{ $_ = &target_fixup ; } @targets ;

error( "No targets to make" )
   unless ( @targets ) ;

print_debug( 'Edited Targets', \@targets ) ;

map { 
   $_ =~ s@(.*)/$@_dir$1/index.html@ ;
   $_ = $output_root . $_ ;
} @targets ;

print_debug( 'Final Targets', \@targets ) ;

if ( $lock_mode =~ /^targets?$/ ) {
   for ( @targets ) {
      get_lock( $_ ) ;
   }
}
elsif ( $lock_mode eq 'global' ) {
   get_lock( '/global' ) ;
}

$command_line = join( 
   ' ', 
   ( 
      $make_path, 
      $make_options . ( $debug_make ? " -d" : "" ),
      @targets, 
      '2>&1' 
   ) 
) ;

print_debug( 'Command Line', $command_line ) ;

unless ( $result_mode eq 'nomake' ) {
   if ( $make_target_dirs ) {
      my @errors ;

      for ( @targets ) {
         my $target_dir = dirname( $_ ) ;
         next if -d $target_dir ;
         if ( -e $target_dir ) {
            push(@errors,"Couldn't make directory '$target_dir': file exists");
         }
         else {
            mkpath( $target_dir, $debug, 0750 ) ;
            push( @errors, "Couldn't make directory '$target_dir': $!" )
               unless -d $target_dir ;
         }
      }
      error( @errors ) if @errors ;
   }

   for ( @targets ) {
      if ( -e $_ ) {
         if ( $force ) {
            print_debug( undef, "unlinking $_ due to force option" ) ;
            unlink( $_ ) || error( "unlink $_ (force): $!" ) ;
         }
         elsif ( -s $_ < 20 ) {
            print_debug( undef, "unlinking $_ due to size" . -s $_ ) ;
            unlink( $_ ) || error( "unlink $_ (size): $!" ) ; ;
         }
      }
   }
   my %old_env = %ENV ;
   my $path = $ENV{PATH} ;
   $ENV{PATH} = join( ':', @path_prefix, $ENV{PATH} ) ;
   $ENV{CGIMAKE_PROJECT} = $project ;
   $ENV{CGIMAKE_CONFIG_DIR} = $config_dir ;
   %ENV = ( %ENV, %env_override )
      if %env_override ;
   if ( $dump_env ) {
      for ( sort keys %ENV ) {
	 print_debug( $_, $ENV{$_} ) ;
      }
   }

   $make_stdout = `$command_line` ;
   %ENV = %old_env ;
}

print_debug( 'Make stdout', $make_stdout ) ;

error( qq{make returned $?

Command Line:
'$command_line'

Output:
'$make_stdout'
} )
   if $? ;

if ( $result_mode =~ /^(targets?|nomake)$/ ) {
   $found = 0 ;
   for ( @targets ) {
      if ( -e $_ ) {
#         if ( ( -s $_ ) < 20 ) {
#            print_debug( undef, "unlinking $_ due to size " . -s $_ ) ;
#            unlink( $_ ) || error( "unlinking $_: $!" ) ;
#            next ;
#         }
         ++$found ;
         print( "<B>From '$_':</B><BR>\n<HR>\n" ) if $debug ;

         open( TARGET, "<$_" ) or error( "Couldn't open '$_': $!" ) ;
         my $debug_header_detected = 0 ;
         my $debug_header_printed = 0 ;
         while ( <TARGET> ) {
            if ( $debug && ! $debug_header_printed && /^(\S+:|\s*$)/ ) {
                unless ( $debug_header_detected ) {
                   print( "<TT>" ) ;
                   $debug_header_detected = 1 ;
                }
                chomp ;
                if ( /^\s*$/ ) {
                   print( "</TT><HR ALIGN=\"LEFT\" WIDTH=\"25%\">\n" ) ;
                   $debug_header_printed = 1 ;
                }
                else {
                   print( $_, "<BR>\n" ) ;
                }
                next ;
            }

            print ;
            print LOG if $log_debug ;
         }
         close( TARGET ) ;

         print( "<HR>\n" ) if $debug ;
      }
      else {
         print_debug( "Doesn't exist", $_ ) ;
      }
   }
   error( $command_line, "\n", $?, "\nNo targets made\n", $result, $make_stdout ) 
      unless $found ;
}
elsif ( $result_mode eq 'make' ) {
   print( $cgi->header, $cgi->start_html( $message ) ) unless $debug ;
   print( 
      $cgi->p( $cgi->b( 'Make stdout' ) ), 
      "\n", 
      $cgi->pre( $make_stdout ), 
      "\n" 
   ) ;
   print( $cgi->end_html ) ;
}
else {
   error( "Invalid value for \$result_mode: '$result_mode'" ) ;
}

unlock_all() ;

print( $cgi->end_html ) if $debug ;

chdir( $orig_cwd ) ;

my_exit( 0 ) ;

#
#
#############################################################################
#############################################################################
#
# Subroutines
#

sub error {
   return if $in_error ;# || ( ! $debug && ! $log_debug ) ;

   $in_error = 1 ;

   unlock_all() ;

   $message = 
      join( 
        '', 
        map{ 
           my $out = $_ ; 
           $out =~ s/([^\n])$/$1\n/ ; 
           $out 
        } @_ 
      ) ;

   if ( defined( $email_errors ) && length( $email_errors ) ) {
      if ( open( MAIL, "| mail -s \"Safari error\" $email_errors" ) ) {
         print( MAIL $message ) or
            $message .= "Couldn't print to mail pipe: $!\n";
         close( MAIL ) or
            $message .= "Couldn't close mail pipe: $!\n";
      }
      else {
         $message .= "Couldn't open mail pipe: $!\n" ;
      }
   }
   $message =~ s/&/&amp;/g ;
   $message =~ s/</&lt;/g ;
   $message =~ s/>/&gt;/g ;
   @message = split( /\r?\n/, $message ) ;

   if ( ! $debug ) {
      my $title = '404 Not Found because make failed' ;
      print $cgi->header( -status=>"404 Not Found" ),
        $cgi->start_html( $title ) ,
	"<P><BIG><STRONG>$title:</STRONG></BIG>:<BR>",
	'<PRE>' ,
	;
   }
   print( join( "\n", @message ) ) ;
   print '</PRE>' ;

   chdir( $orig_cwd ) ;

   $in_error = 0 ;

   my_exit( 0 ) ;
}


my @locks ;

sub get_lock {
   my $lock_file_name = shift ;

   my $lock_file_name = "$lock_root/$lock_file_name" ;

   print_debug( "Locking", $lock_file_name ) ;

   my $lock_file_dir = dirname( $lock_file_name ) ;
   unless ( -d $lock_file_dir ) {
      mkpath( $lock_file_dir, $debug, 0750 ) ;

      error( "couldn't create '$lock_file_dir'" ) 
         unless -d $lock_file_dir ;
   }

   $lock_file_name .= ".dir_lock"
      if -d $lock_file_name || $lock_file_name =~ m@/$@ ;

   open( LOCKFILE, ">$lock_file_name" ) or
      error( "couldn't open $lock_file_name: $!" ) ;
   eval {
      flock( LOCKFILE, LOCK_EX ) or
         die $! ;
   } ;
   error( "couldn't lock $lock_file_name: $@" )
      if $@ ;

   push( @locks, { FH => \*LOCKFILE, NAME => $lock_file_name } ) ;
}


sub unlock_all {
   my @errors ;
   while ( @locks ) {
      my $hash = pop @locks ;
      print_debug( "Unlocking", $hash->{NAME} ) ;

      eval {
         flock( $hash->{FH}, LOCK_UN ) or
            die $! ;
      } ;
      error( "couldn't unlock " . $hash->{NAME} . ": $@" )
         if $@ ;
   }
   error ( @errors ) if @errors ;
}


sub configure {
   $output_root = 'http' ;
   $lock_root   = 'lock' ;
   $lock_mode   = 'global' ;
   @path_prefix = ( "bin" ) ;
   %env_override = () ;

   sub target_fixup { return $_ } ;

   read_config( "$config_dir/$progname.conf" ) ;
   read_config( "$config_dir/$project/$progname.conf" )
      if defined( $project ) && length( $project ) ;

   # We don't absolutify $output_root, since we chdir() there.
   $lock_root = absolutify( $work_root, $lock_root   ) ;
   map{ $_ = absolutify( $config_dir, $_ ) } @path_prefix ;

   map {
      eval( "print_debug( '$_', $_ )" ) ;
   } sort( 
      qw( 
      	 $work_root
	 $lib_root 
   	 $output_root 
      	 $lock_root 
	 $lock_mode 
	 $make_path
         $make_options
         $result_mode
      ) 
   ) ;
}


sub absolutify {
   my ( $base, $path ) = @_ ;

   return ( substr( $path, 0, 1 ) eq '/' ) ? $path : "$base/$path" ;
}


sub my_exit{
   # Apache::exit(-2) will cause the server to exit gracefully,
   # once logging happens and protocol, etc  (-2 == Apache::Constants::DONE)
   $USE_MOD_PERL ? Apache::exit($_[0]) : CORE::exit($_[0]);
}


=head1 NAME

cgimake - use make as a cgi-bin script coordinator

=head1 DESCRIPTION

This script is alpha level.  See L</TODO> for more information.

cgimake is a wrapper around make that allows make to be used as
a cgi-bin program.  This allows several convenient things:

=over

=item optimizing multistep processing

Multi-step processes that end in cgi-bin script being called can be broken
apart using dependencies so that the whole process need not be run every time.
This is most useful for when several cgi-bin scripts share intermediate files
produced by (often slow) backend processes which can also be called from make.


=item caching output from other cgi-bin scripts

cgimake can cache the output from existing (slow) cgi-bin programs and only 
run them when necessary.  This needs a few things worked out to make it
work fully.


=item web site updates

If you keep web materials in an archival system (like CVS), cgimake can
be used to automatically check out the latest version whenever a new
version gets checked in.  This can be done for every request, or by
using a form as a control panel and doing the checkouts by submitting
the form.

=item standard Makefile syntax

Since this currently uses an existing make, most of the configuration takes
place by writing a Makefile.  The primary limitation in caching scenarios is
that the GNU pattern (%) rules are often necessary. In some cases, implicit
rules can be used to do this.

=back

Rudimentary locking facilities are provided, see the source code.


=head1 TODO

=over

=item mod_perl support

Needed for performance reasons.

=item *

Improved documentation.  A lot of it.

=item *

Integration with GNU compatible Make.pm (which is not in general release yet).
This should allow fine-grained locking and access to perlish extensions to
GNU Make.

=item *

Extensions to allow calling other cgi-bin programs to
use as a caching mechanism. I think the main issue here is coming up with
a way of mapping query data for GET methods (at least) in to
unique filenames to use to hold the cached output from whatever cgi-bin
program's being called.

=item *

Use File::Spec for portability and for preventing odd behavior if symbolic
links are used in building cgimake's working directories.

=item *

Better handling of '..' in requested targets. Currently they're forbidden,
but they should be allowed in cases where they aren't a security hazard.
They are OK whenever they don't try to updir out of the working directories.

=back

=head1 PREREQUISITES

A recent perl with standard packages, and a make program that supports
GNU make's pattern rule syntax.

=head1 COREQUISITES

CGI

=pod OSNAMES

Unix, Win32

=pod SCRIPT CATEGORIES

CGI

=cut