Dicop::Base - basics for a Dicop HTTP server/client

	use Dicop::Base;

	Dicop::Base::cfg_default ( $self, $hash );

	Dicop::Base::cfg_level ( $cfg, qw/log_level debug_level .../ );

	my $decoded = decode($encoded);

	my $time = Dicop::time();

	write_file( $path_to_file, \$contents);

	my @files = Dicop::Base::read_dir($directory);

	<TABLE>

	<TR>
        <TD>##field##<TD>##description##
        </TR>

        </TABLE>

	<TABLE>

	##table##

        </TABLE>

	<TR>
        <TD>##field##<TD>##description##
        </TR>

	$random_bytes = Dicop::random(128);	# get 128 random bytes

	$cpuinfo = Dicop::Base::cpuinfo($self, $no_warn);

#############################################################################
# Dicop::Base -- base for a Dicop HTTP server
#
# (c) Bundesamt fuer Sicherheit in der Informationstechnik 1998-2008
#
# DiCoP is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License version 2 as published by the Free
# Software Foundation.
#
# See the file LICENSE or L<http://www.bsi.de/> for more information.
#############################################################################

package Dicop::Base;
use vars qw($VERSION $BUILD @ISA @EXPORT_OK);
use strict;

$VERSION = '3.05';	# Current version of this package
$BUILD = 1;		# Current build of this package
require 5.008001;	# requires this Perl version or later

use Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
		parseFormArgs
                read_list write_list read_file write_file read_dir
		a2h h2a replace_templates
		time cache_time ago simple_ago
		status status_code
		random
		encode decode
		cfg_default cfg_level
		cpuinfo
                );
use Dicop::Event qw/crumble msg/;
use File::Spec;

sub read_list
  {
  my $file = shift;
  
  my $list = []; my $line;
  open my $DICOP_HANDLE, "<", $file or return crumble ("Can't read $file: $!");
  while (my $line = <$DICOP_HANDLE>)
    {
    next if $line =~ /^\s*#/;	# skip comments
    next if $line =~ /^\s*$/;	# skip empty lines
    push @$list, $line;
    }
  close $DICOP_HANDLE or return crumble("Can't close $file: $!");
  $list;
  }

sub read_file
  {
  my $file = shift;
  
  my $txt = "";
  open (my $DICOP_HANDLE, "<", $file) or return crumble ("Can't read '$file': $!");
  local $/ = "";	# slurp mode
  while (my $line = <$DICOP_HANDLE>)
    {
    $txt .= $line;
    }
  close $DICOP_HANDLE or return crumble("Can't close '$file': $!");
  \$txt;
  }

sub read_dir
  {
  my $dir = shift;
  
  opendir (my $DICOP_HANDLE, "$dir") or return crumble ("Can't read dir '$dir': $!");
  my @files = readdir ($DICOP_HANDLE);
  closedir $DICOP_HANDLE or return crumble("Can't close dir '$dir': $!");
  \@files;
  }

sub write_file
  {
  my $file = shift;

  return crumble ("Filename is undef") if !defined $file;
  return crumble ("Filename is empty") if $file eq '';
  return crumble ("Filename contains '..'") if $file =~ /\.\./;

  my $txt = shift || return crumble ("Can't write empty text to '$file'!");

  # generate the dir if it doesn't already exist
  my ($vol,$dir,$f) = File::Spec->splitpath($file);
  my @dirs = File::Spec->splitdir($dir);

  my $combined = '.';
  foreach my $d (@dirs)
    {
    $combined = File::Spec->catdir($combined,$d);
    if (!-d $combined)
      {
      print STDERR "Creating directory $combined\n";
      return crumble ("Couldn't create dir $combined: $!") unless 
        mkdir $combined, 0750;
      }
    }
  
  open my $DICOP_HANDLE, ">", $file or return crumble ("Can't write '$file': $!");
  binmode $DICOP_HANDLE;
  print $DICOP_HANDLE $$txt;
  close $DICOP_HANDLE or return crumble("Can't close '$file': $!");

  return;
  }

sub read_table_template
  {
  # read a file containing a table template, which contains a table and
  # one row of the table (or anything else) between <!-- start --> and
  # <!-- end -->. Returns reference to empty table with ##table## inserted
  # at the place of the template, and the template for one row.

  my $file = shift;

  my $txt = read_file($file);
  die ($txt||"Can't read file $file: $!") unless ref $txt;

  $$txt =~ s/<!-- start -->\n?((.|\n)+)\n?<!-- end -->/##table##/i;
  my $tpl = ($1 || '') . "\n";
  ($txt,$tpl);
  }

# convert "ab" to "6566"
sub a2h
  {
  use bytes;
  my ($a) = shift;
  return '' if !defined $a || $a eq '';		# not defined or empty?
  unpack ( "H" . (length($a) << 1), $a);
  }

# convert "6566" to "ab"
sub h2a
  {
  use bytes;
  my ($h) = shift;
  return '' if !defined $h || $h eq '';		# not defined or empty?
  pack ("H" . length($h), $h);
  }

sub simple_ago
  {
  # from a given time difference, create a string reporting it in
  # seconds/mins/hours/days as appropriate
 
  my ($t) = @_;
  $t = 0 if !defined $t or (!ref $t && $t eq '');
  $t = int($t);						# make int
  $t = $t->numify() if ref($t);				# to scalar
  my $s = " ($t"."s)";
  if ($t < 120)
    {
    my $h = "$t second"; $h .= 's' if $t != 1; $t = $h;
    $s = "";
    }
  elsif ($t < 2*3600)
    {
    $t = int($t/6)/10; $t = "$t minutes";
    }
  elsif ($t < 2*3600*24)
    {
    $t = int($t/(360))/10; $t = "$t hours";
    }
  else
    {
    $t = int($t/(360*24))/10; $t = "$t days";
    }
  "$t$s";
  }

sub ago
  {
  # from a given amount of time in seconds, create a string reporting it in
  # seconds/mins/hours/days as appropriate

  my ($t) = @_; 
  $t = 0 if !defined $t or (!ref $t && $t eq '');
  $t = int($t);						# make int
  $t = $t->numify() if ref($t);				# to scalar
  my $s = $t;
  my $seconds = $t % 60; 
  $t = int($t / 60); my $minutes = $t % 60;
  $t = int($t / 60); my $hours = $t % 24;
  $t = int($t / 24); my $days = $t;
  my $sec = 'second'; $sec .= 's' if $seconds != 1; 
  my $hr = 'hour'; $hr .= 's' if $hours > 1; 
  my $min = 'minute'; $min .= 's' if $minutes > 1; 
  my $d = 'day'; $d .= 's' if $days > 1; 
  return "$s $sec" if ($minutes+$days+$hours == 0);
  my @items = ();
  push @items, "$days $d" if $days > 0;
  push @items, "$hours $hr" if $hours > 0;
#   if $hours > 0 && ($days > 0 || $minutes > 0 || $seconds > 0);
  push @items, "$minutes $min" if $minutes > 0;
#   if $minutes > 0 && ($seconds > 0 || $hours > 0 || $days > 0);
  push @items, "$seconds $sec" if $seconds > 0;
#   if $seconds > 0 && ($minutes > 0 || $hours > 0 || $days > 0);
  # join with ',' , but last with 'and'
  my $es = join (', ',@items);
  $es =~ s/(.*),/$1 and/;			# last , => and
  $es." ($s".'s)';
  }

sub replace_templates
  {
  # take a ref to a text template and a hash containing keys, and replace
  # occurances of ##key## in the text with the value
  my ($txt,$hash) = @_;

  if (!ref ($txt))
    {
    require Carp;
    Carp::cluck ("Need ref to scalar, got " . ref($txt));
    }
  # replace ##key## with the value of the key
  my $val;
  if (ref($hash) eq 'HASH' || !$hash->can('fields'))
    {
    foreach my $key (sort keys %$hash)
      {
      $val = $hash->{$key};
      $val = "undefined value for key $key" if !defined $val;
      $$txt =~ s/##$key##/$val/g;
      }
    }
  else
    {
    # if we got an object, ask it for its fields that we must use as keys
    foreach my $key ($hash->fields())
      {
      $val = $hash->get_as_string($key);
      $val = "undefined value for key $key" if !defined $val;
      $$txt =~ s/##$key##/$val/g;
      }
    }

  $txt;
  }

########################################################
# fetch client arguments and return them

sub parseFormArgs
  {
  # inspired by Michael Budash
  my ($name,$value,%form,@pairs);

  my $incoming;
  if (($ENV{'REQUEST_METHOD'}||"") eq "POST")
    {
    read(STDIN, $incoming, $ENV{'CONTENT_LENGTH'} || 0);
    }
  else
    {
    $incoming = $ENV{'QUERY_STRING'} || $_[0] || '';
    }
  @pairs = split(/&/, $incoming);

  # protect against "Algorithmn Complexity Attack against Perl hash function"
  if (scalar @pairs > 1024)
    {
    die ("Error: More than 1024 arguments.");
    return \%form;
    }

  use bytes;
  foreach (@pairs) 
    {
    ($name, $value) = split(/=/, $_);

    # skip blank names (but keep blank values)
    next if !defined $name || $name eq '';

    # Un-Webify plus signs and %-encoding
    $name  =~ tr/+/ /;
    $value = '' unless defined $value;
    $value =~ tr/+/ /;
    $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/ge;
    $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/ge;

    $form{$name} = $value;
    }
  \%form;
  }

sub encode
  {
  # encode a string that contains characters other than A-Z,a-z,0-9 etc
  use bytes;
  my $var = "$_[0]";

  # encode % as %25 first
  $var =~ s/%/sprintf ("%%%02x",ord("%"));/eg;
  # encode other critical characters
  $var =~ s/([^A-Za-z0-9\.\/\\,%:\s-]|\n|\r)/sprintf("%%%02x",ord($1));/eg;
  # encode ' ' as '+'
  $var =~ tr/ /+/;
  $var;
  }

sub decode
  {
  # decode a string containing + (space) and %XX (hex)
  use bytes;
  my $var = shift; $var = '' unless defined $var;

  $var =~ tr/+/ /;
  $var =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/ge;
  $var;
  }

sub cfg_level
  {
  my $cfg = shift;
  
  foreach my $k (@_)
    {
    my $l = [ split (/\s*[\+]\s*/, ($cfg->{$k}||0)) ]; my $sum = 0;
    foreach (@$l)
      {
      $sum += $_;
      }
    $cfg->{$k} = $sum;
    }
  }

sub cfg_default
  {
  # given a set of keys and their values (a list or hash reference),
  # sets these values as default in the internal cfg object, unless
  # the key is already defined there.
  my $self = shift;

  my $args;
  ref $_[0] ? $args = shift : $args = { @_ };
  foreach (keys %$args)
    {
    $self->{config}->{$_} = $args->{$_} if !defined $self->{config}->{$_};
    }
  $self;
  }

{
  # protected vars
  my $rand_buffer = '';
  my $time = CORE::time;

  sub random
    {
    # return $bits random bits (rounded down to the nearest multiple of 8)
    # Uses /dev/urandom, or if this is not available, chains calls to rand()
    # (The latter is not as secure, but the way it was before we used
    # /dev/urandom)
    my $chars = int((shift || 128) / 8);

    if (length($rand_buffer) <= $chars)
      {
      # rand_buffer not long enough, refill it
      my $dev;
      my $rc = open ($dev, '/dev/urandom');
      if ($rc)
        {
        while (length($rand_buffer) <= $chars)
	  {
	  read ($dev,$rand_buffer, 4096);
	  }
        close $dev;
        }
      else
        {
        while (length($rand_buffer) < 4096)
          {
          $rand_buffer .= int(rand(65537));
          }
        }
      }
    my $buffer = substr($rand_buffer,0,$chars);	# get some bytes
    substr($rand_buffer,0,$chars) = '';		# and remove from rand_buffer
    $buffer;
    }

  sub time
    {
    $time;
    }

  sub cache_time
    {
    $time = CORE::time;
    }
}

sub cpuinfo
  {
  my ($self,$no_warn) = @_;

  # try to get info on cpu
  my $cpuinfo = "";
  if ($^O !~ /win32/i)
    {
    eval { require Linux::Cpuinfo; };
    if (defined $Linux::Cpuinfo::VERSION)
      {
      my $cpu = Linux::Cpuinfo->new( { NoFatal => 1 } );
      if (ref($cpu))
        {
        $cpuinfo  = $cpu->model_name() || 'unknown';
        $cpuinfo =~ s/[_=;,]/-/g;			# no underscores etc
        $cpuinfo =~ s/[\[\(](tm|r)[\)\]]//gi;		# don't need this
        $cpuinfo =~ s/\s+/ /g;				# '  ' => ' '
        $cpuinfo .= ",".int($cpu->cpu_mhz()||0);	# only in integer Hz
	$cpuinfo = ";cpuinfo_$cpuinfo";
        }
      }
    else
      {
      # warn about missing Cpuinfo
      if (!$no_warn)
        {
        no strict 'refs';
        &{ref($self).'::output'} ($self, msg(606)."\n\n");
        sleep(5);
        }
      }
    }
  else
    {
    require Win32;
    Win32->import();
    $cpuinfo = Win32::GetChipName();
    $cpuinfo =~ s/[_=;,]/-/g;			# no underscores etc
    $cpuinfo =~ s/[\[\(](tm|r)[\)\]]//gi;	# don't need this
    $cpuinfo =~ s/\s+/ /g;			# '  ' => ' '
    $cpuinfo = ";cpuinfo_$cpuinfo,0";		# unknown Mhz
    }
  $cpuinfo;
  }

1;

__END__

#############################################################################