Dicop::Request - an object containing one message/request/answer

	use Dicop::Request;
	use Dicop::Request::Pattern;

	my $pattern1 = Dicop::Request::Pattern->new( ... );
	my $pattern2 = Dicop::Request::Pattern->new( ... );

	$request = new Dicop::Request (
          id => 'req0001',
          data => 'req_0000=cmd_status;client_5',
	  patterns => [ $pattern1, $pattern2, ... ],
          );

	print $request->error();	# request was ok?

	$request->check ( $data, $validator);

	$request->request_id('req0003');	# set
	print $request->request_id();		# get and print

	$request->as_request_string();		

	req0002=cmd_status;type_main

	$request->pattern();

	$request->class();

	$request->type();

	$request->output();

	$request->title();

	$request->template_name();

	$request->auth();

	$equest->field('foo';'bar');	# set $request->{foo} to 'bar'

	$result->get_as_string('foo');

	$result->get_as_hex('foo');

	$object->change('foo','bar');   # will change $object->{foo} to bar
					# if foo can be changed

	my $carry = $request->carry();

	die ("Can not change field $field\n") if !$object->can_change($field);

	if ($request->is_form())
	  {
	  ...
	  }

	my ($sort_dir, $sort_by) = $request->sort_order();

#############################################################################
# Dicop::Request -- an object containing one message/request/answer
#
# (c) Bundesamt fuer Sicherheit in der Informationstechnik 1998-2006
#
# 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::Request;
use vars qw($VERSION $DEFAULT_PATTERNS $VALID);
$VERSION = 1.09;	# Current version of this package
require  5.008001;	# requires this Perl version or later

use Dicop::Item;
@ISA = qw/Dicop::Item/;
use strict;

use Dicop::Base qw/encode decode/;
use Dicop::Event qw/msg/;
use Dicop::Cache;

$DEFAULT_PATTERNS = undef;

BEGIN
  {
  $VALID = Dicop::Cache->new( timeout => 7200, limit => 2048 );
  }

#############################################################################
# private, initialize self 

sub _init
  {
  my $self = shift;
  my $args = shift;

  $self->{_error} = '';

  $self->{_id} = $args->{id} || '';
  $self->{_pattern} = undef;

  if ($self->{_id} eq '')
    {
    # Request needs valid id
    $self->error( msg(450, 'need non-empty ID') );
    return $self;
    }

  my $r = $args->{data} || '';

  if ($r eq '')
    {
    # Request needs valid data
    $self->error( msg(450, 'need non-empty data'), $r );
    return $self;
    }

  $self->error( msg(450, 'invalid ID') ) if $self->{_id} !~ /^req[0-9]{4}$/;

  $self->error( msg(450, 'need var name'), $r )
     if $r =~ /(^|;)_/; 			# 'val;_val' or '_val' are bad

  return $self if $self->{_error} ne '';	# on error, return

  # Check with our cache first. It caches valid request strings to shorten
  # the testing time. This assumes that the request-patterns don't change,
  # which is the case, since these are read only at startup. E.g. if a request
  # was valid, it will not be invalid now, and vice versa.
 
  my $is = $VALID->get($r);			# request is valid?
  $VALID->touch($r) if defined $is;		# if it was in cache, touch it
						# to make it newer

  if (defined $is && !ref $is && $is ne '')
    {
    $self->{_error} = $is;			# error
    return $self;				# was in cache as bad
    }
  
  # got a cached copy, so clone it into us, and return
  if (defined $is && ref($is))
    {
    # clone $is into $self
    foreach my $key (keys %$is)
      {
      next if $key eq '_id';			# skip this
      if (ref($is->{$key}) eq 'ARRAY')
        {
        $self->{$key} = [ @{$is->{$key}} ];
        }
      else
        {
        $self->{$key} = $is->{$key};
       }
      }
    return $self;
    }

  # not cached (uncertain), so check further

  my ($var,$p,@par);
  my @params = split /;+/,$r;		# ';+' => ignore multiple ';'
  foreach $p (@params)
    {
    if ($p !~ /_/)
      {
      # each part must be of the form 'var_val'
      $self->error( msg(450, 'invalid part'), $r );
      return $self;
      }
    ($var,@par) = split /_+/,$p;	# '_+' => ignore multiple '_'

    push @par, '' if @par == 0;		# var_; => (var => '')

    $var =~ tr/a-z0-9-//cd;
    # de-htmlize the parameters if the caller requested that
    if ($args->{encoded})
      {
      foreach my $k (@par)
	{
	$k = decode($k);		# $k is an alias to @par element
	}
      } 
    if ($var =~ /^[a-z-]+[0-9]*$/)
      {
      if (@par <= 1)
        {
        $self->{$var} = $par[0];
        }
      else
        {
        $self->{$var} = [ @par ];
        }
      }
    else 
      {
      # illegal var name
      $self->error( msg(450, "invalid var name '$var'"), $r );
      return $self;
      }
    } # end for each all params

  my $patterns = $args->{patterns} || $DEFAULT_PATTERNS;

  # no error so far, and not in cache, so do further detailed checks
  my ($match, $error);
  foreach my $pattern (@$patterns)
    {
    my ($cur_match, $cur_error) = $pattern->match($self);
  
    # if the pattern did not match, or it matched with an error, then
    # try further until we find a match without error
    if (defined $cur_match && (($cur_error || '') eq ''))
      {
      $match = $cur_match; $error = undef; last;
      }
    if (defined $cur_match && defined $cur_error)
      {
      # remember last case of match with error
      ($match, $error) = ($cur_match,$cur_error);
      }
    }

  if (defined $match && !defined $error)
    {
    $self->{_pattern} = $match;		# remember the pattern that defines us
    $VALID->put($r, $self);		# cache good results
    }
  else
    {
    #             error  or no  match at all,  put this error into the cache
    $self->error( $error  ||    msg(462)     , $r );
    }

  $self;
  }

sub error
  {
  my $self = shift;

  if (defined $_[0])
    {
    $self->{_error} = ($_[0] =~ /^req\d{4} / ? '' : "$self->{_id} ");
    $self->{_error} .= $_[0];
    $self->{_error} .= "\n" unless $self->{_error} =~ /\n\z/;
    $VALID->put($_[1], $self->{_error}) if defined $_[1];	# cache bad results
    }
  $self->{_error};
  }
 
sub as_request_string
  {
  # return yourself as a compact request string that can be sent to server
  my $self = shift;
  
  return undef if $self->{_error} ne '';
  my $s = "$self->{_id}=";
  foreach my $k (sort keys %$self)
    {
    next if $k =~ /^(_|dirty)/;	# skip internals
    if (ref ($self->{$k}) eq 'ARRAY')
      {
      if (@{$self->{$k}} > 0)
        {
        $s .= $k.'_';
        foreach my $v (@{$self->{$k}})
          {
	  $v = "$v";	# stringify objects		
	  $v = encode($v) if ($v !~ /^[a-zA-Z0-9]*\z/);
	  $s .= "$v,";
          } 
        chop $s;	# remove last ','
        $s .= ';';	# add ';' for next param	
        }
      }
    else
      {
      if (defined $self->{$k})
        {
	my $v = "$self->{$k}";
	$v = encode($v) if ($v !~ /^[a-zA-Z0-9]*\z/);
        $s .= $k.'_'."$v;";
        }
      }
    }
  chop $s;	# remove last ';'
  $s;
  }

sub copy
  {
  # create an exact copy of yourself
  my $self = shift;

  my $copy = {};
  bless $copy, ref($self);

  foreach my $key (keys %$self)
    {
    if (ref($self->{$key}) eq 'ARRAY')
      {
      $copy->{$key} = [ @{$self->{$key}} ];
      }
    else
      {
      $copy->{$key} = $self->{$key};
      }
    }
  $copy;
  }

sub fields
  { 
  my $self = shift;

  my @keys = ();
  foreach my $key (sort keys %$self)
    { 
    next if $key =~ /^(_|dirty$)/;
    push @keys, $key;
    }
  @keys;
  }

sub field
  { 
  # set a field of the object to another value
  my ($self,$field,$value) = @_;
  
  if (defined $value)
    {
    $self->{$field} = $value;
    $self->check();
    }
  $self->{$field}; 
  }

sub request_id
  {
  # change the request id, and return it
  my $self = shift;

  my $id = shift;
  if ((defined $id) && ($id =~ /^req[0-9]{4}$/))
    {
    $self->{_id} = $id;
    }
  $self->{_id};
  }

#############################################################################
# relay title, output, type etc from the matching request pattern

sub pattern
  {
  $_[0]->{_pattern};
  }

sub type
  {
  my $self = shift;

  return undef if !defined $self->{_pattern};
  $self->{_pattern}->type();
  }

sub class
  {
  my $self = shift;

  return 'invalid' if !defined $self->{_pattern} || $self->{_error};
  $self->{_pattern}->class();
  }

sub output
  {
  my $self = shift;

  return undef if !defined $self->{_pattern};
  $self->{_pattern}->output($self);
  }

sub title
  {
  my $self = shift;

  if ((!defined $self->{_pattern}) || $self->{_error})
    {
    warn ("Access to title for illegal request: " . $self->{_error});
    return undef;
    }
  $self->{_pattern}->title($self);
  }

sub template_name
  {
  my $self = shift;

  return undef if !defined $self->{_pattern};
  $self->{_pattern}->template_name($self);
  }

sub auth
  {
  my $self = shift;

  return 1 if !defined $self->{_pattern} || $self->{_error};
  $self->{_pattern}->auth();
  }

sub sort_order
  {
  my $self = shift;
  
  my @s = ('up','id');

  # pattern defines the default
  if ($self->{_pattern})
    {
    @s = $self->{_pattern}->sort_order();
    }
     
  # if sort and sortby are defined in the request, they have priority
  $s[0] = $self->{sort} if exists $self->{sort} && $self->{sort} =~ /^(up|down|upstr|downstr)\z/;
  $s[1] = $self->{sortby} if exists $self->{sortby} && $self->{sortby} =~ /^[a-z]+\z/;

  # return sort (direction) and sortby (field to sort on)
  @s;
  }

sub carry
  {
  my $self = shift;

  return $self->{_pattern}->carry() if $self->{_pattern};
  ();
  }

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

sub is_auth
  {
  my $self = shift;

  (($self->{_error} eq '') && $self->{_pattern}->{type} eq 'auth') <=> 0;
  }

sub is_info
  {
  my $self = shift;

  (($self->{_error} eq '') && $self->{_pattern}->{type} eq 'info') <=> 0;
  }

sub is_request
  {
  my $self = shift;

  (($self->{_error} eq '') && $self->{_pattern}->{type} eq 'request') <=> 0;
  }

sub is_form
  {
  my $self = shift;

  (($self->{_error} eq '') && $self->{_pattern}->{type} eq 'status') <=> 0;
  }

1;
__END__

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