usr/src/cmd/abi/appcert/scripts/appcert.pl

   1 #!/usr/perl5/bin/perl -w
   2 #
   3 # CDDL HEADER START
   4 #
   5 # The contents of this file are subject to the terms of the
   6 # Common Development and Distribution License, Version 1.0 only
   7 # (the "License").  You may not use this file except in compliance
   8 # with the License.
   9 #
  10 # You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
  11 # or http://www.opensolaris.org/os/licensing.
  12 # See the License for the specific language governing permissions
  13 # and limitations under the License.
  14 #
  15 # When distributing Covered Code, include this CDDL HEADER in each
  16 # file and include the License file at usr/src/OPENSOLARIS.LICENSE.
  17 # If applicable, add the following below this CDDL HEADER, with the
  18 # fields enclosed by brackets "[]" replaced with your own identifying
  19 # information: Portions Copyright [yyyy] [name of copyright owner]
  20 #
  21 # CDDL HEADER END
  22 #
  23 #
  24 # ident "%Z%%M% %I%     %E% SMI"
  25 #
  26 # Copyright 2004 Sun Microsystems, Inc.  All rights reserved.
  27 # Use is subject to license terms.
  28 #
  29
  30 #
  31 # This is the top level script for performing the appcert checks.  It
  32 # reads the command line options, determines list of binaries to check,
  33 # and then calls symprof (the raw symbol profiler), symcheck (that
  34 # checks for unstable behavior), and symreport (that constructs and
  35 # outputs a rollup report)
  36 #
  37
  38 require 5.005;
  39 use strict;
  40 use locale;
  41 use Getopt::Std;
  42 use POSIX qw(locale_h);
  43 use Sun::Solaris::Utils qw(textdomain gettext);
  44 use File::Basename;
  45 use File::Path;
  46
  47 use lib qw(/usr/lib/abi/appcert);
  48 use AppcertUtil;
  49
  50 setlocale(LC_ALL, "");
  51 textdomain(TEXT_DOMAIN);
  52
  53 use vars qw(
  54         @item_list
  55         $file_list
  56         $do_not_follow_symlinks
  57         $modify_ld_path
  58         $append_solaris_dirs_to_ld_path
  59         $skipped_count
  60 );
  61
  62 my $caught_signal = 0;
  63 my $record_binary_call_count = 0;
  64
  65 # The directory where the appcert specific scripts and data reside:
  66 $appcert_lib_dir = "/usr/lib/abi/appcert";
  67
  68 set_clean_up_exit_routine(\&clean_up_exit);
  69
  70 signals('on', \&interrupted);
  71
  72 get_options();
  73
  74 @item_list = @ARGV;             # List of directories and/or objects to check.
  75 check_item_list();
  76
  77 set_working_dir();
  78
  79 find_binaries();                # Records all of the binary objects to check.
  80
  81 supplement_ld_library_path();
  82
  83 export_vars_to_environment();   # Exports info for our child scripts to use.
  84
  85 run_profiler();                 # Run the script symprof.
  86
  87 run_checker();                  # Run script symcheck.
  88
  89 run_report_generator();         # Run the script symreport.
  90
  91 my $rc = overall_result_code();
  92
  93 clean_up();
  94
  95 exit $rc;
  96
  97
  98 #
  99 # This subroutine calls getopts() and sets up variables reflecting how
 100 # we were called.
 101 #
 102 sub get_options
 103 {
 104         my %opt;
 105
 106         getopts('?hnLBSw:f:', \%opt) || (show_usage() && exiter(2));
 107
 108         if (exists($opt{'?'}) || exists($opt{'h'})) {
 109                 show_usage();
 110                 exiter(2);
 111         }
 112
 113         if (exists($opt{'f'})) {
 114                 $file_list = $opt{'f'};
 115         } else {
 116                 $file_list = '';
 117         }
 118
 119         if (exists($opt{'w'})) {
 120                 $working_dir = $opt{'w'};
 121         } else {
 122                 $working_dir = '';
 123         }
 124         if ($working_dir =~ /'/) {
 125                 #
 126                 # This character will ultimately cause problems with
 127                 # system() and pipelines so we exit now.
 128                 #
 129                 exiter(sprintf(gettext(
 130                     "directory contains the single-quote character ': %s\n"),
 131                     $working_dir));
 132         }
 133
 134         if (defined($opt{'B'})) {
 135                 $batch_report = 1;
 136         } else {
 137                 $batch_report = 0;
 138         }
 139
 140         if (defined($opt{'n'})) {
 141                 $do_not_follow_symlinks = 1;
 142         } else {
 143                 $do_not_follow_symlinks = 0;
 144         }
 145
 146         if (defined($opt{'L'})) {
 147                 $modify_ld_path = 0;
 148         } else {
 149                 $modify_ld_path = 1;
 150         }
 151
 152         if (defined($opt{'S'})) {
 153                 $append_solaris_dirs_to_ld_path = 1;
 154         } else {
 155                 $append_solaris_dirs_to_ld_path = 0;
 156         }
 157 }
 158
 159 #
 160 # Performs an initial check to see if the user supplied anything at all
 161 # to check.  Also reads in the file list if the user supplied one via -f <file>
 162 #
 163 sub check_item_list
 164 {
 165         # Add the items if the -f flag was used.
 166         if ($file_list) {
 167                 my $file;
 168                 my $list_fh = do { local *FH; *FH };
 169                 if (-f $file_list && open($list_fh, "<$file_list")) {
 170                         while (<$list_fh>) {
 171                                 chomp($file = $_);
 172                                 push(@item_list, $file);
 173                         }
 174                         close($list_fh);
 175                 } else {
 176                         exiter(nofile($file_list, $!));
 177                 }
 178         }
 179
 180         return if (@item_list);
 181
 182         emsg("$command_name: " . gettext(
 183             "at least one file or directory to check must be specified.") .
 184             "\n\n");
 185
 186         show_usage();
 187         exiter(3);
 188 }
 189
 190 #
 191 # This subroutine sets up the working directory, the default something
 192 # like: /tmp/appcert.<PID>
 193 #
 194 sub set_working_dir
 195 {
 196         if ($working_dir) {
 197                 # working_dir has been set in get_options().
 198                 if (! -d $working_dir) {
 199                         if (! mkpath($working_dir) || ! -d $working_dir) {
 200                                 exiter(nocreatedir($working_dir, $!));
 201                         }
 202                 } else {
 203                         if (! dir_is_empty($working_dir)) {
 204                                 # create a subdir of it for our use.
 205                                 $working_dir = create_tmp_dir($working_dir);
 206                         }
 207                 }
 208         } else {
 209                 # Default case: will create, e.g., /tmp/appcert.12345
 210                 $working_dir = create_tmp_dir();
 211         }
 212
 213         if (! -d $working_dir) {
 214                 # We have no working directory.
 215                 exiter(nocreatedir($working_dir));
 216         }
 217
 218         #
 219         # Create a subdirectory of working_dir that will contain all of
 220         # the object subdirs.
 221         #
 222         my $dir = "$working_dir/$object_dir";
 223         if (! mkpath($dir) || ! -d $dir) {
 224                 exiter(nocreatedir($dir, $!));
 225         }
 226         #
 227         # Make a tmp subdirectory for small temporary work. It is
 228         # preferred to have it on tmpfs (especially not NFS) for
 229         # performance reasons.
 230         #
 231         $tmp_dir = "/tmp/${command_name}_tmp.$$";
 232         if (-d $tmp_dir) {
 233                 exiter(nocreatedir("$tmp_dir", $!));
 234         }
 235         if (! mkpath($tmp_dir, 0, 0700) || ! -d $tmp_dir) {
 236                 emsg("%s", nocreatedir($tmp_dir, $!));
 237                 # fall back to our output dir (which could have slow access)
 238                 $tmp_dir = "$working_dir/tmp";
 239                 if (! mkpath($tmp_dir)) {
 240                         exiter(nocreatedir($tmp_dir, $!));
 241                 }
 242         }
 243
 244         if (! -d $tmp_dir) {
 245                 exiter(nocreatedir($tmp_dir, $!));
 246         }
 247 }
 248
 249 #
 250 # Top level function to find all the binaries to be checked.  Calls
 251 # record_binary() to do the actual deciding and recording.
 252 #
 253 # The array @item_list contains all the items to find.
 254 #
 255 sub find_binaries
 256 {
 257         $binary_count = 0;
 258
 259         my $skipped_file = "$working_dir/Skipped";
 260         my $skipped_fh = do { local *FH; *FH };
 261         open($skipped_fh, ">$skipped_file") ||
 262             exiter(nofile($skipped_file, $!));
 263
 264         $skipped_count = 0;
 265
 266         my ($item, $args, $file);
 267         emsg("\n" .  gettext(
 268             "finding executables and shared libraries to check") . " ...\n");
 269
 270         $args = '';
 271         $args .= '-follow ' unless ($do_not_follow_symlinks);
 272         $args .= '-type f -print';
 273
 274         my $quote_fmt = gettext(
 275             "skipping:  item contains the single-quote character ': %s\n");
 276
 277         foreach $item (@item_list) {
 278                 if (! -e $item) {
 279                         emsg(gettext("skipping:  %s: %s\n"), $item, $!);
 280                         print $skipped_fh "$item: no_exist\n";
 281                         $skipped_count++;
 282                         next;
 283                 } elsif ($item =~ /'/)  {
 284                         emsg($quote_fmt, $item);
 285                         print $skipped_fh "$item: item_has_bad_char\n";
 286                         $skipped_count++;
 287                         next;
 288                 }
 289                 # note that $item does not contain a single-quote.
 290                 my $find_fh = do { local *FH; *FH };
 291                 open($find_fh, "$cmd_find '$item' $args|") ||
 292                     exiter(norunprog("$cmd_find '$item' $args", $!));
 293
 294                 while (<$find_fh>) {
 295                         chomp($file = $_);
 296                         #
 297                         # We are free to remove leading "./". This will
 298                         # minimize directory names we create that would
 299                         # start with a dot.
 300                         #
 301                         $file =~ s,^\./,,;
 302
 303                         next if ($file eq '');
 304
 305                         record_binary($file, $skipped_fh);
 306                 }
 307                 close($find_fh);
 308         }
 309
 310         if ($binary_count == 0) {
 311                 exiter("$command_name: " . gettext(
 312                     "no checkable binary objects were found."), 3);
 313         }
 314
 315         if ($skipped_count == 0) {
 316                 print $skipped_fh "# NO_FILES_WERE_SKIPPED\n";
 317         }
 318         close($skipped_fh);
 319 }
 320
 321 #
 322 # This subroutine will determine if a binary is checkable.
 323 #
 324 # If so, it will reserve a directory for its output in the $working_dir
 325 # location, and store the output of a number of commands there.
 326 #
 327 sub record_binary
 328 {
 329         my ($file, $skipped_fh) = @_;
 330
 331         if ((++$record_binary_call_count % 500) == 0) {
 332                 #
 333                 # This indicates are being called many times for a large
 334                 # product.  Clear out our caches.
 335                 #
 336                 purge_caches();
 337         }
 338
 339         #
 340         # Check if the object exists and is regular file.  Note that
 341         # this test also passes a symlink as long as that symlink
 342         # ultimately refers to a regular file.
 343         #
 344         if (! -f $file) {
 345                 emsg(gettext("skipping:  not a file: %s\n"), $file);
 346                 print $skipped_fh "$file: not_a_file\n";
 347                 $skipped_count++;
 348                 return 0;
 349         }
 350
 351         # Check if it is readable:
 352         if (! -r $file) {
 353                 emsg(gettext("skipping:  cannot read: %s\n"), $file);
 354                 print $skipped_fh "$file: unreadable\n";
 355                 $skipped_count++;
 356                 return 0;
 357         }
 358
 359         #
 360         # Since the filename will be used as operands passed to utility
 361         # commands via the shell, we exclude at the outset certain meta
 362         # characters in the filenames.
 363         #
 364         my $quote_fmt = gettext(
 365             "skipping:  filename contains the single-quote character: ': %s\n");
 366         if ($file =~ /'/) {
 367                 emsg($quote_fmt, $file);
 368                 print $skipped_fh "$file: filename_has_bad_char\n";
 369                 $skipped_count++;
 370                 return 0;
 371         }
 372
 373         my $newline_fmt = gettext(
 374             "skipping:  filename contains the newline character: \\n: %s\n");
 375         if ($file =~ /\n/) {
 376                 emsg($newline_fmt, $file);
 377                 print $skipped_fh "$file: filename_has_bad_char\n";
 378                 $skipped_count++;
 379                 return 0;
 380         }
 381
 382         my $pipe_fmt = gettext(
 383             "skipping:  filename contains the pipe character: \|: %s\n");
 384         if ($file =~ /\|/) {
 385                 emsg($pipe_fmt, $file);
 386                 print $skipped_fh "$file: filename_has_bad_char\n";
 387                 $skipped_count++;
 388                 return 0;
 389         }
 390
 391         my $file_output;
 392
 393         # Run the file(1) command on it.
 394
 395         c_locale(1);
 396         # note that $file does not contain a single-quote.
 397         $file_output = `$cmd_file '$file' 2>/dev/null`;
 398         c_locale(0);
 399
 400         if ($file_output =~ /script$/) {
 401                 $file_output =~ s/:\s+/: /;
 402                 $file_output =~ s/: /: script /;
 403                 print $skipped_fh "$file_output";
 404
 405                 #
 406                 # again now without the c_locale() setting:
 407                 # note that $file does not contain a single-quote.
 408                 #
 409                 $file_output = `$cmd_file '$file' 2>/dev/null`;
 410                 $file_output =~ s/:\s+/: /;
 411                 emsg(gettext("skipping:  %s"), $file_output);
 412                 $skipped_count++;
 413                 return 0;
 414         }
 415
 416         # create ELF and a.out matching regex:
 417         my $object_match =
 418             'ELF.*executable.*dynamically' . '|' .
 419             'ELF.*dynamic lib' . '|' .
 420             'ELF.*executable.*statically' . '|' .
 421             'Sun demand paged SPARC.*dynamically linked' . '|' .
 422             'Sun demand paged SPARC executable' . '|' .
 423             'pure SPARC executable' . '|' .
 424             'impure SPARC executable';
 425
 426         #
 427         # Note that we let the "statically linked" binaries through
 428         # here, but will catch them later in the profiler and checker.
 429         #
 430
 431         if ($file_output !~ /$object_match/io) {
 432                 # it is not an ELF object file and so does not interest us.
 433                 return 0;
 434         }
 435
 436         my $exec_fmt = gettext(
 437             "skipping:  must have exec permission to be checked: %s\n");
 438         if (! -x $file) {
 439                 #
 440                 # It interests us, but the execute bit not set.  Shared
 441                 # objects will be let through here since ldd will still
 442                 # work on them (since it uses lddstub).  Otherwise, we
 443                 # cannot check it.
 444                 #
 445                 if (! is_shared_object($file)) {
 446                         # warn the user exec bit should be set:
 447                         emsg($exec_fmt, $file);
 448                         print $skipped_fh "$file: no_exec_permission\n";
 449                         $skipped_count++;
 450                         return 0;
 451                 }
 452         }
 453
 454         #
 455         # Rather than let ldd fail later on in symprof, we check the
 456         # arch here to make sure it matches $uname_p.  If it does not
 457         # match, we anticipate a 64-bit application and so we
 458         # immediately test how ldd will handle it (kernel might be
 459         # 32-bit, etc).
 460         #
 461         my ($arch, $type, $wordsize, $endian, $e_machine) = bin_type($file);
 462
 463         if ($arch !~ /^${uname_p}$/io) {
 464                 my ($ldd_output, $ldd_output2);
 465
 466                 #
 467                 # Now run ldd on it to see how things would go.  If it
 468                 # fails we must skip it.
 469                 #
 470                 c_locale(1);
 471                 # note that $file does not contain single-quote
 472                 $ldd_output = `$cmd_ldd '$file' 2>&1 1>/dev/null`;
 473                 c_locale(0);
 474                 if ($? != 0) {
 475                         # note that $file does not contain a single-quote
 476                         $ldd_output2 = `$cmd_ldd '$file' 2>&1 1>/dev/null`;
 477                         $ldd_output     =~ s/\n.*$//;
 478                         $ldd_output2    =~ s/\n.*$//;
 479                         if ($ldd_output !~ /wrong class/) {
 480                                 $ldd_output = "$file: " . sprintf(
 481                                     gettext("ldd failed for arch: %s"), $arch);
 482                                 $ldd_output2 = $ldd_output;
 483                         } else {
 484                                 $ldd_output     .= " ($arch)";
 485                                 $ldd_output2    .= " ($arch)";
 486                         }
 487                         $ldd_output     =~ s/:\s+/: /;
 488                         $ldd_output2    =~ s/:\s+/: /;
 489                         emsg(gettext("skipping:  %s\n"), $ldd_output2);
 490                         $ldd_output =~ s/: /: ldd_failed /;
 491                         print $skipped_fh "$ldd_output\n";
 492                         $skipped_count++;
 493                         return 0;
 494                 }
 495         }
 496
 497         # From this point on, object is one we decided to check.
 498
 499         # Create the directory name for this object:
 500         my $dirname = object_to_dir_name($file);
 501         my $dirpath = "$working_dir/$dirname";
 502         my $early_fmt = gettext(
 503             "skipping:  %s referenced earlier on the command line\n");
 504         if (-e $dirpath) {
 505                 #
 506                 # Directory already exists.  We assume this means the
 507                 # user listed it twice (possibly indirectly via "find").
 508                 #
 509                 emsg($early_fmt, $file);
 510                 return 0;
 511         }
 512
 513         if (! mkdir($dirpath, 0777)) {
 514                 exiter(nocreatedir($dirpath, $!));
 515         }
 516
 517         $binary_count++;
 518
 519         # Record binary object's location:
 520         my $path_fh = do { local *FH; *FH };
 521         open($path_fh, ">$dirpath/info.path") ||
 522             exiter(nofile("$dirpath/info.path", $!));
 523         print $path_fh $file, "\n";
 524         close($path_fh);
 525
 526         #
 527         # Record /usr/bin/file output.  Note that the programmatical way
 528         # to access this info is through the command cmd_output_file().
 529         #
 530         my $file_fh = do { local *FH; *FH };
 531         open($file_fh, ">$dirpath/info.file") ||
 532             exiter(nofile("$dirpath/info.file", $!));
 533         print $file_fh $file_output;
 534         close($file_fh);
 535
 536         #
 537         # Record dump -Lv output.  Note that the programmatical way to
 538         # access this info is through the command cmd_output_dump().
 539         #
 540         my $dump_fh = do { local *FH; *FH };
 541         open($dump_fh, ">$dirpath/info.dump") ||
 542             exiter(nofile("$dirpath/info.dump", $!));
 543
 544         my $dump_output;
 545         c_locale(1);
 546         # note that $file does not contain a single-quote
 547         $dump_output = `$cmd_dump -Lv '$file' 2>&1`;
 548         c_locale(0);
 549         print $dump_fh $dump_output;
 550         close($dump_fh);
 551
 552         #
 553         # Record arch and etc binary type.
 554         #
 555         my $arch_fh = do { local *FH; *FH };
 556         open($arch_fh, ">$dirpath/info.arch") ||
 557             exiter(nofile("$dirpath/info.arch", $!));
 558
 559         if ($arch eq 'unknown') {
 560                 my $tmp = $file_output;
 561                 chomp($tmp);
 562                 emsg(gettext("warning:   cannot determine arch: %s\n"), $tmp);
 563         }
 564
 565         print $arch_fh "ARCH: $arch\n";
 566         print $arch_fh "TYPE: $type\n";
 567         print $arch_fh "WORDSIZE: $wordsize\n";
 568         print $arch_fh "BYTEORDER: $endian\n";
 569         print $arch_fh "E_MACHINE: $e_machine\n";
 570         close($arch_fh);
 571
 572         # Record the file -> directory name mapping in the index file.
 573         my $index_file   = "$working_dir/Index";
 574         my $index_fh = do { local *FH; *FH };
 575         open($index_fh, ">>$index_file") ||
 576             exiter(nofile($index_file, $!));
 577         print $index_fh "$file => $dirname\n";
 578         close($index_fh);
 579
 580         return 1;
 581 }
 582
 583 #
 584 # Prints the usage statement to standard out.
 585 #
 586 sub show_usage
 587 {
 588         emsg(gettext(
 589         "usage: appcert [ -nBLS ] [ -f file ] [ -w dir ] { obj | dir } ...\n" .
 590         "       Examine binary object files for use of private Solaris\n" .
 591         "       interfaces, unstable use of static linking, and other\n" .
 592         "       unstable practices.\n")
 593         );
 594 }
 595
 596 #
 597 # Examines the set of binaries to be checked and notes which ones are
 598 # shared libraries. Constructs a LD_LIBRARY_PATH that would find ALL of
 599 # these shared objects. The new directories are placed at the END of the
 600 # current LD_LIBRARY_PATH (if any).
 601 #
 602 sub supplement_ld_library_path
 603 {
 604         my (@orig, @add_product, @add_solaris, %ldpath);
 605
 606         # First, note the current LD_LIBRARY_PATH parts:
 607
 608         my $dirname;
 609         if (defined($ENV{'LD_LIBRARY_PATH'})) {
 610                 foreach $dirname (split(/:/, $ENV{'LD_LIBRARY_PATH'})) {
 611                         if (! exists($ldpath{$dirname})) {
 612                                 push(@orig, $dirname);
 613                                 $ldpath{$dirname} = 1;
 614                         }
 615                 }
 616         }
 617
 618         # Next, search for ELF shared objects.
 619         my ($dir, $path);
 620
 621         if ($modify_ld_path) {
 622                 while (defined($dir = next_dir_name())) {
 623                         $path = dir_name_to_path($dir);
 624
 625                         $dirname = dirname($path);
 626                         next if (exists($ldpath{$dirname}));
 627
 628                         #
 629                         # A colon ":" in directory name is cannot be
 630                         # accepted because that is the LD_LIBRARY_PATH
 631                         # separator.
 632                         #
 633                         next if ($dirname =~ /:/);
 634
 635                         if (is_shared_object($path)) {
 636                                 if (! exists($ldpath{$dirname})) {
 637                                         push(@add_product, $dirname);
 638                                         $ldpath{$dirname} = 1;
 639                                 }
 640                         }
 641                 }
 642         }
 643
 644         if ($append_solaris_dirs_to_ld_path) {
 645                 foreach $dirname (split(/:/, $solaris_library_ld_path)) {
 646                         if (! exists($ldpath{$dirname})) {
 647                                 push(@add_solaris, $dirname);
 648                                 $ldpath{$dirname} = 1;
 649                         }
 650                 }
 651         }
 652
 653         # modify the LD_LIBRARY_PATH:
 654         if (@add_product || @add_solaris) {
 655                 $ENV{'LD_LIBRARY_PATH'} =
 656                     join(':', (@orig, @add_product, @add_solaris));
 657         }
 658
 659         emsg("\n");
 660         if (@add_product) {
 661                 emsg(gettext(
 662                     "Shared libraries were found in the application and the\n" .
 663                     "following directories are appended to LD_LIBRARY_PATH:\n"
 664                     ) . "\n");
 665
 666                 foreach $dir (@add_product) {
 667                         $dir = "./$dir" unless ($dir =~ m,^/,);
 668                         emsg("   $dir\n");
 669                 }
 670                 emsg("\n");
 671         }
 672
 673         if (@add_solaris) {
 674                 emsg(gettext(
 675                     "These Solaris library directories are being appended\n" .
 676                     "to LD_LIBRARY_PATH:\n") . "\n");
 677
 678                 foreach $dir (@add_solaris) {
 679                         emsg("   $dir\n");
 680                 }
 681                 emsg("\n");
 682         }
 683 }
 684
 685 #
 686 # Everything is correctly exported by now, and so we just run "symprof".
 687 # It is run in batches of $block_size binaries to minimize the effect of
 688 # memory usage caused by huge binaries in the product to be checked.
 689 #
 690 sub run_profiler
 691 {
 692         my $block_size = 20;
 693
 694         my $i = 0;
 695
 696         # record old values of the blocks (if any)
 697         my $env_min = $ENV{'AC_BLOCK_MIN'};
 698         my $env_max = $ENV{'AC_BLOCK_MAX'};
 699
 700         while ($i < $binary_count) { # do each block
 701                 # export our symprof values of the block limits
 702                 $ENV{'AC_BLOCK_MIN'} = $i;
 703                 $ENV{'AC_BLOCK_MAX'} = $i + $block_size;
 704
 705                 run_symprof();
 706
 707                 $i += $block_size;
 708         }
 709
 710         # restore old values of the blocks (if any)
 711         if (defined($env_min)) {
 712                 $ENV{'AC_BLOCK_MIN'} = $env_min;
 713         } else {
 714                 delete $ENV{'AC_BLOCK_MIN'};
 715         }
 716         if (defined($env_max)) {
 717                 $ENV{'AC_BLOCK_MAX'} = $env_max;
 718         } else {
 719                 delete $ENV{'AC_BLOCK_MAX'};
 720         }
 721 }
 722
 723 #
 724 # Sub that actually runs "symprof".
 725 #
 726 sub run_symprof
 727 {
 728         system("$appcert_lib_dir/symprof");
 729         if ($? != 0) {
 730                 emsg("%s", utilityfailed("symprof"));
 731                 clean_up_exit(1);
 732         }
 733 }
 734
 735 #
 736 # Sub to run "symcheck".
 737 #
 738 sub run_checker
 739 {
 740         system("$appcert_lib_dir/symcheck");
 741         if ($? != 0) {
 742                 emsg("%s", utilityfailed("symcheck"));
 743                 clean_up_exit(1);
 744         }
 745 }
 746
 747 #
 748 # Sub to run "symreport".
 749 #
 750 sub run_report_generator
 751 {
 752         system("$appcert_lib_dir/symreport");
 753         if ($? != 0) {
 754                 emsg("%s", utilityfailed("symreport"));
 755                 clean_up_exit(1);
 756         }
 757 }
 758
 759 #
 760 # General routine to be called if one of our utility programs (symprof,
 761 # symcheck, symreport) failed (that is, return != 0).  returns the
 762 # formatted error message string to pass to the user.
 763 #
 764 sub utilityfailed
 765 {
 766         my ($prog) = @_;
 767         my $fmt;
 768         $fmt = "\n *** " . gettext("utility program failed: %s\n");
 769         return sprintf($fmt, $prog);
 770 }
 771
 772 #
 773 # Does the cleanup and then exits with return code $rc.  The utility
 774 # subroutine exiter() will call this subroutine.  No general cleanup is
 775 # performed if exiting with error ($rc > 0) so that the user can examine
 776 # at the output files, etc.
 777 #
 778 sub clean_up_exit
 779 {
 780         my ($rc) = @_;
 781
 782         if ($rc != 0) {
 783                 working_dir_msg();
 784         } else {
 785                 clean_up();
 786         }
 787
 788         exit $rc;
 789 }
 790
 791 #
 792 # General cleanup routine.
 793 #
 794 sub clean_up
 795 {
 796         if (-d $tmp_dir && ($tmp_dir !~ m,^/+$,)) {
 797                 rmdir($tmp_dir);
 798         }
 799 }
 800
 801 #
 802 # Routine that is called when an error has occurred.  It indicates to
 803 # user where the working and/or temporary directory is and that they are
 804 # not being removed.
 805 #
 806 sub working_dir_msg
 807 {
 808
 809         my @dirlist;
 810         emsg("\n");
 811         if (defined($working_dir) && -d $working_dir) {
 812                 push(@dirlist, $working_dir);
 813         }
 814         if (defined($tmp_dir) && -d $tmp_dir) {
 815                 push(@dirlist, $tmp_dir);
 816         }
 817
 818         return if (! @dirlist);
 819
 820         emsg(gettext(
 821             "Note that the temporary working directories still exist:") .
 822             "\n\n");
 823
 824         my $dir;
 825         # show the user explicitly which directories remains:
 826         foreach $dir (@dirlist) {
 827                 system($cmd_ls, '-ld', $dir);
 828         }
 829
 830         emsg("\n");
 831 }
 832
 833 #
 834 # Signal handler for interruptions (E.g. Ctrl-C SIGINT).
 835 #
 836 sub interrupted
 837 {
 838         $SIG{$_[0]} = 'IGNORE';
 839
 840         exit 1 if ($caught_signal);
 841         $caught_signal = 1;
 842
 843         signals('off');
 844         emsg("\n** " . gettext("interrupted") . " **\n");
 845
 846         clean_up_exit(1);
 847 }