cgi-bin/LJ/Request/Apache2.pm

   1 package LJ::Request::Apache2;
   2 use strict;
   3
   4 use Carp qw//;
   5 use Apache2::Const qw/:methods :common :http/;
   6 use Apache2::RequestUtil;
   7 use Apache2::RequestRec;
   8 use Apache2::Response;
   9 use Apache2::RequestIO;
  10 use Apache2::Request;
  11 use Apache2::SubRequest;
  12 use Apache2::Upload;
  13 use Apache2::ServerUtil;
  14 use Apache2::Log;
  15 use Apache2::Access;
  16 use Apache2::Connection;
  17 use Apache2::URI;
  18 use ModPerl::Util;
  19 use URI::Escape;
  20 use APR::Finfo;
  21
  22
  23 sub LJ::Request::OK                        { return Apache2::Const::OK }
  24 sub LJ::Request::DONE                      { return Apache2::Const::DONE }
  25 sub LJ::Request::REDIRECT                  { return Apache2::Const::REDIRECT }
  26 sub LJ::Request::DECLINED                  { return Apache2::Const::DECLINED }
  27 sub LJ::Request::FORBIDDEN                 { return Apache2::Const::FORBIDDEN }
  28 sub LJ::Request::NOT_FOUND                 { return Apache2::Const::NOT_FOUND }
  29 sub LJ::Request::HTTP_NOT_MODIFIED         { return Apache2::Const::HTTP_NOT_MODIFIED }
  30 sub LJ::Request::HTTP_MOVED_PERMANENTLY    { return Apache2::Const::HTTP_MOVED_PERMANENTLY }
  31 sub LJ::Request::HTTP_MOVED_TEMPORARILY    { return Apache2::Const::HTTP_MOVED_TEMPORARILY }
  32 sub LJ::Request::HTTP_METHOD_NOT_ALLOWED   { return Apache2::Const::HTTP_METHOD_NOT_ALLOWED() }
  33 sub LJ::Request::HTTP_BAD_REQUEST          { return Apache2::Const::HTTP_BAD_REQUEST() }
  34 sub LJ::Request::M_TRACE                   { return Apache2::Const::M_TRACE }
  35 sub LJ::Request::M_OPTIONS                 { return Apache2::Const::M_OPTIONS }
  36 sub LJ::Request::M_PUT                     { return Apache2::Const::M_PUT }
  37 sub LJ::Request::M_POST                    { return Apache2::Const::M_POST() }
  38 sub LJ::Request::SERVER_ERROR              { return Apache2::Const::SERVER_ERROR }
  39 sub LJ::Request::BAD_REQUEST               { return Apache2::Const::HTTP_BAD_REQUEST }
  40 sub LJ::Request::HTTP_GONE                 { return Apache2::Const::HTTP_GONE }
  41 sub LJ::Request::AUTH_REQUIRED             { return Apache2::Const::AUTH_REQUIRED }
  42 sub LJ::Request::HTTP_PRECONDITION_FAILED  { return Apache2::Const::HTTP_PRECONDITION_FAILED }
  43
  44 my $instance = '';
  45
  46 sub LJ::Request::_get_instance {
  47     my $class = shift;
  48
  49     return $class if ref $class;
  50
  51     Carp::confess("Request is not provided to LJ::Request") unless $instance;
  52     return $instance;
  53 }
  54
  55 sub LJ::Request::interface_name { 'Apache2' }
  56
  57 sub LJ::Request::request { $instance }
  58
  59 sub LJ::Request::r {
  60     return shift->_get_instance()->{r};
  61 }
  62
  63 sub LJ::Request::apr {
  64     return shift->_get_instance()->{apr};
  65 }
  66
  67 sub LJ::Request::_new {
  68     my $class = shift;
  69     my $r     = shift;
  70
  71     return bless {
  72         r   => $r,
  73         apr => Apache2::Request->new($r),
  74     }, $class;
  75 }
  76
  77 sub LJ::Request::instance {
  78     my $class = shift;
  79     Carp::confess("use 'request' instead");
  80 }
  81
  82 sub LJ::Request::init {
  83     my $class = shift;
  84     my $r     = shift;
  85
  86     # second init within a same request.
  87     # Request object may differ between handlers.
  88     if ($class->is_inited){
  89         # NOTE. this is not good approach. becouse we would have Apache::Request based on other $r object.
  90         $instance->{r} = $r;
  91         return $instance;
  92     }
  93
  94     $instance = LJ::Request->_new($r);
  95
  96     return $instance;
  97 }
  98
  99 sub LJ::Request::prev {
 100     my $class = shift;
 101     my $prev_handle = $class->r()->prev(@_);
 102     return unless $prev_handle;
 103     return LJ::Request->_new($prev_handle);
 104 }
 105
 106 sub LJ::Request::is_inited {
 107     return $instance ? 1 : 0;
 108 }
 109
 110 sub LJ::Request::update_mtime {
 111     my $class = shift;
 112     return $class->r()->update_mtime(@_);
 113 }
 114
 115 sub LJ::Request::set_last_modified {
 116     my $class = shift;
 117     return $class->r()->set_last_modified(@_);
 118 }
 119
 120 sub LJ::Request::request_time {
 121     my $class = shift;
 122     return $class->r()->request_time();
 123 }
 124
 125 sub LJ::Request::read {
 126     my $class = shift;
 127     return $class->r()->read(@_);
 128 }
 129
 130 sub LJ::Request::is_main {
 131     my $class = shift;
 132     return !$class->r()->main;
 133 }
 134
 135 sub LJ::Request::main {
 136     my $class = shift;
 137     return $class->r()->main(@_);
 138 }
 139
 140 sub LJ::Request::dir_config {
 141     my $class = shift;
 142     return $class->r()->dir_config(@_);
 143 }
 144
 145 sub LJ::Request::header_only {
 146     my $class = shift;
 147     return $class->r()->header_only;
 148 }
 149
 150 sub LJ::Request::content_languages {
 151     my $class = shift;
 152     return $class->r()->content_languages(@_);
 153 }
 154
 155 sub LJ::Request::register_cleanup {
 156     my $class = shift;
 157     return $class->r()->pool->cleanup_register(@_);
 158 }
 159
 160 sub LJ::Request::path_info {
 161     my $class = shift;
 162     return $class->r()->path_info(@_);
 163 }
 164
 165 # $r->args in 2.0 returns the query string without parsing and splitting it into an array.
 166 sub LJ::Request::args {
 167     my $class = shift;
 168     my $r = $class->r();
 169     if (wantarray()) {
 170         my $qs = $r->args(@_);
 171         my @args =
 172             map { URI::Escape::uri_unescape ($_) }
 173             map { s/\+/ /g; $_ }  # in query_string 'break' is encoded as '+' simbol
 174             map { split /=/ => $_, 2 }
 175             split /[\&\;]/ => $qs;
 176         return @args;
 177     } else {
 178         return $r->args(@_);
 179     }
 180 }
 181
 182 sub LJ::Request::method {
 183     my $class = shift;
 184     $class->r()->method;
 185 }
 186
 187 sub LJ::Request::bytes_sent {
 188     my $class = shift;
 189     $class->r()->bytes_sent(@_);
 190 }
 191
 192 sub LJ::Request::document_root {
 193     my $class = shift;
 194     $class->r()->document_root;
 195 }
 196
 197 sub LJ::Request::finfo {
 198     my $class = shift;
 199     $class->apr()->finfo;
 200 }
 201
 202 sub LJ::Request::filename {
 203     my $class = shift;
 204     $class->r()->filename(@_);
 205 }
 206
 207 sub LJ::Request::add_httpd_conf {
 208     my $class = shift;
 209     my @confs = @_;
 210     Apache2::ServerUtil->server->add_config(\ @confs);
 211 }
 212
 213 sub LJ::Request::is_initial_req {
 214     my $class = shift;
 215     $class->r()->is_initial_req(@_);
 216 }
 217
 218 sub LJ::Request::push_handlers_global {
 219     my $class = shift;
 220     my @handlers = map {
 221             my $el = $_;
 222             $el =~ s/PerlHandler/PerlResponseHandler/g;
 223             $el;
 224         } @_;
 225     Apache2::ServerUtil->server->push_handlers(@handlers);
 226 }
 227
 228 sub LJ::Request::push_handlers {
 229     my $class = shift;
 230     my @handlers = map {
 231             my $el = $_;
 232             $el =~ s/PerlHandler/PerlResponseHandler/g;
 233             $el;
 234         } @_;
 235     return $class->r()->push_handlers(@handlers);
 236 }
 237
 238 sub LJ::Request::set_handlers {
 239     my $class = shift;
 240     my @handlers = map {
 241             my $el = $_;
 242             $el =~ s/PerlHandler/PerlResponseHandler/g;
 243             $el;
 244         } @_;
 245     $class->r()->set_handlers(@handlers);
 246 }
 247
 248 sub LJ::Request::handler {
 249     my $class = shift;
 250     $class->r()->handler(@_);
 251 }
 252
 253 sub LJ::Request::method_number {
 254     my $class = shift;
 255     return $class->r()->method_number(@_);
 256 }
 257
 258 sub LJ::Request::status {
 259     my $class = shift;
 260     return $class->r()->status(@_);
 261 }
 262
 263 sub LJ::Request::status_line {
 264     my $class = shift;
 265     return $class->r()->status_line(@_);
 266 }
 267
 268 ##
 269 ##
 270 ##
 271 sub LJ::Request::free {
 272     my $class = shift;
 273     $instance = undef;
 274 }
 275
 276
 277 sub LJ::Request::notes {
 278     my $class = shift;
 279     return $class->r()->pnotes(@_);
 280 }
 281
 282 sub LJ::Request::pnotes {
 283     my $class = shift;
 284     $class->r()->pnotes (@_);
 285 }
 286
 287 sub LJ::Request::parse {
 288     my $class = shift;
 289     $class->r()->parse (@_);
 290 }
 291
 292 sub LJ::Request::uri {
 293     my $class = shift;
 294     $class->r()->uri (@_);
 295 }
 296
 297 sub LJ::Request::hostname {
 298     my $class = shift;
 299     $class->r()->hostname (@_);
 300 }
 301
 302 sub LJ::Request::header_out {
 303     my $class = shift;
 304     my $header = shift;
 305     if (@_ > 0){
 306         return $class->r()->err_headers_out->{$header} = shift;
 307     } else {
 308         return $class->r()->err_headers_out->{$header};
 309     }
 310 }
 311
 312 sub LJ::Request::headers_out {
 313     my $class = shift;
 314     $class->r()->headers_out (@_);
 315 }
 316
 317 sub LJ::Request::header_in {
 318     my $class = shift;
 319     my $header = shift;
 320     if (@_ > 0){
 321         return $class->r()->headers_in->{$header} = shift;
 322     } else {
 323         return $class->r()->headers_in->{$header};
 324     }
 325 }
 326
 327 sub LJ::Request::headers_in {
 328     my $class = shift;
 329     $class->r()->headers_in();
 330 }
 331
 332 sub LJ::Request::param {
 333     my $class = shift;
 334     $class->r()->param (@_);
 335 }
 336
 337 sub LJ::Request::no_cache {
 338     my $class = shift;
 339     $class->r()->no_cache (@_);
 340 }
 341
 342 sub LJ::Request::content_type {
 343     my $class = shift;
 344     $class->r()->content_type (@_);
 345 }
 346
 347 sub LJ::Request::pool {
 348     my $class = shift;
 349     $class->r()->pool;
 350 }
 351
 352 sub LJ::Request::connection {
 353     my $class = shift;
 354     $class->r()->connection;
 355 }
 356
 357 sub LJ::Request::output_filters {
 358     my $class = shift;
 359     $class->r()->output_filters(@_);
 360 }
 361
 362 sub LJ::Request::print {
 363     my $class = shift;
 364     my $res = eval { $class->r()->print (@_) };
 365     if ($@){
 366         return undef if $@ =~ m'Software caused connection abort';  ## that's not a real error.
 367                                                                     ## upcoming client closed connection.
 368                                                                     ## catch it and allow handler to complete work.
 369         die $@; ## throw error
 370     }
 371     return $res;
 372 }
 373
 374 sub LJ::Request::content_encoding {
 375     my $class = shift;
 376     $class->r()->content_encoding(@_);
 377 }
 378
 379 sub LJ::Request::send_http_header {
 380     my $class = shift;
 381     # http://perl.apache.org/docs/2.0/user/porting/compat.html#C____r_E_gt_send_http_header___
 382     # This method is not needed to be called in 2.0,
 383     #
 384     # http://perl.apache.org/docs/2.0/user/coding/coding.html#Forcing_HTTP_Response_Headers_Out
 385     $class->r()->rflush;
 386
 387 }
 388
 389
 390 sub LJ::Request::err_headers_out {
 391     my $class = shift;
 392     $class->r()->err_headers_out (@_)
 393 }
 394
 395 sub LJ::Request::allowed {
 396     my $class = shift;
 397     return $class->r()->allowed(@_);
 398 }
 399
 400
 401 ## Returns Array (Key, Value, Key, Value) which can be converted to HASH.
 402 ## But there can be some params with the same name!
 403 #
 404 # TODO: do we need this and 'args' methods? they are much the same.
 405 sub LJ::Request::get_params {
 406     my $class = shift;
 407     my $r = $class->r();
 408     if (wantarray()){
 409         my $qs = $r->args(@_);
 410         my @args = split /[&;]/ => $qs;
 411         return map {
 412             my ($k, $v) = map {
 413                 s{\+} { }g; # in query_string 'break' is encoded as '+' simbol
 414                 URI::Escape::uri_unescape($_)
 415             } split '=', $_, 2;
 416
 417             defined $k? ($k, $v) : ();
 418         } @args;
 419     } else {
 420         return $r->args(@_);
 421     }
 422 }
 423
 424 sub LJ::Request::post_params {
 425     my $class = shift;
 426     my $self = $class->_get_instance();
 427     my $apr = $self->apr();
 428
 429     return @{ $self->{params} } if $self->{params};
 430     my (@params, %already_seen);
 431     foreach my $name ($apr->body) {
 432         next if $already_seen{$name}++;
 433         foreach my $val ($apr->body($name)) {
 434             push @params, ($name, $val);
 435         }
 436     }
 437     $self->{params} = \@params;
 438     return @params;
 439 }
 440
 441 sub LJ::Request::raw_content {
 442     my $class = shift;
 443     my $self = $class->_get_instance();
 444     my $r = $self->apr();
 445     return $self->{raw_content} if $self->{raw_content};
 446     $r->read($self->{raw_content}, $r->headers_in()->get('Content-Length')) if $r->headers_in()->get('Content-Length');
 447     return $self->{raw_content};
 448 }
 449
 450 sub LJ::Request::add_header_out {
 451     my $class  = shift;
 452     my $header = shift;
 453     my $value  = shift;
 454
 455     my $r = $class->r();
 456     ## The difference between headers_out and err_headers_out, is that
 457     ## the latter are printed even on error, and persist across internal redirects
 458     ## (so the headers printed for ErrorDocument handlers will have them).
 459     $r->err_headers_out->add($header, $value);
 460
 461     return 1;
 462 }
 463
 464 # TODO: maybe remove next method and use 'header_out' instead?
 465 sub LJ::Request::set_header_out {
 466     my $class  = shift;
 467     my $header = shift;
 468     my $value  = shift;
 469
 470     my $r = $class->r();
 471     ## The difference between headers_out and err_headers_out, is that
 472     ## the latter are printed even on error, and persist across internal redirects
 473     ## (so the headers printed for ErrorDocument handlers will have them).
 474     $r->err_headers_out->set($header, $value);
 475
 476     return 1;
 477 }
 478
 479 sub LJ::Request::unset_headers_in {
 480     my $class = shift;
 481     my $header = shift;
 482     $class->r()->headers_in->unset($header);
 483 }
 484
 485 sub LJ::Request::log_error {
 486     my $class = shift;
 487     return $class->r()->log_error(@_);
 488 }
 489
 490 sub LJ::Request::remote_ip {
 491     my $class = shift;
 492     return $class->r()->connection()->remote_ip(@_);
 493 }
 494
 495 sub LJ::Request::remote_host {
 496     my $class = shift;
 497     return $class->r()->connection()->remote_host;
 498 }
 499
 500 sub LJ::Request::user {
 501     my $class = shift;
 502     return $class->r()->auth_name();
 503 }
 504
 505 sub LJ::Request::aborted {
 506     my $class = shift;
 507     return $class->r()->connection()->aborted;
 508 }
 509
 510 sub LJ::Request::upload {
 511     my $class = shift;
 512     return $class->apr()->upload(@_);
 513 }
 514
 515 sub LJ::Request::sendfile {
 516     my $class = shift;
 517     my $filename = shift;
 518     my $fh       = shift; # used in Apache v.1
 519
 520     return $class->r()->sendfile($filename);
 521 }
 522
 523 sub LJ::Request::parsed_uri {
 524     my $class = shift;
 525     $class->r()->parsed_uri; # Apache2::URI
 526 }
 527
 528 sub LJ::Request::unparsed_uri {
 529     my $class = shift;
 530     $class->r()->unparsed_uri; # Apache2::URI
 531 }
 532
 533 sub LJ::Request::current_callback {
 534     my $class = shift;
 535     return ModPerl::Util::current_callback();
 536 }
 537
 538 sub LJ::Request::child_terminate {
 539     my $class = shift;
 540     return $class->r()->child_terminate;
 541 }
 542
 543 sub LJ::Request::meets_conditions {
 544     my $class = shift;
 545     return $class->r()->meets_conditions;
 546 }
 547
 548 1;