1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
# $NetBSD: Util.pm,v 1.3 2015/10/11 21:23:34 rillig Exp $
#
# This package is a catch-all for subroutines that are not application-spe-
# cific. Currently it contains the boolean constants C<false> and C<true>,
# as well as a function to print text in a table format, and a function
# that converts an array into a hash. The latter is just for convenience
# because I don't know of a Perl operator similar to qw() that can be used
# for creating a hash.
#
package PkgLint::Util;
use strict;
use warnings;
BEGIN {
use Exporter;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(
assert
false true dont_know doesnt_matter
array_to_hash normalize_pathname print_table
);
}
use enum qw(false true dont_know doesnt_matter);
sub assert($$) {
my ($cond, $msg) = @_;
my (@callers, $n);
if (!$cond) {
print STDERR ("FATAL: Assertion failed: ${msg}.\n");
for ($n = 0; my @info = caller($n); $n++) {
push(@callers, [$info[2], $info[3]]);
}
for (my $i = $#callers; $i >= 0; $i--) {
my $info = $callers[$i];
printf STDERR (" line %4d called %s\n", $info->[0], $info->[1]);
}
exit(1);
}
}
# Prints the C<$table> on the C<$out> stream. The C<$table> shall be an
# array of rows, each row shall be an array of cells, and each cell shall
# be a string.
sub print_table($$) {
my ($out, $table) = @_;
my (@width) = ();
foreach my $row (@{$table}) {
foreach my $i (0..$#{$row}) {
if (!defined($width[$i]) || length($row->[$i]) > $width[$i]) {
$width[$i] = length($row->[$i]);
}
}
}
foreach my $row (@{$table}) {
my ($max) = ($#{$row});
foreach my $i (0..$max) {
if ($i != 0) {
print $out (" ");
}
print $out ($row->[$i]);
if ($i != $max) {
print $out (" " x ($width[$i] - length($row->[$i])));
}
}
print $out ("\n");
}
}
sub array_to_hash(@) {
my ($result) = {};
foreach my $arg (@_) {
$result->{$arg} = 1;
}
return $result;
}
sub normalize_pathname($) {
my ($fname) = @_;
# strip "." path components
$fname =~ s,^(?:\./)+,,;
$fname =~ s,/(?:\./)+,/,g;
$fname =~ s,/+,/,g;
# strip intermediate "../.." path components
while ($fname =~ s,/[^.][^/]*/[^.][^/]*/\.\./\.\./,/,) {
}
return $fname;
}
|
