view release on metacpan or  search on metacpan

lib/Apache/HeavyCGI.pm  view on Meta::CPAN

  if (my $ep = $self->{EXECUTION_PLAN}) {
    $ep->walk($self);
  } else {
    die "No execution plan!";
  }
}

sub serverroot_url {
  my Apache::HeavyCGI $self = shift;
  return $self->{SERVERROOT_URL} if $self->{SERVERROOT_URL};
  require URI::URL;
  my $r = $self->{R} or
      return URI::URL->new("http://localhost");
  my $host   = $r->server->server_hostname;
  my $port = $r->server->port || 80;
  my $protocol = $port == 443 ? "https" : "http";
  my $explicit_port = ($port == 80 || $port == 443) ? "" : ":$port";
  $self->{SERVERROOT_URL} = URI::URL->new(
				   "$protocol\://" .
				   $host .
				   $explicit_port .
				   "/"
				  );
}

sub time {
  my Apache::HeavyCGI $self = shift;
  $self->{TIME} ||= time;
}

sub today {
  my Apache::HeavyCGI $self = shift;
  return $self->{TODAY} if defined $self->{TODAY};
  my(@time) = localtime($self->time);
  $time[4]++;
  $time[5] += 1900;
  $self->{TODAY} = sprintf "%04d-%02d-%02d", @time[5,4,3];
}

# CGI form handling

sub checkbox {
  my($self,%arg) = @_;

  my $name = $arg{name};
  my $value;
  defined($value = $arg{value}) or ($value = "on");
  my $checked;
  my @sel = $self->{CGI}->param($name);
  if (@sel) {
    for my $s (@sel) {
      if ($s eq $value) {
	$checked = 1;
	last;
      }
    }
  } else {
    $checked = $arg{checked};
  }
  sprintf(qq{<input type="checkbox" name="%s" value="%s"%s />},
	  $self->escapeHTML($name),
	  $self->escapeHTML($value),
	  $checked ? qq{ checked="checked"} : ""
	 );
}

# pause_1999::main
sub checkbox_group {
  my($self,%arg) = @_;

  my $name = $arg{name};
  my @sel = $self->{CGI}->param($name);
  unless (@sel) {
    if (exists $arg{default}) {
      my $default = $arg{default};
      @sel = ref $default ? @$default : $default;
    }
  }

  my %sel;
  @sel{@sel} = ();
  my @m;

  $name = $self->escapeHTML($name);

  my $haslabels = exists $arg{labels};
  my $linebreak = $arg{linebreak} ? "<br />" : "";

  for my $v (@{$arg{values} || []}) {
    push(@m,
	 sprintf(
		 qq{<input type="checkbox" name="%s" value="%s"%s />%s%s},
		 $name,
		 $self->escapeHTML($v),
		 exists $sel{$v} ? qq{ checked="checked"} : "",
		 $haslabels ? $arg{labels}{$v} : $self->escapeHTML($v),
		 $linebreak,
		)
	);
  }
  join "", @m;
}

sub escapeHTML {
  my($self, $what) = @_;
  return unless defined $what;
  my %escapes = qw(& &amp; " &quot; > &gt; < &lt;);
  $what =~ s[ ([&"<>]) ][$escapes{$1}]xg; # ]] cperl-mode comment
  $what;
}

sub file_field {
  my($self) = shift;
  $self->text_pw_field(FIELDTYPE=>"file", @_);
}

sub hidden_field {
  my($self) = shift;
  $self->text_pw_field(FIELDTYPE=>"hidden", @_);
}

sub password_field {
  my($self) = shift;
  $self->text_pw_field(FIELDTYPE=>"password", @_);
}

# pause_1999::main
sub radio_group {
  my($self,%arg) = @_;
  my $name = $arg{name};
  my $value;
  my $checked;
  my $sel = $self->{CGI}->param($name);
  my $haslabels = exists $arg{labels};
  my $values = $arg{values} or Carp::croak "radio_group called without values";
  defined($checked = $arg{checked})
      or defined($checked = $sel)
	  or defined($checked = $arg{default})
	      or $checked = "";
  # some people like to check the first item anyway:
  #	  or ($checked = $values->[0]);
  my $escname=$self->escapeHTML($name);
  my $linebreak = $arg{linebreak} ? "<br />" : "";
  my @m;
  for my $v (@$values) {
    my $escv = $self->escapeHTML($v);
    if ($DEBUG) {
      warn "escname undef" unless defined $escname;
      warn "escv undef" unless defined $escv;
      warn "v undef" unless defined $v;
      warn "\$arg{labels}{\$v} undef" unless defined $arg{labels}{$v};
      warn "checked undef" unless defined $checked;
      warn "haslabels undef" unless defined $haslabels;
      warn "linebreak undef" unless defined $linebreak;
    }
    push(@m,
	 sprintf(
		 qq{<input type="radio" name="%s" value="%s"%s />%s%s},
		 $escname,
		 $escv,
		 $v eq $checked ? qq{ checked="checked"} : "",
		 $haslabels ? $arg{labels}{$v} : $escv,
		 $linebreak,
		));
  }
  join "", @m;
}

# pause_1999::main
sub scrolling_list {
  my($self, %arg) = @_;
  # name values size labels
  my $size = $arg{size} ? qq{ size="$arg{size}"} : "";
  my $multiple = $arg{multiple} ? q{ multiple="multiple"} : "";
  my $haslabels = exists $arg{labels};
  my $name = $arg{name};
  my @sel = $self->{CGI}->param($name);
  if (!@sel && exists $arg{default} && defined $arg{default}) {
    my $d = $arg{default};
    @sel = ref $d ? @$d : $d;
  }
  my %sel;
  @sel{@sel} = ();
  my @m;
  push @m, sprintf qq{<select name="%s"%s%s>}, $name, $size, $multiple;
  $arg{values} = [$arg{value}] unless exists $arg{values};
  for my $v (@{$arg{values} || []}) {
    my $escv = $self->escapeHTML($v);
    push @m, sprintf qq{<option%s value="%s">%s</option>\n},
	exists $sel{$v} ? q{ selected="selected"} : "",
	    $escv,
		$haslabels ? $self->escapeHTML($arg{labels}{$v}) : $escv;
  }
  push @m, "</select>";
  join "", @m;
}

# pause_1999::main
sub submit {
  my($self,%arg) = @_;
  my $name = $arg{name} || "";
  my $val  = $arg{value} || $name;
  sprintf qq{<input type="submit" name="%s" value="%s" />},
      $self->escapeHTML($name),
	  $self->escapeHTML($val);
}

# pause_1999::main
sub textarea {
  my($self,%arg) = @_;
  my $req = $self->{CGI};
  my $name = $arg{name} || "";
  my $val  = $req->param($name) || $arg{default} || $arg{value} || "";
  my($r)   = exists $arg{rows} ? qq{ rows="$arg{rows}"} : '';
  my($c)   = exists $arg{cols} ? qq{ cols="$arg{cols}"} : '';
  my($wrap)= exists $arg{wrap} ? qq{ wrap="$arg{wrap}"} : '';
  sprintf qq{<textarea name="%s"%s%s%s>%s</textarea>},
      $self->escapeHTML($name),
	  $r, $c, $wrap, $self->escapeHTML($val);
}

# pause_1999::main
sub textfield {
  my($self) = shift;
  $self->text_pw_field(FIELDTYPE=>"text", @_);
}

sub text_pw_field {
  my($self, %arg) = @_;
  my $name = $arg{name} || "";
  my $fieldtype = $arg{FIELDTYPE};

  my $req = $self->{CGI};
  my $val;
  if ($fieldtype eq "FILE") {
    if ($req->can("upload")) {
      if ($req->upload($name)) {
	$val = $req->upload($name);
      } else {
	$val = $req->param($name);
      }
    } else {
      $val = $req->param($name);
    }
  } else {
    $val = $req->param($name);
  }
  defined $val or
      defined($val = $arg{value}) or
	  defined($val = $arg{default}) or
	      ($val = "");

  sprintf qq{<input type="$fieldtype"
 name="%s" value="%s"%s%s />},
      $self->escapeHTML($name),
	   $self->escapeHTML($val),
	       exists $arg{size} ? " size=\"$arg{size}\"" : "",
		   exists $arg{maxlength} ? " maxlength=\"$arg{maxlength}\"" : "";
}

sub uri_escape {
  my Apache::HeavyCGI $self = shift;
  my $string = shift;
  return "" unless defined $string;
  require URI::Escape;
  my $s = URI::Escape::uri_escape($string, '^\w ');
  $s =~ s/ /+/g;
  $s;
}

sub uri_escape_light {
  my Apache::HeavyCGI $self = shift;
  require URI::Escape;
  URI::Escape::uri_escape(shift,q{<>#%"; \/\?:&=+,\$}); #"
}

1;

=head1 NAME

Apache::HeavyCGI - Framework to run complex CGI tasks on an Apache server

=head1 SYNOPSIS

 use Apache::HeavyCGI;

=head1 WARNING UNSUPPORTED ALPHA CODE RELEASED FOR DEMO ONLY

The release of this software was only for evaluation purposes to
people who are actively writing code that deals with Web Application
Frameworks. This package is probably just another Web Application
Framework and may be worth using or may not be worth using. As of this
writing (July 1999) it is by no means clear if this software will be
developed further in the future. The author has written it over many
years and is deploying it in several places. B<Update 2006-02-03:
Development stalled since 2001 and now discontinued.>

There is no official support for this software. If you find it useful
or even if you find it useless, please mail the author directly.

But please make sure you remember: THE RELEASE IS FOR DEMONSTRATION
PURPOSES ONLY.

=head1 DESCRIPTION

The Apache::HeavyCGI framework is intended to provide a couple of
simple tricks that make it easier to write complex CGI solutions. It
has been developed on a site that runs all requests through a single
mod_perl handler that in turn uses CGI.pm or Apache::Request as the
query interface. So Apache::HeavyCGI is -- as the name implies -- not
merely for multi-page CGI scripts (for which there are other
solutions), but it is for the integration of many different pages into
a single solution. The many different pages can then conveniently
share common tasks.

The approach taken by Apache::HeavyCGI is a components-driven one with
all components being pure perl. So if you're not looking for yet
another embedded perl solution, and aren't intimidated by perl, please
read on.

=head2 Stacked handlers suck

If you have had a look at stacked handlers, you might have noticed
that the model for stacking handlers often is too primitive. The model
supposes that the final form of a document can be found by running
several passes over a single entity, each pass refining the entity,
manipulating some headers, maybe even passing some notes to the next
handler, and in the most advanced form passing pnotes between
handlers. A lot of Web pages may fit into that model, even complex
ones, but it doesn't scale well for pages that result out of a
structure that's more complicated than adjacent items. The more
complexity you add to a page, the more overhead is generated by the
model, because for every handler you push onto the stack, the whole
document has to be parsed and recomposed again and headers have to be