File Coverage

blib/lib/Net/XMPP/Debug.pm

Criterion	Covered	Total	%
statement	53	107	49.5
branch	20	50	40.0
condition	2	3	66.6
subroutine	11	12	91.6
pod	2	6	33.3
total	88	178	49.4

##############################################################################
#
#  This library is free software; you can redistribute it and/or
#  modify it under the terms of the GNU Library General Public
#  License as published by the Free Software Foundation; either
#  version 2 of the License, or (at your option) any later version.
#
#  This library is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#  Library General Public License for more details.
#
#  You should have received a copy of the GNU Library General Public
#  License along with this library; if not, write to the
#  Free Software Foundation, Inc., 59 Temple Place - Suite 330,
#  Boston, MA  02111-1307, USA.
#
#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
#
##############################################################################

package Net::XMPP::Debug;

=head1 NAME

Net::XMPP::Debug - XMPP Debug Module

=head1 SYNOPSIS

Net::XMPP::Debug is a module that provides a developer easy access
to logging debug information.

=head1 DESCRIPTION

Debug is a helper module for the Net::XMPP modules.  It provides
the Net::XMPP modules with an object to control where, how, and
what is logged.

=head2 Basic Functions

    $Debug = Net::XMPP::Debug->new();

    $Debug->Init(
           level  => 2,
	   file   => "stdout",
	   header =>"MyScript");

    $Debug->Log0("Connection established");

=head1 METHODS

=head2 Basic Functions

=over 4

=item new

    new(hash)

creates the Debug object.  The hash argument is passed
to the Init function.  See that function description
below for the valid settings.

=item Init

    Init(
         level      => integer,
         file       => string,
         header     => string,
         setdefault => 0|1,
         usedefault => 0|1,
         time       => 0|1)

initializes the debug object.

The B determines the maximum level of debug
messages to log:

  0 - Base level Output (default)
  1 - High level API calls
  2 - Low level API calls
  ...
  N - Whatever you want....

The B determines where the debug log
goes.  You can either specify a path to
a file, or "stdout" (the default).  "stdout"
tells Debug to send all of the debug info
sent to this object to go to stdout.

B is a string that will preappended
to the beginning of all log entries.  This
makes it easier to see what generated the
log entry (default is "Debug").

B saves the current filehandle
and makes it available for other Debug
objects to use.  To use the default set
B to 1.

The B parameter specifies whether or not to add a
timestamp to the beginning of each logged line.

=item LogN

  LogN(array)

Logs the elements of the array at the corresponding
debug level N.  If you pass in a reference to an
array or hash then they are printed in a readable
way.  (ie... Log0, Log2, Log100, etc...)

=back

=head1 EXAMPLE

  $Debug = Net::XMPP:Debug->new(level=>2,
                               header=>"Example");

  $Debug->Log0("test");

  $Debug->Log2("level 2 test");

  $hash{a} = "atest";
  $hash{b} = "btest";

  $Debug->Log1("hashtest", \%hash);

You would get the following log:

    Example: test
    Example: level 2 test
    Example: hashtest { a=>"atest" b=>"btest" }

If you had set the level to 1 instead of 2 you would get:

    Example: test
    Example: hashtest { a=>"atest" b=>"btest" }

=head1 AUTHOR

Originally authored by Ryan Eatmon.

Previously maintained by Eric Hacker.

Currently maintained by Darian Anthony Patrick.

=head1 COPYRIGHT

This module is free software, you can redistribute it and/or modify it
under the LGPL 2.1.

=cut

require 5.008;
use strict;
use warnings;
use FileHandle;
use Carp;
use vars qw( %HANDLES $DEFAULT $DEFAULTLEVEL $DEFAULTTIME $AUTOLOAD );

$DEFAULTLEVEL = -1;

sub new
{
    my $proto = shift;
    my $self = { };
    bless($self, $proto);

    $self->Init(@_);

    return $self;
}


##############################################################################
#
# Init - opens the fielhandle and initializes the Debug object.
#
##############################################################################
sub Init
{
    my $self = shift;

    my %args;
    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }

    delete($args{file}) if (defined $args{file} && lc($args{file}) eq "stdout");

    $args{time} = 0 if !exists($args{time});
    $args{setdefault} = 0 if !exists($args{setdefault});
    $args{usedefault} = 0 if !exists($args{usedefault});

    $self->{TIME} = $args{time};

    if ($args{usedefault} == 1)
    {
        $args{setdefault} = 0;
        $self->{USEDEFAULT} = 1;
    }
    else
    {
        $self->{LEVEL} = 0;
        $self->{LEVEL} = $args{level} if exists($args{level});
        if ($self->{LEVEL} >= 0)
        {

            $self->{HANDLE} = FileHandle->new(">&STDERR");
            $self->{HANDLE}->autoflush(1);
            if (exists($args{file}))
            {
                if (exists($Net::XMPP::Debug::HANDLES{$args{file}}))
                {
                    $self->{HANDLE} = $Net::XMPP::Debug::HANDLES{$args{file}};
                    $self->{HANDLE}->autoflush(1);
                }
                else
                {
                    if (-e $args{file})
                    {
                        if (-w $args{file})
                        {
                            $self->{HANDLE} = FileHandle->new(">$args{file}");
                            if (defined($self->{HANDLE}))
                            {
                                $self->{HANDLE}->autoflush(1);
                                $Net::XMPP::Debug::HANDLES{$args{file}} = $self->{HANDLE};
                            }
                            else
                            {
                                print STDERR "ERROR: Debug filehandle could not be opened.\n";
                                print STDERR"        Debugging disabled.\n";
                                print STDERR "       ($!)\n";
                                $self->{LEVEL} = -1;
                            }
                        }
                        else
                        {
                            print STDERR "ERROR: You do not have permission to write to $args{file}.\n";
                            print STDERR"        Debugging disabled.\n";
                            $self->{LEVEL} = -1;
                        }
                    }
                    else
                    {
                        $self->{HANDLE} = FileHandle->new(">$args{file}");
                        if (defined($self->{HANDLE}))
                        {
                            $self->{HANDLE}->autoflush(1);
                            $Net::XMPP::Debug::HANDLES{$args{file}} = $self->{HANDLE};
                        }
                        else
                        {
                            print STDERR "ERROR: Debug filehandle could not be opened.\n";
                            print STDERR"        Debugging disabled.\n";
                            print STDERR "       ($!)\n";
                            $self->{LEVEL} = -1;
                        }
                    }
                }
            }
        }
    }
    if ($args{setdefault} == 1)
    {
        $Net::XMPP::Debug::DEFAULT = $self->{HANDLE};
        $Net::XMPP::Debug::DEFAULTLEVEL = $self->{LEVEL};
        $Net::XMPP::Debug::DEFAULTTIME = $self->{TIME};
    }

    $self->{HEADER} = "Debug";
    $self->{HEADER} = $args{header} if exists($args{header});
}


##############################################################################
#
# Log - takes the limit and the array to log and logs them
#
##############################################################################
sub Log
{
    my $self = shift;
    my (@args) = @_;

    my $fh = $self->{HANDLE};
    $fh = $Net::XMPP::Debug::DEFAULT if exists($self->{USEDEFAULT});
    return if not $fh;

    my $string = "";

    my $testTime = $self->{TIME};
    $testTime = $Net::XMPP::Debug::DEFAULTTIME if exists($self->{USEDEFAULT});

    $string .= "[".&Net::XMPP::GetTimeStamp("local",time,"short")."] "
        if ($testTime == 1);
    $string .= $self->{HEADER}.": ";

    my $arg;

    foreach $arg (@args)
    {
        if (ref($arg) eq "HASH")
        {
            $string .= " {";
            my $key;
            foreach $key (sort {$a cmp $b} keys(%{$arg}))
            {
                $string .= " ".$key."=>'".$arg->{$key}."'";
            }
            $string .= " }";
        }
        else
        {
            if (ref($arg) eq "ARRAY")
            {
                $string .= " [ ".join(" ",@{$arg})." ]";
            }  else {
                $string .= $arg;
            }
        }
    }
    print $fh "$string\n";
    return 1;
}


##############################################################################
#
# AUTOLOAD - if a function is called that is not defined then this function
#            will examine the function name and either give an error or call
#            the appropriate function.
#
##############################################################################
sub AUTOLOAD
{
    my $self = shift;
    return if ($AUTOLOAD =~ /::DESTROY$/);
    my ($function) = ($AUTOLOAD =~ /\:\:(.*)$/);
    croak("$function not defined") if !($function =~ /Log\d+/);
    my ($level) = ($function =~ /Log(\d+)/);
    return 0 if ($level > (exists($self->{USEDEFAULT}) ? $Net::XMPP::Debug::DEFAULTLEVEL : $self->{LEVEL}));
    $self->Log(@_);
}


##############################################################################
#
# GetHandle - returns the filehandle being used by this object.
#
##############################################################################
sub GetHandle
{
    my $self = shift;
    return $self->{HANDLE};
}


##############################################################################
#
# GetLevel - returns the debug level used by this object.
#
##############################################################################
sub GetLevel
{
    my $self = shift;
    return $self->{LEVEL};
}


##############################################################################
#
# GetTime - returns the debug time used by this object.
#
##############################################################################
sub GetTime
{
    my $self = shift;
    return $self->{TIME};
}


1;