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