#!/usr/bin/perl # # cgimake for Safari # Copyright (c) 1999 by Barrie Slaymaker, rbs@telerama.com # # 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/$value\n" ; $value =~ s/\n/
\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]/, ) ) ; 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=' 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" ), "

\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( "From '$_':
\n


\n" ) if $debug ; open( TARGET, "<$_" ) or error( "Couldn't open '$_': $!" ) ; my $debug_header_detected = 0 ; my $debug_header_printed = 0 ; while ( ) { if ( $debug && ! $debug_header_printed && /^(\S+:|\s*$)/ ) { unless ( $debug_header_detected ) { print( "" ) ; $debug_header_detected = 1 ; } chomp ; if ( /^\s*$/ ) { print( "
\n" ) ; $debug_header_printed = 1 ; } else { print( $_, "
\n" ) ; } next ; } print ; print LOG if $log_debug ; } close( TARGET ) ; print( "
\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/&/&/g ; $message =~ s//>/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 ) , "

$title::
", '

' ,
	;
   }
   print( join( "\n", @message ) ) ;
   print '
' ; 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 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