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
|
package Devscripts::Output;
use strict;
use Exporter 'import';
use File::Basename;
use constant accept => qr/^y(?:es)?\s*$/i;
use constant refuse => qr/^n(?:o)?\s*$/i;
our @EXPORT = (
qw(ds_debug ds_extra_debug ds_verbose ds_warn ds_error
ds_die ds_msg who_called $progname $verbose
ds_prompt accept refuse $ds_yes)
);
# ACCESSORS
our ($verbose, $die_on_error, $ds_yes) = (0, 1, 0);
our $progname = basename($0);
sub printwarn {
my ($msg, $w) = @_;
chomp $msg;
if ($w) {
print STDERR "$msg\n";
} else {
print "$msg\n";
}
}
sub ds_msg {
my $msg = $_[0];
printwarn("$progname: $msg", $_[1]);
}
sub ds_verbose {
my $msg = $_[0];
if ($verbose > 0) {
printwarn("$progname info: $msg", $_[1]);
}
}
sub who_called {
return '' unless ($verbose > 1);
my @out = caller(1);
return " [$out[0]: $out[2]]";
}
sub ds_warn {
my $msg = $_[0];
printwarn("$progname warn: $msg" . who_called, 1);
}
sub ds_debug {
my $msg = $_[0];
printwarn("$progname debug: $msg", $_[1]) if $verbose > 1;
}
sub ds_extra_debug {
my $msg = $_[0];
printwarn("$progname debug: $msg", $_[1]) if $verbose > 2;
}
*ds_die = \&ds_error;
sub ds_error {
my $msg = $_[0];
$msg = "$progname error: $msg" . who_called;
if ($die_on_error) {
print STDERR "$msg\n";
exit 1;
}
printwarn($msg, 1);
}
sub ds_prompt {
return 'yes' if ($ds_yes > 0);
print STDERR shift;
my $s = <STDIN>;
chomp $s;
return $s;
}
1;
|