cgi-bin/LJ/Request/Apache.pm

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