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
113
114
115
116
|
package Ddtc::Common;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(
__
set_debug
get_debug
inc_debug
dec_debug
debug
warning
suicide
);
my $debug; # debug level
BEGIN {
eval 'use Locale::gettext';
if ($@) {
*gettext = sub { shift };
*textdomain = sub { "" };
*LC_MESSAGES = sub { 5 };
}
eval {
require POSIX;
import POSIX qw(setlocale);
};
if ($@) {
*setlocale = sub { 1 };
}
}
no strict;
setlocale(LC_MESSAGES, "");
use strict;
textdomain("ddtc");
sub __($) {
gettext(shift);
}
# set debug level
sub inc_debug() { $debug++ if $debug < 9 }; # increase debug level
sub dec_debug() { $debug-- if $debug > 0 }; # decrease debug level
sub set_debug($) {
$debug = $_[0] > 9 ? 9 :
$_[0] < 0 ? 0 :
shift; # set debug level
};
# get debug level
sub get_debug() { return $debug }; # get debug level
# write debug messages
sub debug ($;$@) {
return unless $debug >= shift; # debug level
my $text = shift || "";
$text = sprintf ($text, @_) if @_;
my @text = split("\n", $text);
@text = ("") unless @text;
my $line = (caller(0))[2]; # get calling line
my $sub = (caller(1))[3] || ''; # get calling sub name
foreach (@text) {
print "debug ($sub\:$line) " unless $debug < 3;
print "$_\n";
}
}
# write error message and die
sub suicide ($;@) {
my $text = shift || "";
$text = sprintf ($text, @_) if @_;
my @text = split("\n", $text);
@text = ("") unless @text;
my $line = (caller(0))[2]; # get calling line
my $sub = (caller(1))[3] || ''; # get calling sub name
foreach (@text) {
$debug < 3 ? print __("ERROR ") :
print "suicide ($sub\:$line) ";
print "$_\n";
}
exit -1;
}
# write warning message
sub warning ($;@) {
my $text = shift || "";
$text = sprintf ($text, @_) if @_;
my @text = split("\n", $text);
@text = ("") unless @text;
my $line = (caller(0))[2]; # get calling line
my $sub = (caller(1))[3] || ''; # get calling sub name
foreach (@text) {
$debug < 3 ? print __("WARNING ") :
print "warning ($sub\:$line) ";
print "$_\n";
}
}
1;
|
