view release on metacpan or  search on metacpan

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

         require Apache::RequestIO;
         require Apache::RequestUtil;
         require Apache::Const;
         require Apache::Log;
         require Apache::URI;
         require APR::Table;
         require APR::URI;
         require CGI;

         Apache::Const->import(-compile => qw(OK DECLINED HTTP_NOT_FOUND HTTP_NOT_ACCEPTABLE HTTP_PARTIAL_CONTENT HTTP_INTERNAL_SERVER_ERROR));

         CGI->compile(qw(param));
      }

     else {
         require Apache;
         require Apache::Constants;
         require Apache::Log;
         require Apache::Request;

         # mod_perl 1.x does not declare a 
         # HTTP_PARTIAL_CONTENT constant so
         # it gets hard-coded below

         Apache::Constants->import(qw(OK DECLINED NOT_FOUND HTTP_NOT_ACCEPTABLE SERVER_ERROR));
     }
}

sub handler : method {
  my $pkg    = shift;
  my $apache = shift;

  my $range  = $pkg->range($apache);

  if (! $range) {
      return $pkg->_declined();
  }

  my $accept = undef;

  if (my $possible = $pkg->accept($apache)) {

      foreach my $choice (split(",",$possible)) {
	  
	  $choice =~ s/^\s+//;
	  $choice =~ s/\s+$//;

          # hand-waving...levels
	  # ...more hand-waving

	  $choice =~ s/;.*//;

	  if ($pkg->send_as($choice)) {
	      $accept = $choice;
	      last;
	  }
      }

      if (! $accept) {
	  $apache->log()->error("unable to send request as '$accept'");
	  return $pkg->_not_acceptable();
      }
  }

  #

  my $parsed = $pkg->parse_range($apache,$range);

  if (! $parsed) {
      $apache->log()->error(sprintf("failed to parse range '%s'",
				    $range));
      
      return $pkg->_server_error();
  }

  #

  my $res = $pkg->query($apache,$parsed);

  if ((! $res) || (! $res->{success})) {
      return $res->{response};
  }

  #

  my $ok = $pkg->send_results($apache,$res,$accept);
  return $ok;
}

sub send_results {
    my $pkg    = shift;
    my $apache = shift;
    my $res    = shift;
    my $accept = shift;

    $accept ||= $apache->dir_config("XPointerSendRangeAs");
    
    my $method = $pkg->send_as($accept);

    if (! $pkg->can($method)) {
	$apache->log()->error("Unknown send as method '$method'");
	return $pkg->_server_error();
    }

    #

    $pkg->send_headers($apache,$res,$accept);
    $pkg->$method($apache,$res);

    # We set the status in 'send_headers' because
    # apache/mod_perl keeps trying to send back an
    # HTML error page whenever we return 206...

    return 0;
}

sub send_headers {
    my $pkg    = shift;
    my $apache = shift;
    my $res    = shift;
    my $accept = shift;

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

	$accept     = $pkg->_param($apache,$aparam);
    }

    return $accept;
}

sub send_as {
    my $pkg = shift;
    return $pkg->_nometh(@_);
}

sub parse_range {
    my $pkg = shift;
    return $pkg->_nometh(@_);
}

sub query {
    my $pkg = shift;
    return $pkg->_nometh(@_);
}

sub _mp2 {
    return MP2;
}

sub _param {
    my $pkg    = shift;
    my $apache = shift;
    my $field  = shift;

    if ($pkg->_mp2()) {
	return CGI::param($field);
    }
    
    my $request = Apache::Request->new($apache);
    return $request->param($field);
}

sub _nometh {
    my $pkg    = shift;
    my $apache = shift;

    my $caller = (caller(1))[3];
    $caller =~ s/.*:://;

    $apache->log()->error(sprintf("package %s does not define a '%s' method",
				  $pkg,$caller));
    return 0;
}

sub _declined {
    my $pkg = shift;
    return ($pkg->_mp2()) ? Apache::DECLINED() : Apache::Constants::DECLINED();
}

sub _server_error {
    my $pkg = shift;
    return ($pkg->_mp2()) ? Apache::HTTP_INTERNAL_SERVER_ERROR() : Apache::Constants::SERVER_ERROR();
}

sub _not_found {
    my $pkg = shift;
    return ($pkg->_mp2()) ? Apache::HTTP_NOT_FOUND() : Apache::Constants::NOT_FOUND();
}

sub _not_acceptable {
    my $pkg = shift;
    return ($pkg->_mp2()) ? Apache::HTTP_NOT_ACCEPTABLE() : Apache::Constants::HTTP_NOT_ACCEPTABLE();
}

sub _partial_content {
    my $pkg = shift;
    return ($pkg->_mp2()) ? Apache::HTTP_PARTIAL_CONTENT() : 206;
}

sub _ok {
    my $pkg = shift;
    return ($pkg->_mp2()) ? Apache::OK() : Apache::Constants::OK();
}

sub _header_in {
    my $pkg    = shift;
    my $apache = shift;
    my $field  = shift;

    return ($pkg->_mp2()) ? $apache->headers_in()->{$field} : $apache->header_in($field);
}

sub _header_out {
    my $pkg    = shift;
    my $apache = shift;
    my $field  = shift;
    my $value  = shift;

    ($pkg->_mp2()) ? $apache->headers_out()->{$field} = $value: $apache->header_out($field,$value);
}

=head1 VERSION

1.1

=head1 DATE

$Date: 2004/11/16 03:56:18 $

=head1 AUTHOR

Aaron Straup Cope E<lt>ascope@cpan.orgE<gt>

=head1 SEE ALSO

http://www.mindswap.org/papers/swrp-iswc04.pdf

http://www.w3.org/TR/WD-xptr

=head1 LICENSE

Copyright (c) 2004 Aaron Straup Cope. All rights reserved.

This is free software, you may use it and distribute it under
the same terms as Perl itself.

=cut

return 1;