File Coverage

blib/lib/MIME/Tools.pm
Criterion Covered Total %
statement 38 46 82.6
branch 10 24 41.6
condition 6 11 54.5
subroutine 13 15 86.6
pod 3 10 30.0
total 70 106 66.0


line stmt bran cond sub pod time code
1             package MIME::Tools;
2              
3             #------------------------------
4             # Because the POD documentation is pretty extensive, it follows
5             # the __END__ statement below...
6             #------------------------------
7              
8 28     28   293596 use strict;
  28         36  
  28         823  
9 28         2271 use vars (qw(@ISA %CONFIG @EXPORT_OK %EXPORT_TAGS $VERSION $ME
10 28     28   97 $M_DEBUG $M_WARNING $M_ERROR ));
  28         33  
11              
12             require Exporter;
13 28     28   5006 use IO::File;
  28         75288  
  28         2642  
14 28     28   18144 use File::Temp 0.18 ();
  28         257041  
  28         667  
15 28     28   140 use Carp;
  28         31  
  28         15573  
16              
17             $ME = "MIME-tools";
18              
19             @ISA = qw(Exporter);
20              
21             # Exporting (importing should only be done by modules in this toolkit!):
22             %EXPORT_TAGS = (
23             'config' => [qw(%CONFIG)],
24             'msgs' => [qw(usage debug whine error)],
25             'msgtypes'=> [qw($M_DEBUG $M_WARNING $M_ERROR)],
26             'utils' => [qw(textual_type tmpopen )],
27             );
28             Exporter::export_ok_tags('config', 'msgs', 'msgtypes', 'utils');
29              
30             # The TOOLKIT version, both in 1.23 style *and* usable by MakeMaker:
31             $VERSION = "5.508";
32              
33             # Configuration (do NOT alter this directly)...
34             # All legal CONFIG vars *must* be in here, even if only to be set to undef:
35             %CONFIG =
36             (
37             DEBUGGING => 0,
38             QUIET => 1,
39             );
40              
41             # Message-logging constants:
42             $M_DEBUG = 'debug';
43             $M_WARNING = 'warning';
44             $M_ERROR = 'error';
45              
46              
47              
48             #------------------------------
49             #
50             # CONFIGURATION... (see below)
51             #
52             #------------------------------
53              
54             sub config {
55 0     0 0 0 my $class = shift;
56 0         0 usage("config() is obsolete");
57              
58             # No args? Just return list:
59 0 0       0 @_ or return keys %CONFIG;
60 0         0 my $method = lc(shift);
61 0         0 return $class->$method(@_);
62             }
63              
64             sub debugging {
65 1533     1533 1 1313 my ($class, $value) = @_;
66 1533 50       2261 $CONFIG{'DEBUGGING'} = $value if (@_ > 1);
67 1533         3317 return $CONFIG{'DEBUGGING'};
68             }
69              
70             sub quiet {
71 0     0 1 0 my ($class, $value) = @_;
72 0 0       0 $CONFIG{'QUIET'} = $value if (@_ > 1);
73 0         0 return $CONFIG{'QUIET'};
74             }
75              
76             sub version {
77 22     22 1 33 my ($class, $value) = @_;
78 22         84 return $VERSION;
79             }
80              
81              
82              
83             #------------------------------
84             #
85             # MESSAGES...
86             #
87             #------------------------------
88              
89             #------------------------------
90             #
91             # debug MESSAGE...
92             #
93             # Function, private.
94             # Output a debug message.
95             #
96             sub debug {
97 48 50   48 0 415 print STDERR "$ME: $M_DEBUG: ", @_, "\n" if $CONFIG{DEBUGGING};
98             }
99              
100             #------------------------------
101             #
102             # whine MESSAGE...
103             #
104             # Function, private.
105             # Something doesn't look right: issue a warning.
106             # Only output if $^W (-w) is true, and we're not being QUIET.
107             #
108             sub whine {
109 28     28 0 102 my $msg = "$ME: $M_WARNING: ".join('', @_)."\n";
110 28 50 66     154 warn $msg if ($^W && !$CONFIG{QUIET});
111 28 50       75 return (wantarray ? () : undef);
112             }
113              
114             #------------------------------
115             #
116             # error MESSAGE...
117             #
118             # Function, private.
119             # Something failed, but not so badly that we want to throw an
120             # exception. Just report our general unhappiness.
121             # Only output if $^W (-w) is true, and we're not being QUIET.
122             #
123             sub error {
124 6     6 0 127 my $msg = "$ME: $M_ERROR: ".join('', @_)."\n";
125 6 50 33     31 warn $msg if ($^W && !$CONFIG{QUIET});
126 6 50       14 return (wantarray ? () : undef);
127             }
128              
129             #------------------------------
130             #
131             # usage MESSAGE...
132             #
133             # Register unhappiness about usage.
134             #
135             sub usage {
136 3     3 0 16 my ( $p, $f, $l, $s) = caller(1);
137 3         6 my ($cp, $cf, $cl, $cs) = caller(2);
138 3 50       13 my $msg = join('', (($s =~ /::/) ? "$s() " : "${p}::$s() "), @_, "\n");
139 3 50       6 my $loc = ($cf ? "\tin code called from $cf l.$cl" : '');
140              
141 3 50 33     13 warn "$msg$loc\n" if ($^W && !$CONFIG{QUIET});
142 3 50       8 return (wantarray ? () : undef);
143             }
144              
145              
146              
147             #------------------------------
148             #
149             # UTILS...
150             #
151             #------------------------------
152              
153             #------------------------------
154             #
155             # textual_type MIMETYPE
156             #
157             # Function. Does the given MIME type indicate a textlike document?
158             #
159             sub textual_type {
160 196     196 0 940 ($_[0] =~ m{^(text|message)(/|\Z)}i);
161             }
162              
163             #------------------------------
164             #
165             # tmpopen
166             #
167             #
168             sub tmpopen
169             {
170 103     103 0 88 my ($args) = @_;
171 103   100     175 $args ||= {};
172 103         85 return File::Temp->new( %{$args} );
  103         616  
173             }
174              
175             #------------------------------
176             1;
177             __END__