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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
package Devscripts::Uscan::Output;
use strict;
use Devscripts::Output;
use Exporter 'import';
use File::Basename;
our @EXPORT = (
@Devscripts::Output::EXPORT, qw(
uscan_msg uscan_verbose dehs_verbose uscan_warn uscan_debug
uscan_extra_debug uscan_die dehs_output $dehs $verbose $dehs_tags
$dehs_start_output $dehs_end_output $found
));
# ACCESSORS
our ($dehs, $dehs_tags, $dehs_start_output, $dehs_end_output, $found)
= (0, {}, 0, 0);
our $progname = basename($0);
sub printwarn {
my ($msg, $w) = @_;
chomp $msg;
if ($w or $dehs) {
print STDERR "$msg\n";
} else {
print "$msg\n";
}
}
*uscan_msg = \&ds_msg;
*uscan_verbose = \&ds_verbose;
*uscan_extra_debug = \&ds_extra_debug;
sub dehs_verbose ($) {
my $msg = $_[0];
push @{ $dehs_tags->{'messages'} }, "$msg\n";
uscan_verbose($msg);
}
sub uscan_warn ($) {
my $msg = $_[0];
push @{ $dehs_tags->{'warnings'} }, $msg if $dehs;
printwarn("$progname warn: $msg" . &Devscripts::Output::who_called, 1);
}
*uscan_debug = \&ds_debug;
sub uscan_die ($) {
my $msg = $_[0];
if ($dehs) {
$dehs_tags = { 'errors' => "$msg" };
$dehs_end_output = 1;
dehs_output();
}
$msg = "$progname die: $msg" . &Devscripts::Output::who_called;
if ($Devscripts::Output::die_on_error) {
die $msg;
}
printwarn($msg, 1);
}
sub dehs_output () {
return unless $dehs;
if (!$dehs_start_output) {
print "<dehs>\n";
$dehs_start_output = 1;
}
for my $tag (
qw(package debian-uversion debian-mangled-uversion
upstream-version upstream-url decoded-checksum
status target target-path messages warnings errors)
) {
if (exists $dehs_tags->{$tag}) {
if (ref $dehs_tags->{$tag} eq "ARRAY") {
foreach my $entry (@{ $dehs_tags->{$tag} }) {
$entry =~ s/</</g;
$entry =~ s/>/>/g;
$entry =~ s/&/&/g;
print "<$tag>$entry</$tag>\n";
}
} else {
$dehs_tags->{$tag} =~ s/</</g;
$dehs_tags->{$tag} =~ s/>/>/g;
$dehs_tags->{$tag} =~ s/&/&/g;
print "<$tag>$dehs_tags->{$tag}</$tag>\n";
}
}
}
foreach my $cmp (@{ $dehs_tags->{'component-name'} }) {
print qq'<component id="$cmp">\n';
foreach my $tag (
qw(debian-uversion debian-mangled-uversion
upstream-version upstream-url target target-path)
) {
my $v = shift @{ $dehs_tags->{"component-$tag"} };
print " <component-$tag>$v</component-$tag>\n" if $v;
}
print "</component>\n";
}
if ($dehs_end_output) {
print "</dehs>\n";
}
# Don't repeat output
$dehs_tags = {};
}
1;
|
