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

package MIME::Tools;

#------------------------------
# Because the POD documentation is pretty extensive, it follows
# the __END__ statement below...
#------------------------------

use strict;
use vars (qw(@ISA %CONFIG @EXPORT_OK %EXPORT_TAGS $VERSION $ME
	     $M_DEBUG $M_WARNING $M_ERROR ));

require Exporter;
use IO::File;
use File::Temp 0.18 ();
use Carp;

$ME = "MIME-tools";

@ISA = qw(Exporter);

# Exporting (importing should only be done by modules in this toolkit!):
%EXPORT_TAGS = (
    'config'  => [qw(%CONFIG)],
    'msgs'    => [qw(usage debug whine error)],
    'msgtypes'=> [qw($M_DEBUG $M_WARNING $M_ERROR)],
    'utils'   => [qw(textual_type tmpopen )],
    );
Exporter::export_ok_tags('config', 'msgs', 'msgtypes', 'utils');

# The TOOLKIT version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "5.508";

# Configuration (do NOT alter this directly)...
# All legal CONFIG vars *must* be in here, even if only to be set to undef:
%CONFIG =
    (
     DEBUGGING       => 0,
     QUIET           => 1,
     );

# Message-logging constants:
$M_DEBUG   = 'debug';
$M_WARNING = 'warning';
$M_ERROR   = 'error';



#------------------------------
#
# CONFIGURATION... (see below)
#
#------------------------------

sub config {
    my $class = shift;
    usage("config() is obsolete");

    # No args? Just return list:
    @_ or return keys %CONFIG;
    my $method = lc(shift);
    return $class->$method(@_);
}

sub debugging {
    my ($class, $value) = @_;
    $CONFIG{'DEBUGGING'} = $value   if (@_ > 1);
    return $CONFIG{'DEBUGGING'};
}

sub quiet {
    my ($class, $value) = @_;
    $CONFIG{'QUIET'} = $value   if (@_ > 1);
    return $CONFIG{'QUIET'};
}

sub version {
    my ($class, $value) = @_;
    return $VERSION;
}



#------------------------------
#
# MESSAGES...
#
#------------------------------

#------------------------------
#
# debug MESSAGE...
#
# Function, private.
# Output a debug message.
#
sub debug {
    print STDERR "$ME: $M_DEBUG: ", @_, "\n"      if $CONFIG{DEBUGGING};
}

#------------------------------
#
# whine MESSAGE...
#
# Function, private.
# Something doesn't look right: issue a warning.
# Only output if $^W (-w) is true, and we're not being QUIET.
#
sub whine {
    my $msg = "$ME: $M_WARNING: ".join('', @_)."\n";
    warn $msg if ($^W && !$CONFIG{QUIET});
    return (wantarray ? () : undef);
}

#------------------------------
#
# error MESSAGE...
#
# Function, private.
# Something failed, but not so badly that we want to throw an
# exception.  Just report our general unhappiness.
# Only output if $^W (-w) is true, and we're not being QUIET.
#
sub error {
    my $msg = "$ME: $M_ERROR: ".join('', @_)."\n";
    warn $msg if ($^W && !$CONFIG{QUIET});
    return (wantarray ? () : undef);
}

#------------------------------
#
# usage MESSAGE...
#
# Register unhappiness about usage.
#
sub usage {
    my ( $p,  $f,  $l,  $s) = caller(1);
    my ($cp, $cf, $cl, $cs) = caller(2);
    my $msg = join('', (($s =~ /::/) ? "$s() " : "${p}::$s() "), @_, "\n");
    my $loc = ($cf ? "\tin code called from $cf l.$cl" : '');

    warn "$msg$loc\n" if ($^W && !$CONFIG{QUIET});
    return (wantarray ? () : undef);
}



#------------------------------
#
# UTILS...
#
#------------------------------

#------------------------------
#
# textual_type MIMETYPE
#
# Function.  Does the given MIME type indicate a textlike document?
#
sub textual_type {
    ($_[0] =~ m{^(text|message)(/|\Z)}i);
}

#------------------------------
#
# tmpopen
#
#
sub tmpopen
{
	my ($args) = @_;
	$args ||= {};
	return File::Temp->new( %{$args} );
}

#------------------------------
1;
__END__