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