lib/Devscripts/Uscan/Output.pm


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

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_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;

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
        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/</&lt;/g;
                    $entry =~ s/>/&gt;/g;
                    $entry =~ s/&/&amp;/g;
                    print "<$tag>$entry</$tag>\n";
                }
            } else {
                $dehs_tags->{$tag} =~ s/</&lt;/g;
                $dehs_tags->{$tag} =~ s/>/&gt;/g;
                $dehs_tags->{$tag} =~ s/&/&amp;/g;
                print "<$tag>$dehs_tags->{$tag}</$tag>\n";
            }
        }
    }
    if ($dehs_end_output) {
        print "</dehs>\n";
    }

    # Don't repeat output
    $dehs_tags = {};
}
1;