###########################################################################
# $Id: Formatting.pm,v 1.6 2005/10/02 16:47:36 wendigo Exp $
###########################################################################
#
# Log::Agent::Formatting
#
# RCS Revision: $Revision: 1.6 $
# Date: $Date: 2005/10/02 16:47:36 $
#
# Copyright (c) 1999 Raphael Manfredi
# Copyright (c) 2002-2003,2005 Mark Rogaski, mrogaski@cpan.org;
# all rights reserved.
#
# See the README file included with the
# distribution for license information.
#
# $Log: Formatting.pm,v $
# Revision 1.6  2005/10/02 16:47:36  wendigo
# Fixed formatting behavior for strings that contain "%%" without any other
# formating characters.
#
# Revision 1.5  2003/09/27 18:11:16  wendigo
# Modified comments.
#
# Revision 1.4  2003/09/27 17:41:41  wendigo
# Modified to use $Log::Agent::OS_Error for substitution of %m instead
# of $!.
#
# Revision 1.3  2003/03/08 16:40:27  wendigo
# Merged format and multiline carp changes
#
# Revision 1.2.2.1  2002/12/13 04:25:24  wendigo
# Fixed logxxx() formatting to match sprintf semantics.
#
# Revision 1.2  2002/05/12 07:20:03  wendigo
# Reduced format_args to adjust_msg
# Added prechecks of sprintf() arguments
#
# Revision 1.1  2002/03/09 16:01:37  wendigo
# New maintainer
#
# Revision 0.2.1.1  2001/03/13 18:45:06  ram
# patch2: renamed caller_format_args() as tag_format_args()
#
# Revision 0.2  2000/11/06 19:30:33  ram
# Baseline for second Alpha release.
#
###########################################################################

use strict;
require Exporter;

########################################################################
package Log::Agent::Formatting;

use vars qw(@ISA @EXPORT_OK);

@ISA = qw(Exporter);
@EXPORT_OK = qw(format_args tag_format_args);

require Log::Agent::Message;

#
# adjust_fmt
# 
# We process syslog's %m macro as being the current error message ($!) in
# the first argument only. Doing it at this level means it will be supported
# independently from the driver they'll choose. It's also done BEFORE any
# log-related system call, thus ensuring that $! retains its original value.
#
if ($] >= 5.005) {
    eval q{     # if VERSION >= 5.005
        # 5.005 and later version grok /(?<!)/
        sub adjust_fmt {
            my $fmt = shift;
            $fmt =~ s/((?<!%)(?:%%)*)%m/$Log::Agent::OS_Error/g;
            return $fmt;
        }
    }
} else {
    eval q{     # else /* VERSION < 5.005 */
        # pre-5.005 does not grok /(?<!)/
        sub adjust_fmt {
            my $fmt = shift;
            $fmt =~ s/%%/\01/g;
            $fmt =~ s/%m/$Log::Agent::OS_Error/g;
            $fmt =~ s/\01/%%/g;
            return $fmt;
        }
    }
}       # endif /* VERSION >= 5.005 */

#
# whine
#
# This is a local hack of carp 
#
sub whine {
    my $msg = shift;
    unless (chomp $msg) {
        my($package, $filename, $line) = caller 2;
        $msg .= " at $filename line $line.";
    }
    warn "$msg\n";
}

#
# tag_format_args
#
# Arguments:
#
#   $caller     caller information, done firstly
#   $priority   priority information, done secondly
#   $tags       list of user-defined tags, done lastly
#   $ary        arguments for sprintf()
#
# Returns a Log::Agent::Message object, which, when stringified, prints
# the string itself.
#
sub tag_format_args {
    my ($caller, $priority, $tags, $ary) = @_;
    my $msg = adjust_fmt(shift @$ary);

    # This bit of tomfoolery is intended to make debugging of
    # programs a bit easier by prechecking input to sprintf() 
    # for errors.  I usually prefer lazy error checking, but 
    # this seems to be an appropriate exception.
    if (my @arglist = $msg =~ /\%[^\%]*[csduoxefgXEGbpniDUOF]|\%\%/g) {
        BEGIN { no warnings }
        my $argcnt = grep !/\%\%/, @arglist;
        if (grep {! defined} @$ary[0..($argcnt - 1)]) {
            whine("Use of uninitialized value in sprintf");
        }
        $msg = sprintf $msg, @$ary;
    }

    my $str = Log::Agent::Message->make($msg);
    $caller->insert($str) if defined $caller;
    $priority->insert($str) if defined $priority;
    if (defined $tags) {
        foreach my $tag (@$tags) {
            $tag->insert($str);
        }
    }
    return $str;
}

1;