view release on metacpan or  search on metacpan

lib/XAO/DO/Web/Condition.pm  view on Meta::CPAN

Parent object argument.

=item siteconf

Site configuration parameter.

=item cookie

Cookie value (including cookie values set earlier in the same render).

=item secure

True if the the current page is being transferred over a secure
connection (the url prefix is https://). Value is not used.

=back

All values are treated as booleans only, no comparision is implemented
yet.

=cut

###############################################################################
package XAO::DO::Web::Condition;
use strict;
use XAO::Utils;
use XAO::Objects;
use base XAO::Objects->load(objname => 'Web::Page');

our $VERSION='2.009';

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

sub check_target ($$$) {
    my ($pvalue,$target,$targop)=@_;

    if(defined $target && defined $pvalue) {
        if($targop eq '=')      { return ($pvalue eq $target); }
        elsif($targop eq '!')   { return ($pvalue ne $target); }
        elsif($targop eq '<')   { return ($pvalue < $target); }
        elsif($targop eq '>')   { return ($pvalue > $target); }
    }
    else {
        return $pvalue;
    }
}

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

sub display ($;%)
{ my $self=shift;
  my %args=%{get_args(\@_) || {}};
  my $config=$self->siteconfig;

  ##
  # First going through the list of conditions and checking them.
  #
  my $name;
  foreach my $a (sort keys %args)
   { next unless $a =~ /^(\w+)\.(number|value|arg|cgiparam|length|siteconf|siteconfig|cookie|secure|clipboard)$/;
     if($2 eq 'cgiparam')
      { my $param=$args{$a};
        my $cname=$1;
        my ($target,$targop);
        if($param =~ /^\s*(.*?)\s*(=|>|<|\!)\s*(.*?)\s*$/)
         { $param=$1;
           $targop=$2;
           $target=$3;
         }
        my $pvalue=$config->cgi->param($param);
        if(check_target($pvalue,$target,$targop))
         { $name=$cname;
           last;
         }
      }
     elsif($2 eq 'length')
      { my $param=$args{$a};
        if(defined($param) && length($param))
         { $name=$1;
           last;
         }
      }
     elsif($2 eq 'arg')
      { my $param=$args{$a};
        my $cname=$1;
        my ($target,$targop);
        if($param =~ /^\s*(.*?)\s*(=|>|<|\!)\s*(.*?)\s*$/)
         { $param=$1;
           $targop=$2;
           $target=$3;
         }
        if($self->{'parent'})
         { my $pvalue=$self->{'parent'}->{'args'}->{$param};
           my $matches;
           if(check_target($pvalue,$target,$targop))
            { $name=$cname;
              last;
            }
         }
      }
     elsif($2 eq 'siteconf' || $2 eq 'siteconfig')
      { my $param=$args{$a};
        my $cname=$1;
        my ($target,$targop);
        if($param =~ /^\s*(.*?)\s*(=|>|<|\!)\s*(.*?)\s*$/)
         { $param=$1;
           $targop=$2;
           $target=$3;
         }
        my $pvalue=$config->get($param);
        if(check_target($pvalue,$target,$targop))
         { $name=$cname;
           last;
         }
      }
     elsif($2 eq 'cookie')
      { my $param=$args{$a};
        my $cname=$1;
        my ($target,$targop);
        if($param =~ /^\s*(.*?)\s*(=|>|<|\!)\s*(.*?)\s*$/)
         { $param=$1;
           $targop=$2;
           $target=$3;
         }
        my $pvalue=$config->get_cookie($param);
        if(check_target($pvalue,$target,$targop))
         { $name=$cname;
           last;
         }
      }
     elsif($2 eq 'number')
      { if(($args{$a} || 0)+0)
         { $name=$1;
           last;
         }
      }
     elsif($2 eq 'secure')
      { if($self->is_secure)
         { $name=$1;
           last;
         }
      }
     elsif($2 eq 'clipboard')
      { my $param=$args{$a};
        my $cname=$1;
        my ($target,$targop);
        if($param =~ /^\s*(.*?)\s*(=|>|<|\!)\s*(.*?)\s*$/)
         { $param=$1;
           $targop=$2;
           $target=$3;
         }
        my $pvalue=$self->clipboard->get($param);
        if(check_target($pvalue,$target,$targop))
         { $name=$cname;
           last;
         }
      }
     elsif($args{$a})	# value
      { $name=$1;
        last;
      }
   }
    $name="default" unless defined $name;

    # Building object arguments now.
    #
    my %objargs;
    foreach my $a (keys %args) {
        if($self->{'parent'} && $self->{'parent'}->{'args'}
                             && $a =~ /^$name\.pass\.(.*)$/) {
            $objargs{$1}=$self->{'parent'}->{'args'}->{$1};
        }
        elsif($a eq "$name.pass") {
            # See below
        }
        elsif($a =~ /^$name\.(\w.*)$/) {
            $objargs{$1}=$args{$a};
        }
    }
    return unless %objargs;

    # Now getting the object
    #
    my $obj=$self->object(objname => $objargs{'objname'} || "Page");
    delete $objargs{'objname'};

    # If we were asked to pass complete set of arguments then merging.
    #
    if($args{"$name.pass"}) {
        $obj->display($self->pass_args($args{"$name.pass"},\%objargs));
    }
    else {
        $obj->display(\%objargs);
    }
}

###############################################################################
1;
__END__

=head1 METHODS

No publicly available methods except overriden display().

=head1 EXPORTS

Nothing.

=head1 AUTHOR

Copyright (c) 2005 Andrew Maltsev