<commit_before>package Qpsmtpd;
use strict;
use vars qw($VERSION $LogLevel);

use Sys::Hostname;
use Qpsmtpd::Constants;

$VERSION = "0.28";
sub TRACE_LEVEL { $LogLevel }

sub version { $VERSION };

sub init_logger {
    my $self = shift;
    # Get the loglevel - we localise loglevel to zero while we do this
    my $loglevel = do {
        local $LogLevel = 0;
        $self->config("loglevel");
    };
    if (defined($loglevel) and $loglevel =~ /^\d+$/) {
        $LogLevel = $loglevel;
    }
    else {
        $LogLevel = LOGWARN; # Default if no loglevel file found.
    }
    return $LogLevel;
}

sub log {
  my ($self, $trace, @log) = @_;
  my $level = TRACE_LEVEL();
  $level = $self->init_logger unless defined $level;
  warn join(" ", $$, @log), "\n"
    if $trace <= $level;
}


#
# method to get the configuration.  It just calls get_qmail_config by
# default, but it could be overwritten to look configuration up in a
# database or whatever.
#
sub config {
  my ($self, $c, $type) = @_;

  #warn "SELF->config($c) ", ref $self;

  my %defaults = (
		  me      => hostname,
		  timeout => 1200,
		  );

  my ($rc, @config) = $self->run_hooks("config", $c);
  @config = () unless $rc == OK;

  if (wantarray) {
      @config = $self->get_qmail_config($c, $type) unless @config;
      @config = $defaults{$c} if (!@config and $defaults{$c});
      return @config;
  } 
  else {
      return ($config[0] || $self->get_qmail_config($c, $type) || $defaults{$c});
   }
}


sub get_qmail_config {
  my ($self, $config, $type) = @_;
  $self->log(LOGDEBUG, "trying to get config for $config");
  if ($self->{_config_cache}->{$config}) {
    return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0];
  }
  my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
  my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
  $configdir = "$name/config" if (-e "$name/config/$config");

  my $configfile = "$configdir/$config";

  if ($type and $type eq "map")  {
    return +{} unless -e $configfile . ".cdb";
    eval { require CDB_File };

    if ($@) {
      $self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@");
      return +{};
    }

    my %h;
    unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
      $self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
      return +{};
    }
    #warn Data::Dumper->Dump([\%h], [qw(h)]);
    # should we cache this?
    return \%h;
  }

  return $self->_config_from_file($configfile, $config);
}

sub _config_from_file {
  my ($self, $configfile, $config) = @_;
  return unless -e $configfile;
  open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return;
  my @config = <CF>;
  chomp @config;
  @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config;
  close CF;
  #$self->log(10, "returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
  $self->{_config_cache}->{$config} = \@config;
  return wantarray ? @config : $config[0];
}

sub _compile {
    my ($plugin, $package, $file) = @_;
    
    my $sub;
    open F, $file or die "could not open $file: $!";
    { 
      local $/ = undef;
      $sub = <F>;
    }
    close F;

    my $line = "\n#line 1 $file\n";

    my $eval = join(
		    "\n",
		    "package $package;",
		    'use Qpsmtpd::Constants;',
		    "require Qpsmtpd::Plugin;",
		    'use vars qw(@ISA);',
		    '@ISA = qw(Qpsmtpd::Plugin);',
		    "sub plugin_name { qq[$plugin] }",
		    $line,
		    $sub,
		    "\n", # last line comment without newline?
		   );

    #warn "eval: $eval";

    $eval =~ m/(.*)/s;
    $eval = $1;

    eval $eval;
    die "eval $@" if $@;
}

sub load_plugins {
  my $self = shift;
  
  $self->{hooks} ||= {};
  
  my @plugins = $self->config('plugins');

  my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
  my $dir = "$name/plugins";
  $self->log(LOGNOTICE, "loading plugins from $dir");

  $self->_load_plugins($dir, @plugins);
}

sub _load_plugins {
  my $self = shift;
  my ($dir, @plugins) = @_;
  
  for my $plugin (@plugins) {
    $self->log(LOGINFO, "Loading $plugin");
    ($plugin, my @args) = split /\s+/, $plugin;
    
    if (lc($plugin) eq '$include') {
      my $inc = shift @args;
      my $config_dir = ($ENV{QMAIL} || '/var/qmail') . '/control';
      my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
      $config_dir = "$name/config" if (-e "$name/config/$inc");
      if (-d "$config_dir/$inc") {
        $self->log(LOGDEBUG, "Loading include dir: $config_dir/$inc");
        opendir(DIR, "$config_dir/$inc") || die "opendir($config_dir/$inc): $!";
        my @plugconf = sort grep { -f $_ } map { "$config_dir/$inc/$_" } grep { !/^\./ } readdir(DIR);
        closedir(DIR);
        foreach my $f (@plugconf) {
            $self->_load_plugins($dir, $self->_config_from_file($f, "plugins"));
        }
      }
      elsif (-f "$config_dir/$inc") {
        $self->log(LOGDEBUG, "Loading include file: $config_dir/$inc");
        $self->_load_plugins($dir, $self->_config_from_file("$config_dir/$inc", "plugins"));
      }
      else {
        $self->log(LOGCRIT, "CRITICAL PLUGIN CONFIG ERROR: Include $config_dir/$inc not found");
      }
      next;
    }
    
    my $plugin_name = $plugin;

    # Escape everything into valid perl identifiers
    $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;

    # second pass cares for slashes and words starting with a digit
    $plugin_name =~ s{
		      (/+)       # directory
		      (\d?)      # package's first character
		     }[
		       "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
		      ]egx;

    my $package = "Qpsmtpd::Plugin::$plugin_name";

    # don't reload plugins if they are already loaded
    _compile($plugin_name, $package, "$dir/$plugin") unless
        defined &{"${package}::register"};
    
    my $plug = $package->new();
    $plug->_register($self, @args);<commit_msg>Allow for multiple instances of a single plugin by using plugin:0 notation<commit_after>package Qpsmtpd;
use strict;
use vars qw($VERSION $LogLevel);

use Sys::Hostname;
use Qpsmtpd::Constants;

$VERSION = "0.28";
sub TRACE_LEVEL { $LogLevel }

sub version { $VERSION };

sub init_logger {
    my $self = shift;
    # Get the loglevel - we localise loglevel to zero while we do this
    my $loglevel = do {
        local $LogLevel = 0;
        $self->config("loglevel");
    };
    if (defined($loglevel) and $loglevel =~ /^\d+$/) {
        $LogLevel = $loglevel;
    }
    else {
        $LogLevel = LOGWARN; # Default if no loglevel file found.
    }
    return $LogLevel;
}

sub log {
  my ($self, $trace, @log) = @_;
  my $level = TRACE_LEVEL();
  $level = $self->init_logger unless defined $level;
  warn join(" ", $$, @log), "\n"
    if $trace <= $level;
}


#
# method to get the configuration.  It just calls get_qmail_config by
# default, but it could be overwritten to look configuration up in a
# database or whatever.
#
sub config {
  my ($self, $c, $type) = @_;

  #warn "SELF->config($c) ", ref $self;

  my %defaults = (
		  me      => hostname,
		  timeout => 1200,
		  );

  my ($rc, @config) = $self->run_hooks("config", $c);
  @config = () unless $rc == OK;

  if (wantarray) {
      @config = $self->get_qmail_config($c, $type) unless @config;
      @config = $defaults{$c} if (!@config and $defaults{$c});
      return @config;
  } 
  else {
      return ($config[0] || $self->get_qmail_config($c, $type) || $defaults{$c});
   }
}


sub get_qmail_config {
  my ($self, $config, $type) = @_;
  $self->log(LOGDEBUG, "trying to get config for $config");
  if ($self->{_config_cache}->{$config}) {
    return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0];
  }
  my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
  my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
  $configdir = "$name/config" if (-e "$name/config/$config");

  my $configfile = "$configdir/$config";

  if ($type and $type eq "map")  {
    return +{} unless -e $configfile . ".cdb";
    eval { require CDB_File };

    if ($@) {
      $self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@");
      return +{};
    }

    my %h;
    unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
      $self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
      return +{};
    }
    #warn Data::Dumper->Dump([\%h], [qw(h)]);
    # should we cache this?
    return \%h;
  }

  return $self->_config_from_file($configfile, $config);
}

sub _config_from_file {
  my ($self, $configfile, $config) = @_;
  return unless -e $configfile;
  open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return;
  my @config = <CF>;
  chomp @config;
  @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config;
  close CF;
  #$self->log(10, "returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
  $self->{_config_cache}->{$config} = \@config;
  return wantarray ? @config : $config[0];
}

sub _compile {
    my ($plugin, $package, $file) = @_;
    
    my $sub;
    open F, $file or die "could not open $file: $!";
    { 
      local $/ = undef;
      $sub = <F>;
    }
    close F;

    my $line = "\n#line 1 $file\n";

    my $eval = join(
		    "\n",
		    "package $package;",
		    'use Qpsmtpd::Constants;',
		    "require Qpsmtpd::Plugin;",
		    'use vars qw(@ISA);',
		    '@ISA = qw(Qpsmtpd::Plugin);',
		    "sub plugin_name { qq[$plugin] }",
		    $line,
		    $sub,
		    "\n", # last line comment without newline?
		   );

    #warn "eval: $eval";

    $eval =~ m/(.*)/s;
    $eval = $1;

    eval $eval;
    die "eval $@" if $@;
}

sub load_plugins {
  my $self = shift;
  
  $self->{hooks} ||= {};
  
  my @plugins = $self->config('plugins');

  my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
  my $dir = "$name/plugins";
  $self->log(LOGNOTICE, "loading plugins from $dir");

  $self->_load_plugins($dir, @plugins);
}

sub _load_plugins {
  my $self = shift;
  my ($dir, @plugins) = @_;
  
  for my $plugin (@plugins) {
    $self->log(LOGINFO, "Loading $plugin");
    ($plugin, my @args) = split /\s+/, $plugin;
    
    if (lc($plugin) eq '$include') {
      my $inc = shift @args;
      my $config_dir = ($ENV{QMAIL} || '/var/qmail') . '/control';
      my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
      $config_dir = "$name/config" if (-e "$name/config/$inc");
      if (-d "$config_dir/$inc") {
        $self->log(LOGDEBUG, "Loading include dir: $config_dir/$inc");
        opendir(DIR, "$config_dir/$inc") || die "opendir($config_dir/$inc): $!";
        my @plugconf = sort grep { -f $_ } map { "$config_dir/$inc/$_" } grep { !/^\./ } readdir(DIR);
        closedir(DIR);
        foreach my $f (@plugconf) {
            $self->_load_plugins($dir, $self->_config_from_file($f, "plugins"));
        }
      }
      elsif (-f "$config_dir/$inc") {
        $self->log(LOGDEBUG, "Loading include file: $config_dir/$inc");
        $self->_load_plugins($dir, $self->_config_from_file("$config_dir/$inc", "plugins"));
      }
      else {
        $self->log(LOGCRIT, "CRITICAL PLUGIN CONFIG ERROR: Include $config_dir/$inc not found");
      }
      next;
    }

    my $plugin_name = $plugin;
    $plugin =~ s/:\d+$//;       # after this point, only used for filename

    # Escape everything into valid perl identifiers
    $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;

    # second pass cares for slashes and words starting with a digit
    $plugin_name =~ s{
		      (/+)       # directory
		      (\d?)      # package's first character
		     }[
		       "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
		      ]egx;

    my $package = "Qpsmtpd::Plugin::$plugin_name";

    # don't reload plugins if they are already loaded
    _compile($plugin_name, $package, "$dir/$plugin") unless
        defined &{"${package}::register"};
    
    my $plug = $package->new();
    $plug->_register($self, @args);
{'fraction_non_alphanumeric': 0.2032994500916514, 'fraction_numerical': 0.00424929178470255, 'mean_word_length': 2.770970782280867, 'pattern_counts': {'":': 2, '<': 11, '<?xml version=': 0, '>': 83, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5061354', 'n_tokens_mistral': 4505, 'n_tokens_neox': 4310, 'n_words': 1081}