1# $Id: Mpp.pm,v 1.14 2012/03/04 13:56:35 pfeiffer Exp $ 2 3=head1 NAME 4 5Mpp - Common subs for makepp and makeppreplay 6 7=head1 DESCRIPTION 8 9This package contains basic stuff for makepp. 10 11=cut 12 13package Mpp; 14 15use strict; 16use Config; 17 18our $progname; 19BEGIN { 20 $progname ||= 'makepp'; # Use a constant string, even for mpp, to make IDE parsing easy. 21 eval "sub ARCHITECTURE() { '$Config{archname}' }"; # Get a tag for the architecture. 22} 23 24use Mpp::Text; 25 26# 27# Signal handling and exiting 28# 29# Do this early, because the END block defined below shall be the first seen 30# by perl, such that it is the last executed. Unless we need to propagate a 31# signal, it leaves the process via POSIX::_exit, so that no expensive garbage 32# collection of Mpp::File objects occurs. All other places can use die or normal 33# exit. If you define additional END blocks in any module, you must take care 34# to not reset $?. 35# 36{ 37 my (%signo, @signame); 38 if(defined(my $sig_name = $Config{sig_name})) { 39 my $i=0; 40 for my $name (split(' ', $sig_name)) { 41 $signo{$name} ||= $i; 42 $signame[$i] = $name; 43 $i++; 44 } 45 } 46 sub signo { 47 $signo{$_[0]} || $_[0]; 48 } 49 sub signame { 50 $signame[$_[0]] || $_[0]; 51 } 52} 53 54our $int_signo = signo 'INT'; 55our $quit_signo = signo 'QUIT'; 56 57my $logfh; 58our @close_fhs = \(*STDOUT, *STDERR); 59my $warn_level = 1; # Default to warning. 60 61our $critical_sections = 0; 62 63our $n_files_changed = 0; # Keep track of the number of files that 64 # we actually changed. 65our $n_phony_targets_built = 0; # Keep track of the number of phony targets 66 # built, too. 67our $error_found = 0; # Non-zero if we found an error. This is used 68 # to stop cleanly when we are doing a parallel 69 # build (unless -k is specified). 70our $failed_count = 0; # How many targets failed. TODO: my when moving build et al here 71our $build_cache_hits = 0; # Number of the files changed that were 72 # imported from a build cache. 73our $rep_hits = 0; # Number of the files changed that were 74 # imported from a rep. 75our $print_directory = 1; # Default to printing it. 76our $log_level = 2; # Default to logging. 1: STDOUT, 2: $logfile 77sub log($@); 78 79my @signals_to_handle = is_windows > 0 && is_perl_5_6 ? 80 () : # ActiveState 5.6 doesn't define signals. 81 qw/INT QUIT HUP TERM/; 82{ 83 my %pending_signals; 84 sub suicide { 85 my ($sig) = @_; 86 $SIG{$sig} = 'DEFAULT'; 87 88 # If we're propagating a signal from a subprocess that produced a core 89 # dump, then we want to propagate the same signal without overwriting 90 # the core file. This is true even if the subprocess didn't produce a 91 # core dump, because it could be propagating a signal from its child 92 # that did produce a core dump. 93 $sig = 'INT' if $sig eq 'QUIT' && 94 !(require BSD::Resource && BSD::Resource::setrlimit( &BSD::Resource::RLIMIT_CORE, 0, 0 )); 95 96 kill $sig, $$; 97 POSIX::_exit(0x80 | signo($sig)); # just in case; 98 } 99 sub handle_signal { 100 my $sig = $_[0]; 101 102 # Do nothing on SIGINT or SIGQUIT if there are external processes. These 103 # signals are sent to all child processes as well, and if any of those 104 # processes propagates them, then we will too. Otherwise we ignore them 105 # completely (which is the UNIX convention). 106 return if $Mpp::Event::n_external_processes && 107 ($sig eq 'INT' || $sig eq 'QUIT'); 108 109 $pending_signals{$sig} = 1; 110 # If there's nothing that we absolutely have to do before terminating, then 111 # just terminate. 112 exit unless $critical_sections; 113 114 &Mpp::Event::Process::terminate_all_processes; 115 } 116 # This gets called after a critical section is completed: 117 sub propagate_pending_signals { 118 die if $critical_sections<0; 119 return if $critical_sections; 120 exit 2 if grep $_, values %pending_signals; 121 } 122 sub reset_signal_handlers { 123 @SIG{@signals_to_handle} = ( 'DEFAULT' ) x @signals_to_handle; 124 } 125 # Autovivification of hash elements probably isn't reentrant, so initialize 126 # them here in case we're using Perl 5.6. 127 @pending_signals{@signals_to_handle} = ( 0 ) x @signals_to_handle; 128 129 END { 130 Mpp::log N_REP_HITS => $rep_hits 131 if $log_level && $rep_hits; 132 Mpp::log N_CACHE_HITS => $build_cache_hits 133 if $log_level && $build_cache_hits; 134 Mpp::log N_FILES => $n_files_changed, $n_phony_targets_built, $failed_count 135 if defined $logfh; # Don't create log for --help or --version. 136 if( exists $Devel::DProf::{VERSION} ) { # Running with profiler? 137 warn "Doing slow exit, needed for profiler.\n"; 138 } else { 139 close $_ for @close_fhs; 140 $pending_signals{$_} && suicide $_ for keys %pending_signals; 141 POSIX::_exit $?; 142 } 143 } 144 145} 146@SIG{@signals_to_handle} = ( \&handle_signal ) x @signals_to_handle; 147 148my $invocation = join_with_protection($0, @ARGV); 149 150for( qw(/usr/xpg4/bin/sh /sbin/xpg4/sh /bin/sh) ) { 151 if( -x ) { 152 $ENV{SHELL} = $_; # Always use a hopefully Posix shell. 153 last; 154 } 155} 156delete $ENV{PWD}; # This is dangerous. 157 158our $indent_level = 0; # Indentation level in the log output. 159our $keep_going = 0; # -k specified. 160my $logfile; # Other than default log file. 161our $parallel_make = 0; # True if we're in parallel make mode. 162our $profile = 0; # Log messages about execution times. 163our $verbose; 164our $quiet_flag; # Default to printing informational messages. 165 166$SIG{__WARN__} = sub { 167 my $level = ($_[0] =~ /^(?:error()|info): /s) ? '' : 'warning: '; 168 my $error = defined $1; 169 if( $log_level == 2 ) { 170 &Mpp::log() unless defined $logfh; # Only open the file. 171 print $logfh "*** $level$_[0]"; 172 } 173 print STDERR "$progname: $level$_[0]" if $error or $warn_level; 174}; 175 176 177 178=head2 Mpp::log 179 180 Mpp::log KEY => {object | array of objects | string} ... 181 if $log_level; 182 183The list of available KEYs is present in makepplog. If you pass an non-key 184str if will later be output verbatim. The objects must have a method `name'. 185 186This log overrides logarithm (which is not needed by makepp). Because of 187this, and because it is not exported, it must always be invoked as Mpp::log. 188 189The log format contains a few control chars, denoted here as ^A, ^B ... 190 191The first line is special, the invocation preceded by "logversion^A" as 192explained at @obsolete_msg in makepplog. 193 194A leading ^B is stripped, but tells makepplog to outdent, and a leading ^C to 195indent. After that a line with no ^A is considered plain text. Else it is 196split on the ^A`s. There must be a ^A at the line end, which allows having 197multine fields between ^A`s. If the resulting fields contain ^B`s they are 198lists of simple fields, else just one simple field. 199 200The first field is a message I<key>. The others work as follows. If the 201simple fields contain ^C`s they are ref definitions of up to 4 fields: 202 203 ref[^Cname[^Cdir-ref[^Cdir-name]]] 204 205The I<refs> are numbers (hex on HP/UX with 64bit pointers) and the I<names> 206are to be remembered by makepplog for these numbers. If a I<dir-name> is 207present, that is remembered for I<dir-ref>, else it has been given earlier. 208If a I<dir-ref> is given, that is prepended to I<name> with a slash and 209remembered for I<ref>. Else if only I<name> is given that is remembered for 210I<ref> as is. If I<ref> is alone, it has been given earlier. Makepplog will 211output the remembered name for refs between quotes. 212 213The fields may also be plain strings if they contain no known I<ref>. Due to 214the required terminator, the strings may contain newlines, which will get 215displayed as \n. For keys that start with N_, all fields are treated as plain 216numbers, even if they happen to coincide with a I<ref>. 217 218=cut 219 220use Mpp::File; 221use Mpp::Cmds; 222 223my $last_indent_level = 0; 224sub log($@) { 225 226 # Open the log file if we haven't yet. Must do it dynamically, because 227 # there can be messages (e.g. from -R) before handling all options. 228 unless( defined $logfh ) { 229 if( $log_level == 1 ) { 230 (my $mppl = $0) =~ s/\w+$/makepplog/; 231 -f $mppl or 232 substr $mppl, 0, 0, absolute_filename( $Mpp::original_cwd ) . '/'; 233 open $logfh, '|' . PERL . " $mppl -pl-" or # Pass the messages to makepplog for formatting. 234 die "$progname: can't pipe to `makepplog' for verbose option--$!\n"; 235 } else { 236 if( $logfile ) { 237 my( $dir ) = $logfile =~ /(.+)\//; 238 Mpp::Cmds::c_mkdir -p => $dir if $dir; 239 } else { 240 mkdir '.makepp'; # Just in case 241 $logfile = '.makepp/log'; 242 } 243 unless( open $logfh, '>', $logfile ) { 244 warn "$progname: can't create log file ./$logfile--$!\n"; 245 $log_level = 0; 246 return; 247 } 248 } 249 push @close_fhs, $logfh; 250 printf $logfh "3\01%s\nVERSION\01%s\01%vd\01%s\01\n", $invocation, $Mpp::VERSION, $^V, ARCHITECTURE; 251 252 # If we're running with --traditional-recursive-make, then print the directory 253 # when we're entering and exiting the program, because we may be running as 254 # a make subprocess. 255 256 Mpp::Rule::print_build_cwd( $CWD_INFO ) 257 if defined $Mpp::Recursive::traditional; 258 259 return unless @_; # From __WARN__ 260 } 261 262 print $logfh 263 join "\01", 264 $indent_level == $last_indent_level ? shift() : # Cheaper than passing a slice to map 265 ($indent_level < $last_indent_level ? "\02" : "\03") . shift, 266 map( { 267 if( !ref ) { 268 $_; 269 } elsif( 'ARRAY' eq ref ) { 270 join "\02", map { # Array shall only contain objects. 271 if( exists $_->{xLOGGED} ) { # Already defined 272 int; # The cheapest external representation of a ref. 273 } elsif( !exists $_->{'..'} ) { # not a Mpp::File 274 # TODO: These two lines are a reminder for when we store RULE_SOURCE per ref. 275 #undef $_->{xLOGGED}; 276 #int() . "\03" . $_->name; 277 $_->name; 278 } elsif( exists $_->{'..'}{xLOGGED} ) { # Dir already defined 279 undef $_->{xLOGGED}; 280 int() . "\03$_->{NAME}\03" . int $_->{'..'}; 281 } else { 282 undef $_->{xLOGGED}; 283 undef $_->{'..'}{xLOGGED}; 284 int() . "\03$_->{NAME}\03" . 285 int( $_->{'..'} ) . "\03" . ($_->{'..'}{FULLNAME} || absolute_filename $_->{'..'}); 286 } 287 } @$_; 288# The rest is a verbatim copy of the map block above. This function is heavy 289# duty, and repeating code is 6% faster than calling it as a function, even 290# with &reuse_stack semantics. 291 } elsif( exists $_->{xLOGGED} ) { # Already defined 292 int; # The cheapest external representation of a ref. 293 } elsif( !exists $_->{'..'} ) { # not a Mpp::File 294 # TODO: These two lines are a reminder for when we store RULE_SOURCE per ref. 295 #undef $_->{xLOGGED}; 296 #int() . "\03" . $_->name; 297 $_->name; 298 } elsif( exists $_->{'..'}{xLOGGED} ) { # Dir already defined 299 undef $_->{xLOGGED}; 300 int() . "\03$_->{NAME}\03" . int $_->{'..'}; 301 } else { 302 undef $_->{xLOGGED}; 303 undef $_->{'..'}{xLOGGED}; 304 int() . "\03$_->{NAME}\03" . 305 int( $_->{'..'} ) . "\03" . ($_->{'..'}{FULLNAME} || absolute_filename $_->{'..'}); 306 } 307 } @_ ), 308 "\n"; 309 $last_indent_level = $indent_level; 310} 311 312=head2 flush_log 313 314Flush the log file and standard file handles. This is useful for making sure 315that output of a perl action is not lost before the action's process 316terminates with POSIX::_exit. 317 318=cut 319 320sub flush_log { 321 my $fh = select STDOUT; local $| = 1; 322 select STDERR; $| = 1; 323 if( defined $logfh ) { select $logfh; $| = 1 } 324 select $fh; 325} 326 327my $hires_time; 328sub print_profile { 329 print $profile ? "$progname: Begin \@" . &$hires_time() . " $_[0]\n" : "$_[0]\n"; 330} 331 332sub print_profile_end { 333 print "$progname: End \@" . &$hires_time() . " $_[0]\n"; 334} 335 336=head2 print_error 337 338 print_error "message", ...; 339 340Prints an error message, with the program name prefixed. For any arg which is 341a reference, $arg->name is printed. 342 343If any filename is printed, it should have be quoted as in `filename' or 344`filename:lineno:' at BOL, so that IDEs can parse it. 345 346=cut 347 348sub print_error { 349 my( $log, $stderr ) = $log_level && '*** '; 350 my $str = ''; 351 if( $_[0] =~ /^error()/ || $_[0] !~ /^\S+?:/ ) { # No name? 352 $stderr = "$progname: "; 353 $str = 'error: ' unless defined $1; 354 } 355 $str .= ref() ? $_->name : $_ 356 for @_; 357 $str .= "\n" if $str !~ /\n\z/; 358 print STDERR $stderr ? $stderr . $str : $str; 359 if( $log_level == 2 ) { 360 &Mpp::log() unless defined $logfh; # Only open the file. 361 print $logfh $log . $str; 362 } 363 &flush_log; 364} 365 366 367sub perform(@) { 368 #my @handles = @_; # Arguments passed to wait_for. 369 my $status; 370 my $start_pid = $$; 371 my $error_message = $@ || ''; 372 unless( $error_message ) { 373 eval { $status = &wait_for }; # Wait for args to be built. 374 # Wait for all the children to complete. 375 $error_message .= $@ if $@; # Record any new error messages. 376 } 377 { 378 my $orig = ''; 379 if($error_message) { 380 chomp($orig = $error_message); 381 $orig = " (Original error was $orig)"; 382 } 383 384 if( $$ != $start_pid ) { 385 print STDERR qq{makepp internal error: sub-process died or returned to outer scope. 386If we had not caught this, it would cause exit blocks to run multiple times. 387Use POSIX::_exit instead.$orig Stopped}; 388 close $_ for @close_fhs; 389 POSIX::_exit 3; 390 } 391 392 # Wait for our last jobs to finish. This can be the case when running 393 # with -kj<n>, a job failed and we ran out of queued jobs. 394 &Mpp::Event::event_loop 395 while $Mpp::Event::n_external_processes; 396 397 die qq{makepp internal error: dangling critical section. 398This means that there was a live process in the background when makepp 399died, so makepp did not have a chance to create build info files for 400targets generated by that process. It also means that makepp can't 401propagate signals. This could instead mean that you need an extra 'eval' 402somewhere to prevent an exception from bypassing process accounting and 403signal propagation.$orig Stopped} 404 if $critical_sections; 405 406 if( $error_found && $error_found =~ /^signal ($int_signo|$quit_signo)$/ ) { 407 my $sig = $1; 408 handle_signal signame($sig); 409 } 410 } 411 412 if( $quiet_flag ) { 413 # Suppress following chatter. 414 } elsif( $n_files_changed || $rep_hits || $build_cache_hits || $n_phony_targets_built || $failed_count ) { 415 print "$progname: $n_files_changed file" . ($n_files_changed == 1 ? '' : 's') . ' updated' . 416 ($rep_hits ? ", $rep_hits repository import" . ($rep_hits == 1 ? '' : 's') : '') . 417 ($build_cache_hits ? ", $build_cache_hits build cache import" . ($build_cache_hits == 1 ? '' : 's') : '') . 418 ($error_found ? ',' : ' and') . 419 " $n_phony_targets_built phony target" . ($n_phony_targets_built == 1 ? '' : 's') . ' built' . 420 ($failed_count ? " and $failed_count target" . ($failed_count == 1 ? '' : 's') . " failed\n" : "\n"); 421 } elsif( !$error_message ) { 422 print "$progname: no update necessary\n"; 423 } 424 425 print "$progname: Ending \@" . &$hires_time() . "\n" if $profile; 426 print_error $error_message if $error_message; 427 exit 1 if $error_message || $status || !MAKEPP && $failed_count; 428 # 2004_12_06_scancache has a use case for not failing despite $failed_count 429 exit 0; 430} 431 432our @common_opts = 433 ( 434 ['k', qr/keep[-_]?going/, \$keep_going], 435 436 [undef, qr/log(?:[-_]?file)?/, \$logfile, 1], 437 438 ['n', qr/(?:just[-_]?print|dry[-_]?run|recon)/, \$Mpp::dry_run], 439 [undef, qr/no[-_]?log/, \$log_level, undef, 0], # Turn off logging. 440 [undef, qr/no[-_]?print[-_]?directory/, \$print_directory, 0, undef], 441 [undef, qr/no[-_]?warn/, \$warn_level, undef, 0], 442 443 [undef, 'profile', \$profile, undef, sub { 444 if( !$hires_time ) { 445 eval { require Time::HiRes }; 446 $hires_time = $@ ? sub { time } : \&Time::HiRes::time; 447 print "$progname: Beginning \@" . &$hires_time() . "\n"; 448 } 449 }], 450 451 ['s', qr/quiet|silent/, \$quiet_flag], 452 453 [qw(v verbose), undef, undef, sub { 454 $verbose = 2; # Value 2 queried only by Mpp/Cmds. 455 $log_level = 1; # Send the log to stdout instead. Don't make 456 # this the option variable, as it must be 457 # exactly 1, not just true. 458 $warn_level = 0; # Warnings will be output via logging. 459 }], 460 461 splice @Mpp::Text::common_opts 462 ); 463 4641; 465