<commit_before>#!/usr/bin/perl -w

#
# EMULAB-COPYRIGHT
# Copyright (c) 2005, 2010 University of Utah and the Flux Group.
# All rights reserved.
#

#
# libtblog-simple: Logging library for testbed
#
# This version ...
#

package libtblog_simple;

sub import {
    'libtblog'->export_to_level (1, @_);
}

package libtblog;
use Exporter;

@ISA = "Exporter";
@EXPORT = qw (tblog tberror tberr tbwarn tbwarning tbnotice tbinfo tbdebug 
	      tbdie tblog_session 
	      TBLOG_EMERG TBLOG_ALERT TBLOG_CRIT TBLOG_ERR 
	      TBLOG_WARNING TBLOG_NOTICE TBLOG_INFO TBLOG_DEBUG
	      SEV_DEBUG SEV_NOTICE SEV_WARNING SEV_SECONDARY
	      SEV_ERROR SEV_ADDITIONAL SEV_IMMEDIATE);

# After package decl.
# DO NOT USE "use English" in this module
use File::Basename;
use IO::Handle;
use Text::Wrap;
use Carp;

use strict;

use vars qw($SCRIPTNAME 
	    $EMERG $ALRET $CRIT $ERR $WARNING $NOTICE $INFO $DEBUG
	    %PRIORITY_MAP_TO_STR %PRIORITY_MAP_TO_NUM
	    *SOUT *SERR);

#
# Duplicate STDOUT and STDERR to SOUT and SERR respectfully, since
# tblog_capture() will redirect the real STDOUT and STDERR
#

open SOUT ,">&=STDOUT"; # Must be "&=" not "&" to avoid creating a
                        # new low level file descriper as this
                        # interacts strangly with the fork in swapexp.
autoflush SOUT 1;
open SERR ,">&=STDERR"; # Ditto
autoflush SERR 1;
						       
#
#
#

$SCRIPTNAME = basename($0);

#
# Make constants for the error level, the sub, prefixed with TBLOG_,
# are exported, the non-prefixed variables are used internally
#

sub TBLOG_EMERG   {000} $EMERG   = 000;
sub TBLOG_ALERT   {100} $ALRET   = 100;
sub TBLOG_CRIT    {200} $CRIT    = 200;
sub TBLOG_ERR     {300} $ERR     = 300;
sub TBLOG_WARNING {400} $WARNING = 400;
sub TBLOG_NOTICE  {500} $NOTICE  = 500;
sub TBLOG_INFO    {600} $INFO    = 600;
sub TBLOG_DEBUG   {700} $DEBUG   = 700;

%PRIORITY_MAP_TO_STR = (000 => 'EMERG',
	                100 => 'ALRET',
               	        200 => 'CRIT',
           	        300 => 'ERR',
			400 => 'WARNING',
			500 => 'NOTICE',
			600 => 'INFO',
			700 => 'DEBUG');
while (my ($n,$v) = each %PRIORITY_MAP_TO_STR) {
  $PRIORITY_MAP_TO_NUM{uc $v} = $n;
  $PRIORITY_MAP_TO_NUM{lc $v} = $n;
}

#
# tbreport related constants
#

use constant SEV_DEBUG      =>   0;
use constant SEV_NOTICE     => 100;
use constant SEV_WARNING    => 300;
use constant SEV_SECONDARY  => 400;
use constant SEV_ERROR      => 500; # Threshold
use constant SEV_ADDITIONAL => 600;
use constant SEV_IMMEDIATE  => 900;

#
# Utility functions
#

sub if_defined ($$) {
    return $_[0] if defined $_[0];
    return $_[1] if defined $_[1];
    return '';
}

sub oneof ($@) {
    my ($to_find) = shift;
    my @res = grep {$to_find eq $_} @_;
    return @res > 0;
}

sub scriptname() {
  if_defined($SCRIPTNAME, $ENV{TBLOG_SCRIPTNAME});
}

#
#
#

sub tblog_session() {
    return $ENV{TBLOG_SESSION};
}


#
# Dummy dblog, does nothing in this module
# Once the real "libtblog.pm" is used than this will be replaced
# with the real function which logs to the database
#
sub dblog_dummy( $$@ ) {
  return 1;
}
*dblog = \&dblog_dummy;


#
# tblog(priority, mesg, ...)
# tblog(priority, {parm=>value,...}, mesg, ...)
#
#   The main log function.  Logs a message to the database and print
#   the message to STDERR with an approate prefix depending on the
#   severity of the error.  If more than one string is given for the
#   message than they will concatenated.  If the env. var. TBLOG_OFF
#   is set to a true value than nothing will be written to the
#   database, but the message will still be written to STDOUT.  
#   Useful parms: sublevel, cause, type
#
sub tblog( $@ ) {
    my ($priority) = shift;
    my $parms = {};
    $parms = shift if ref $_[0] eq 'HASH';
    my $mesg = join('',@_);

    if (exists $PRIORITY_MAP_TO_STR{$priority}) {
      # $priority already a valid priority number
    } elsif (exists $PRIORITY_MAP_TO_NUM{$priority}) {
      # $priority a priority string, convert to num
      $priority = $PRIORITY_MAP_TO_NUM{$priority}
    } else {
      croak "Unknown priority \"$priority\" in call to tblog";
    }

    my $res = dblog($priority, $parms, $mesg) unless $mesg =~ /^\s+$/;
    
    print SERR format_message(scriptname(), $priority, $mesg);

    return $res;
}


# Useful alias functions

sub tberror( @ ) {&tblog($ERR, @_)}
sub tberr( @ ) {&tblog($ERR, @_)}
sub tbwarn( @ ) {&tblog($WARNING, @_)}
sub tbwarning( @ ) {&tblog($WARNING, @_)}
sub tbnotice( @ ) {&tblog($NOTICE, @_)}
sub tbinfo( @ ) {&tblog($INFO, @_)}
sub tbdebug( @ ) {&tblog($DEBUG, @_)}
<commit_msg>Hack to shutup perl 5.12 about unused SOUT variable.<commit_after>#!/usr/bin/perl -w

#
# EMULAB-COPYRIGHT
# Copyright (c) 2005-2012 University of Utah and the Flux Group.
# All rights reserved.
#

#
# libtblog-simple: Logging library for testbed
#
# This version ...
#

package libtblog_simple;

sub import {
    'libtblog'->export_to_level (1, @_);
}

package libtblog;
use Exporter;

@ISA = "Exporter";
@EXPORT = qw (tblog tberror tberr tbwarn tbwarning tbnotice tbinfo tbdebug 
	      tbdie tblog_session 
	      TBLOG_EMERG TBLOG_ALERT TBLOG_CRIT TBLOG_ERR 
	      TBLOG_WARNING TBLOG_NOTICE TBLOG_INFO TBLOG_DEBUG
	      SEV_DEBUG SEV_NOTICE SEV_WARNING SEV_SECONDARY
	      SEV_ERROR SEV_ADDITIONAL SEV_IMMEDIATE);

# After package decl.
# DO NOT USE "use English" in this module
use File::Basename;
use IO::Handle;
use Text::Wrap;
use Carp;

use strict;

use vars qw($SCRIPTNAME 
	    $EMERG $ALRET $CRIT $ERR $WARNING $NOTICE $INFO $DEBUG
	    %PRIORITY_MAP_TO_STR %PRIORITY_MAP_TO_NUM
	    *SOUT *SERR);

#
# Duplicate STDOUT and STDERR to SOUT and SERR respectfully, since
# tblog_capture() will redirect the real STDOUT and STDERR
#

open SOUT ,">&=STDOUT"; # Must be "&=" not "&" to avoid creating a
                        # new low level file descriper as this
                        # interacts strangly with the fork in swapexp.
autoflush SOUT 1;
open SERR ,">&=STDERR"; # Ditto
autoflush SERR 1;
						       
#
#
#

$SCRIPTNAME = basename($0);

#
# Make constants for the error level, the sub, prefixed with TBLOG_,
# are exported, the non-prefixed variables are used internally
#

sub TBLOG_EMERG   {000} $EMERG   = 000;
sub TBLOG_ALERT   {100} $ALRET   = 100;
sub TBLOG_CRIT    {200} $CRIT    = 200;
sub TBLOG_ERR     {300} $ERR     = 300;
sub TBLOG_WARNING {400} $WARNING = 400;
sub TBLOG_NOTICE  {500} $NOTICE  = 500;
sub TBLOG_INFO    {600} $INFO    = 600;
sub TBLOG_DEBUG   {700} $DEBUG   = 700;

%PRIORITY_MAP_TO_STR = (000 => 'EMERG',
	                100 => 'ALRET',
               	        200 => 'CRIT',
           	        300 => 'ERR',
			400 => 'WARNING',
			500 => 'NOTICE',
			600 => 'INFO',
			700 => 'DEBUG');
while (my ($n,$v) = each %PRIORITY_MAP_TO_STR) {
  $PRIORITY_MAP_TO_NUM{uc $v} = $n;
  $PRIORITY_MAP_TO_NUM{lc $v} = $n;
}

#
# tbreport related constants
#

use constant SEV_DEBUG      =>   0;
use constant SEV_NOTICE     => 100;
use constant SEV_WARNING    => 300;
use constant SEV_SECONDARY  => 400;
use constant SEV_ERROR      => 500; # Threshold
use constant SEV_ADDITIONAL => 600;
use constant SEV_IMMEDIATE  => 900;

#
# Utility functions
#

sub if_defined ($$) {
    return $_[0] if defined $_[0];
    return $_[1] if defined $_[1];
    return '';
}

sub oneof ($@) {
    my ($to_find) = shift;
    my @res = grep {$to_find eq $_} @_;
    return @res > 0;
}

sub scriptname() {
  if_defined($SCRIPTNAME, $ENV{TBLOG_SCRIPTNAME});
}

#
#
#

sub tblog_session() {
    return $ENV{TBLOG_SESSION};
}


#
# Dummy dblog, does nothing in this module
# Once the real "libtblog.pm" is used than this will be replaced
# with the real function which logs to the database
#
sub dblog_dummy( $$@ ) {
  return 1;
}
*dblog = \&dblog_dummy;


#
# tblog(priority, mesg, ...)
# tblog(priority, {parm=>value,...}, mesg, ...)
#
#   The main log function.  Logs a message to the database and print
#   the message to STDERR with an approate prefix depending on the
#   severity of the error.  If more than one string is given for the
#   message than they will concatenated.  If the env. var. TBLOG_OFF
#   is set to a true value than nothing will be written to the
#   database, but the message will still be written to STDOUT.  
#   Useful parms: sublevel, cause, type
#
sub tblog( $@ ) {
    my ($priority) = shift;
    my $parms = {};
    $parms = shift if ref $_[0] eq 'HASH';
    my $mesg = join('',@_);

    if (exists $PRIORITY_MAP_TO_STR{$priority}) {
      # $priority already a valid priority number
    } elsif (exists $PRIORITY_MAP_TO_NUM{$priority}) {
      # $priority a priority string, convert to num
      $priority = $PRIORITY_MAP_TO_NUM{$priority}
    } else {
      croak "Unknown priority \"$priority\" in call to tblog";
    }

    my $res = dblog($priority, $parms, $mesg) unless $mesg =~ /^\s+$/;
    
    # XXX argh! Keep perl from complaining about unused SOUT var
    if (0) {
	print SOUT format_message(scriptname(), $priority, $mesg);
    }
    print SERR format_message(scriptname(), $priority, $mesg);

    return $res;
}


# Useful alias functions

sub tberror( @ ) {&tblog($ERR, @_)}
sub tberr( @ ) {&tblog($ERR, @_)}
sub tbwarn( @ ) {&tblog($WARNING, @_)}
sub tbwarning( @ ) {&tblog($WARNING, @_)}
sub tbnotice( @ ) {&tblog($NOTICE, @_)}
sub tbinfo( @ ) {&tblog($INFO, @_)}
sub tbdebug( @ ) {&tblog($DEBUG, @_)}

{'fraction_non_alphanumeric': 0.1274258903817445, 'fraction_numerical': 0.023885689912561313, 'mean_word_length': 3.1463306808134393, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5186892', 'n_tokens_mistral': 3726, 'n_tokens_neox': 3436, 'n_words': 1036}