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 38require 5.005; 39use strict; 40use locale; 41use Getopt::Std; 42use POSIX qw(locale_h); 43use Sun::Solaris::Utils qw(textdomain gettext); 44use File::Basename; 45use File::Path; 46 47use lib qw(/usr/lib/abi/appcert); 48use AppcertUtil; 49 50setlocale(LC_ALL, ""); 51textdomain(TEXT_DOMAIN); 52 53use 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 62my $caught_signal = 0; 63my $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 68set_clean_up_exit_routine(\&clean_up_exit); 69 70signals('on', \&interrupted); 71 72get_options(); 73 74@item_list = @ARGV; # List of directories and/or objects to check. 75check_item_list(); 76 77set_working_dir(); 78 79find_binaries(); # Records all of the binary objects to check. 80 81supplement_ld_library_path(); 82 83export_vars_to_environment(); # Exports info for our child scripts to use. 84 85run_profiler(); # Run the script symprof. 86 87run_checker(); # Run script symcheck. 88 89run_report_generator(); # Run the script symreport. 90 91my $rc = overall_result_code(); 92 93clean_up(); 94 95exit $rc; 96 97 98# 99# This subroutine calls getopts() and sets up variables reflecting how 100# we were called. 101# 102sub 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# 163sub 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# 194sub 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# 255sub 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# 327sub 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# 586sub 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# 602sub 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# 690sub 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# 726sub 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# 738sub 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# 750sub 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# 764sub 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# 778sub 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# 794sub 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# 806sub 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# 836sub 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} 848