[poe-commits] extras/whip/Whip State.pm,NONE,1.1 Tag.pm,NONE,1.1

[<rc...@us...>]

Update of /cvsroot/poe/extras/whip/Whip
In directory usw-pr-cvs1:/tmp/cvs-serv5830/Whip

Added Files:
	State.pm Tag.pm 
Log Message:
Initial add.  The design is still in flux, but it's now stable enough
to commit.


--- NEW FILE: State.pm ---
# $Id: State.pm,v 1.1 2002/11/04 03:40:58 rcaputo Exp $

# Wrapper for a whip request/response transaction.

package Whip::State;

use warnings;
use strict;
use Carp qw(croak);

sub STATE_PARENT () { 0 }
sub STATE_VALUES () { 1 }

### Create an initial state.

sub new {
  my ($class, $parent_state) = @_;
  my $self = bless
    [ $parent_state,  # STATE_PARENT
      {},             # STATE_VALUES
    ], $class;
  return $self;
}

### Return the values hash from this state.

sub get_values {
  my $self = shift;
  return %{$self->[STATE_VALUES]};
}

### Absorb another state into this one.

sub absorb {
  my ($self, $other_state) = @_;

  my %other_state = $other_state->get_values();
  while (my ($attribute, $value) = each %other_state) {
    $self->store($attribute, $value);
  }
}

### Store a value into a state.

sub store {
  my $self = shift;

  while (@_ >= 2) {
    my $attribute = lc(shift);
    my $value = shift;

    my @value;
    if (ref($value) eq "ARRAY") {
      @value = @$value;
    }
    else {
      @value = $value;
    }

    unless (exists $self->[STATE_VALUES]->{$attribute}) {
      $self->[STATE_VALUES]->{$attribute} = [ ];
    }

    push @{$self->[STATE_VALUES]->{$attribute}}, @value;
  }

  croak "Whip::State->store() called with an odd number of parameters" if @_;
}

### Remove a value and return it.

sub delete {
  my ($self, $attribute) = @_;
  my $value = delete $self->[STATE_VALUES]->{lc($attribute)};
  return unless $value;

  if (wantarray) {
    return @$value;
  }
  return $value->[0];
}

### Fetch a scalar, possibly inheriting it from elsewhere.

sub fetch {
  my ($self, $attribute, @default) = @_;
  $attribute = lc($attribute);

  if (exists $self->[STATE_VALUES]->{$attribute}) {
    if (wantarray) {
      return @{$self->[STATE_VALUES]->{$attribute}};
    }
    return $self->[STATE_VALUES]->{$attribute}->[0];
  }

  if (defined $self->[STATE_PARENT]) {
    if (wantarray) {
      my @return = $self->[STATE_PARENT]->fetch($attribute);
      return @return;
    }
    my $return = $self->[STATE_PARENT]->fetch($attribute);
    return $return;
  }

  return @default;
}

### Rename _value to something else.

sub rename_value {
  my ($self, $new_name) = @_;
  $new_name = lc($new_name);
  $self->[STATE_VALUES]->{$new_name} = delete $self->[STATE_VALUES]->{_value};
}

1;

--- NEW FILE: Tag.pm ---
# $Id: Tag.pm,v 1.1 2002/11/04 03:40:58 rcaputo Exp $

# Whip::Tag is what all the whip tag handlers inherit from.  It
# supplies basic features for parsing and rendering tags.

package Whip::Tag;

use warnings;
use strict;

use CGI qw(escape escapeHTML);

### Move the _value of a tag into an attribute named after the tag.
### This is used by tags that augment their parent structures.

sub from_value {
  my ($state, $tag) = @_;
  $state->rename_value($tag);
}

### Wiki-parse the value.

sub wiki_value {
  my ($state, $tag) = @_;

  my $input = $state->delete("_value");
  my $output = "";

  while ( length($input) and
          $input =~ s/^(.*?)\[\s*([^\]\s]+)\s*([^\]]*)\s*\]//
        ) {
    my ($prefix, $url, $text) = ($1, $2, $3);

    $text = $url unless defined $text;
    $text = escapeHTML($text);

    $prefix = "" unless defined $prefix;

    $output .=
      ( $prefix .
        "<a href='?" . escape($url) . "'>$text</a>"
      );
  }

  $output .= $input if defined $input;

  $state->store($tag => $output);
}

1;