sanitizer 1.76-3 / usr / share / perl5 / Anomy / Log.pm

#!/usr/bin/perl
#
my $revision = '$Id: Log.pm,v 1.9 2002/01/04 18:32:49 bre Exp $';
my $version = 'Anomy 0.0.0 : sanitizer.pl';
#
##  Copyright (c) 2001-2002 Bjarni R. Einarsson. All rights reserved.
##  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 of the License, or
##  (at your option) any later version.
#
##############################################################################
#
# NOTE:  Sanitizer development is for the most part sponsored by
#        FRISK Software International, http://www.f-prot.com/.  Please
#        consider buying their anti-virus products to show your 
#        appreciation.
#
##############################################################################
#
# This a module for handling nested log files.  It provides a framework 
# for building very detailed logs in memory and outputting them either as
# human readable text or XML.
#
# Example:
#
#   my $log1 = new Anomy::Log;
#   my $log2 = new Anomy::Log;
#   my $log3;
#
#   # Set up local hooks for events
#   $log1->add_hook("match", sub { print "Hey, something matched!\n"; } );
#   $log1->add_hook("part",  sub { print "Ooh, a new part!\n"; } );
#
#   # Set up a global hook (inherited by sub-logs)
#   $log1->add_hook("thing",  sub { print "Ooh, a new thing!\n"; }, "global" );
#
#   # Record an event
#   $log1->entry("match", SLOG_INFO, { rule => 3 }, "Matched rule %rule%." );
#
#   # Attach $log2 to an entry in $log1.
#   $log->sublog("part", SLOG_TRACE, { type => "multipart/mixed" }, $log2);
#
#   # Create a new log ($log3) chained to an entry in $log1.
#   $log3 = $log1->sublog("part", SLOG_TRACE, { type => "multipart/mixed" });
#
#   # Print everything of level SLOG_INFO as text.
#   print $log1->print_as_text(SLOG_INFO);
#
#   # Print everyting (any level) as XML.
#   print $log1->print_as_xml(SLOG_ALL);
#
##[ Package definition ]######################################################

package Anomy::Log;
use strict;
 
BEGIN {
    use Exporter ();
    use vars         qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION         = do { my @r = (q$Revision: 1.9 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
    @ISA             = qw(Exporter);
    @EXPORT          = qw(&SLOG_ERROR 
                          &SLOG_WARNING 
			  &SLOG_INFO
			  &SLOG_DEBUG
			  &SLOG_TRACE
                          &SLOG_SUBLOG 
			  &SLOG_ALL);
    @EXPORT_OK       = qw( );
}

use vars @EXPORT_OK;

##[ Constants ]###############################################################

# Log message types
sub SLOG_ERROR        { return 0x0001; }
sub SLOG_WARNING      { return 0x0002; }
sub SLOG_INFO         { return 0x0004; }
sub SLOG_DEBUG        { return 0x0008; }
sub SLOG_SUBLOG       { return 0x4000; }
sub SLOG_TRACE        { return 0x8000; }
sub SLOG_ALL          { return 0xFFFF; }

sub LOG_ENTRY         { return 1; }
sub LOG_SUBLOG        { return 2; }

##[ Package implementation ]##################################################

sub new 
{
    my ($proto) = @_;
    my $class = ref($proto) || $proto;

    my $self = {
        "local_hooks"  => { },
        "global_hooks" => { },
        "log"          => [ ],
    };
    bless ($self, $class);

    return $self;
}

# Wipe the log clean.
sub clear
{
    my $self = shift;
    $self->{"log"} = [ ];
}

# Register a new hook.
sub add_hook
{
    my ($self, $tag, $hook, $global) = @_;

    my $h = "local_hooks";
       $h = "global_hooks" if ($global);

    $self->{$h}->{$tag} = [ ] unless ($self->{$h}->{$tag});
    push @{ $self->{$h}->{$tag} }, $hook;
}

# Check for hooks for this log entry type, execute them if present.
# Returns 1 (true) if no hooks are found, otherwise it returns the
# value returned by the hook.
sub check_hook
{
    my ($self, $entry) = @_;
    my $ret = 1;
    
    foreach my $h ("local_hooks", "global_hooks")
    {
        if (my $hooks = $self->{$h}->{ $entry->[1] })
        {
            foreach my $cmd (@{ $hooks })
	    {
                $ret = 0 unless (&$cmd($self, $entry));
	    }
        }
    }
    return $ret;
}

# Usage:
#
#  $log->entry("match", SLOG_INFO, { rule => 3 }, "Matched rule %rule%." );
#
sub entry
{
    my ($self, $tag, $level, $attr, $data) = @_;
    my $entry = [ LOG_ENTRY, $tag, $level, $attr || { }, $data ];
    push @{ $self->{"log"} }, $entry if ($self->check_hook($entry));
}

# Usage:
#
#  $sublog = $log->sublog("part", SLOG_TRACE, { type => "multipart/mixed" });
#  $log->sublog("part", SLOG_TRACE, { type => "multipart/mixed" }, $sublog);
#
sub sublog
{
    my ($self, $tag, $level, $attr, $sl) = @_;
    $sl = new Anomy::Log unless ($sl);

    # Inherit global hooks from parent
    $sl->{"global_hooks"} = $self->{"global_hooks"};

    $level = 0 unless ($level);
    $level |= SLOG_SUBLOG;

    my $entry = [ LOG_SUBLOG, $tag, $level, $attr || { }, $sl ];
    push @{ $self->{"log"} }, $entry if ($self->check_hook($entry));
    return $sl;
}

# Render a log as a bit of HTML, using the embedded descriptions.
#
# Usage:
#
#  $text = $log->print_as_text(SLOG_ALL);
#
sub print_as_html
{
    my ($self, $out_level, $prefix, $color) = @_;

    my $ret = $self->print_as_text($out_level, $prefix);
    $ret =~ s/&/&/g;
    $ret =~ s/</&lt;/g;
    $ret =~ s/>/&gt;/g;

    return "<pre><font color=\"$color\">\n$ret\n</font></pre>\n";
}

# Render a log as a text file, using the embedded descriptions.
#
# Usage:
#
#  $text = $log->print_as_text(SLOG_ALL);
sub print_as_text
{
    my ($self, $out_level, $prefix) = @_;
    my $ret = "";

    $out_level = SLOG_ALL unless (defined $out_level);

    foreach my $entry (@{ $self->{"log"} })
    {
        my ($type, $tag, $level, $attr, $data) = @{ $entry };

        my $attrs = join(", ", map { $_="$_=\"".$attr->{$_}."\"" } 
	                           sort(keys(%{ $attr })));

        if (LOG_SUBLOG == $type)
	{
	    my $d = $data->print_as_text($out_level, $prefix."  ");
	    if (($d) || ($level & $out_level))
	    {
	        $ret .= $prefix.$tag." (".$attrs."):\n".$d."\n";
	    }
	    $ret =~ s/\n\n+$/\n\n/;
	}
	elsif ($level & $out_level)
	{
	    my $d = $data;
	    foreach my $key (sort(keys(%{ $attr })))
	    {
	        $d =~ s/%$key%/$attr->{$key}/g;
	    }
	    $d =~ s/%ATTRIBUTES%/$attrs/g;
	    $d =~ s/\n/\n$prefix/gs;
	    $ret .= $prefix.$d."\n";
	}
    }

    return $ret;
}


# Render a log as an XML-formatted string, pruning all leaves not matching
# the requested log level.
#
# Usage:
#
#  $text = $log->print_as_xml(SLOG_ALL);
#
sub print_as_xml
{
    my ($self, $out_level, $prefix) = @_;
    my $ret = "";

    $out_level = SLOG_ALL unless (defined $out_level);

    foreach my $entry (@{ $self->{"log"} })
    {
        my ($type, $tag, $level, $attr, $data) = @{ $entry };

        if (LOG_SUBLOG == $type)
	{
	    my $d = $data->print_as_xml($out_level, $prefix."  ");
	    if (($d) || ($level & $out_level))
	    {
	        $ret .= $prefix;
		$ret .= print_tag($tag, $attr)."\n";
		$ret .= $d;
		$ret .= $prefix."</".$tag.">\n";
	    }
	}
	elsif ($level & $out_level)
	{
	    $ret .= $prefix;
	    $ret .= print_tag($tag, $attr);
	    $ret .= encode_xml($data);
	    $ret .= "</".$tag.">\n";
	}
    }

    return $ret;
}

## Helper for print_as_xml
sub print_tag
{
    my ($tag, $attr) = @_;
    my $ret = "<".$tag;
    
    foreach my $a (sort(keys(%{ $attr })))
    {
        $ret .= " $a=\"". encode_xml($attr->{$a}) ."\"";
    }
    $ret .= ">";
    return $ret;
}

## Helper for print_as_xml 
sub encode_xml
{
   my $text = shift;
   $text =~ s/&/&amp;/g;
   $text =~ s/</&lt;/g;
   $text =~ s/>/&gt;/g;
   $text =~ s/"/&quot;/g;     # FIXME!! Probably not valid XML!
   $text =~ s/\n/&nl;/g;      # FIXME!! Probably not valid XML!
   return $text;
}

1;
#EOF#