Apache-HeavyCGI

 view release on metacpan or  search on metacpan

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

      $self->{CAN_UTF8} = 0;
    }
    return $self->{CAN_UTF8};
  }
  my $protocol = $self->{R}->protocol || "";
  my($major,$minor) = $protocol =~ m|HTTP/(\d+)\.(\d+)|;
  $self->{CAN_UTF8} = $major >= 1 && $minor >= 1;
}

sub deliver {
  my Apache::HeavyCGI $self = shift;
  my $r = $self->{R};
  # warn "Going to send_http_header";
  $r->send_http_header;
  return OK if $r->method eq "HEAD";
  # warn "Going to print content";
  $r->print($self->{CONTENT});
  DONE; # we've sent the headers and the body, apache shouldn't talk
        # to the browser anymore
}

sub handler {
  warn "The handler of the request hasn't defined a handler subroutine.";
  __PACKAGE__->new( R => shift )->dispatch;
}

sub dispatch {
  my Apache::HeavyCGI $self = shift;
  $self->init;
  eval { $self->prepare; };
  if ($@) {
    if (UNIVERSAL::isa($@,"Apache::HeavyCGI::Exception")) {
      if ($@->{ERROR}) {
	warn "\$\@ ERROR[$@->{ERROR}]";
	$@->{ERROR} = [ $@->{ERROR} ] unless ref $@->{ERROR};
	warn "\$\@ ERROR[$@->{ERROR}]";
	push @{$self->{ERROR}}, @{$@->{ERROR}};
	warn "self ERROR[$self->{ERROR}]";
      } elsif ($@->{HTTP_STATUS}) {
	return $@->{HTTP_STATUS};
      }
    } else {
      # this is not a known error type, we need to handle it anon
      if ($self->{ERRORS_TO_BROWSER}) {
	push @{$self->{ERROR}}, " ", $@;
      } else {
	$self->{R}->log_error($@);
	return SERVER_ERROR;
      }
    }
  }
  return $self->{DONE} if $self->{DONE}; # backwards comp now, will go away
  $self->{CONTENT} = $self->layout->as_string($self);
  $self->finish;
  $self->deliver;
}

sub expires {
  my Apache::HeavyCGI $self = shift;
  my($set) = @_;
  $set = Apache::HeavyCGI::Date->new(unix => $set)
      if defined($set) and not ref($set); # allow setting to a number
  $self->{EXPIRES} = $set if defined $set;
  return $self->{EXPIRES}; # even if not defined $self->{EXPIRES};
}

sub finish {
  my Apache::HeavyCGI $self = shift;

  my $r = $self->{R};
  my $content_type = "text/html";
  $content_type .= "; charset=$self->{CHARSET}" if defined $self->{CHARSET};
  $r->content_type($content_type);

  eval { require Compress::Zlib; };
  $self->{CAN_GZIP} = 0 if $@; # we cannot compress anyway :-)

  if ($self->can_gzip) {
    $r->header_out('Content-Encoding', 'gzip');
    $self->{CONTENT} = Compress::Zlib::memGzip($self->{CONTENT});
  }

  $r->header_out('Vary', join ", ", 'accept-encoding');
  $r->header_out('Expires', $self->expires->http) if $self->expires;
  $r->header_out('Last-Modified',$self->last_modified->http);
  $r->header_out('Content-Length', length($self->{CONTENT}));
}

sub init {
  return;
}

sub instance_of {
  my($self,$class) = @_;
  return $class->instance if $class->can("instance");
  my $requirefile = $class;
  $requirefile =~ s/::/\//g;
  $requirefile .= ".pm";
  # warn "requiring[$requirefile]";
  require $requirefile;
  $class->instance;
}

sub layout {
  my Apache::HeavyCGI $self = shift;
  require Apache::HeavyCGI::Layout;
  my @l;
  push @l, qq{<html><head><title>Apache::HeavyCGI default page</title>
</head><body><pre>};
  push @l, $self->instance_of("Apache::HeavyCGI::Debug");
  push @l, qq{</pre></body></html>};
  Apache::HeavyCGI::Layout->new(@l);
}

sub last_modified {
  my Apache::HeavyCGI $self = shift;
  my($set) = @_;
  $set = Apache::HeavyCGI::Date->new(unix => $set)
      if defined($set) and not ref($set); # allow setting to a number
  $self->{LAST_MODIFIED} = $set if defined $set;
  return $self->{LAST_MODIFIED} if defined $self->{LAST_MODIFIED};
  $self->{LAST_MODIFIED} =
      Apache::HeavyCGI::Date->new(unix => $self->time);
}

sub myurl {
  my Apache::HeavyCGI $self = shift;
  return $self->{MYURL} if defined $self->{MYURL};
  require URI::URL;
  my $r = $self->{R} or
      return URI::URL->new("http://localhost");
  my $script_name = substr(
			   $r->uri,
			   0,
			   length($r->uri)-length($r->path_info)
			  );
  my $port = $r->server->port || 80;
  my $protocol = $port == 443 ? "https" : "http";
  my $explicit_port = ($port == 80 || $port == 443) ? "" : ":$port";
  $self->{MYURL} = URI::URL->new(
				 "$protocol://" .
				 $r->server->server_hostname .
				 $explicit_port .
				 $script_name);
}

sub new {
  my($class,%opt) = @_;
  no strict "refs";
  my $self = bless {}, $class;
  while (my($k,$v) = each %opt) {
    $self->{$k} = $v;
  }
  $self;
}

sub prepare {
  my Apache::HeavyCGI $self = shift;
  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 .
				   "/"
				  );
}



( run in 2.143 seconds using v1.01-cache-2.11-cpan-fe3c2283af0 )