Bug 5236 Followup: items table information being keyed by biblionumber instead!
[wip/koha-chris_n.git] / misc / translator / VerboseWarnings.pm
1 package VerboseWarnings;
2
3 use strict;
4 #use warnings; FIXME - Bug 2505
5 require Exporter;
6
7 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
8
9 ###############################################################################
10
11 =head1 NAME
12
13 VerboseWarnings.pm - Verbose warnings for Perl scripts
14
15 =head1 DESCRIPTION
16
17 Contains convenience functions to construct Unix-style informational,
18 verbose warnings.
19
20 =cut
21
22 ###############################################################################
23
24 $VERSION = 0.01;
25
26 @ISA = qw(Exporter);
27 @EXPORT_OK = qw(
28     &pedantic_p
29     &warn_additional
30     &warn_normal
31     &warn_pedantic
32     &error_additional
33     &error_normal
34 );
35 %EXPORT_TAGS = (
36     'warn' => [ 'warn_additional',  'warn_normal',  'warn_pedantic' ],
37     'die'  => [ 'error_additional', 'error_normal' ],
38 );
39
40 ###############################################################################
41
42 use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag $quiet);
43 use vars qw( $warned $erred );
44
45 sub set_application_name ($) {
46     my($s) = @_;
47     $appName = $& if !defined $appName && $s =~ /[^\/]+$/;
48 }
49
50 sub application_name () {
51     return $appName;
52 }
53
54 sub set_input_file_name ($) {
55     my($s) = @_;
56     $input = $s;
57     $input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
58 }
59
60 sub set_pedantic_mode ($) {
61     my($p) = @_;
62     $pedantic_p = $p;
63     $pedantic_tag = $pedantic_p? '': ' (negligible)';
64 }
65
66 sub pedantic_p () {
67     return $pedantic_p;
68 }
69
70 sub construct_warn_prefix ($$) {
71     my($prefix, $lc) = @_;
72     die "construct_warn_prefix called before set_application_name"
73             unless defined $appName;
74     die "construct_warn_prefix called before set_input_file_name"
75             unless defined $input || !defined $lc; # be a bit lenient
76     die "construct_warn_prefix called before set_pedantic_mode"
77             unless defined $pedantic_tag;
78
79     # FIXME: The line number is not accurate, but should be "close enough"
80     # FIXME: This wording is worse than what was there, but it's wrong to
81     # FIXME: hard-code this thing in each warn statement. Need improvement.
82     return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
83 }
84
85 sub warn_additional ($$) {
86     my($msg, $lc) = @_;
87     my $prefix = construct_warn_prefix('Warning', $lc);
88     $msg .= "\n" unless $msg =~ /\n$/s;
89     warn "$prefix$msg";
90 }
91
92 sub warn_normal ($$) {
93     my($msg, $lc) = @_;
94     $warned += 1;
95     warn_additional($msg, $lc);
96 }
97
98 sub warn_pedantic ($$$) {
99     my($msg, $lc, $flag) = @_;
100     my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
101     $msg .= "\n" unless $msg =~ /\n$/s;
102     warn "$prefix$msg" if ($pedantic_p || !$$flag) && $quiet;
103     if (!$pedantic_p) {
104         $prefix = construct_warn_prefix("Warning$pedantic_tag", undef);
105         warn $prefix."Further similar negligible warnings will not be reported, use --pedantic for details\n" unless ($$flag || !$quiet);
106         $$flag = 1;
107     }
108     $warned += 1;
109 }
110
111 sub error_additional ($$) {
112     my($msg, $lc) = @_;
113     my $prefix = construct_warn_prefix('ERROR', $lc);
114     $msg .= "\n" unless $msg =~ /\n$/s;
115     warn "$prefix$msg";
116 }
117
118 sub error_normal ($$) {
119     my($msg, $lc) = @_;
120     $erred += 1;
121     error_additional($msg, $lc);
122 }
123
124 sub warned () {
125     return $warned; # number of times warned
126 }
127
128 ###############################################################################