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
|
# -*- Mode: Perl -*-
#
# Utils.pm
# Copyright (C) 1997 Federico Di Gregorio.
#
# This module is part of the Debian Type Manager package.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
=head1 NAME
DTM::Utils - Some small usefull functions that doesn't fit elsewere
=cut
package DTM::Utils;
use File::Basename;
use Cwd;
require 5.004;
use strict;
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = 0.2;
@ISA = qw(Exporter);
@EXPORT = qw(&abs_path_file &safe_system &dtm_error &dtm_warning);
%EXPORT_TAGS = ();
@EXPORT_OK = qw();
sub abs_path_file {
my $file = shift ||
dtm_error("abs_path_file: missing argument");
my ($cd, $path);
($file, $path) = fileparse($file);
$cd = fastcwd();
chdir $path;
$path = fastcwd();
chdir $cd;
return ($path, $file);
};
sub safe_system {
my ($command, $errormessage) = @_;
my $ret = system $command;
if (int($ret/256) > 0) {
$errormessage = "running `$command' failed" if !$errormessage;
dtm_warning($errormessage);
}
}
# The standard error sub prints the message and exits
sub __dtm_std_error {
my $msg = shift;
print STDERR "error: $msg\n";
exit;
}
my $error_sub = \&__dtm_std_error;
sub dtm_set_error_sub {
$error_sub = shift || \&__dtm_std_error;
}
sub dtm_error {
&$error_sub;
}
# Print out a warning message but does not exit
sub __dtm_std_warning {
my $msg = shift;
print STDERR "warning: $msg\n";
}
my $warning_sub = \&__dtm_std_warning;
sub dtm_set_warning_sub {
$warning_sub = shift || \&__dtm_std_warning;
}
sub dtm_warning {
&$warning_sub;
}
# return true
1
|
