view release on metacpan or  search on metacpan

lib/Apache2/POST200.pm  view on Meta::CPAN

			   RaiseError=>0,
			  } )
      or do {
	$r->warn( "Cannot connect to $cf->{storage}->[0]: $DBI::errstr" );
	$f->remove;
	return Apache2::Const::DECLINED;
      };

    $dbh->begin_work;

    my $headers='';
    $r->headers_out->do(sub{$headers.="$_[0]: $_[1]\n";1;});
    my $err_headers='';
    $r->err_headers_out->do(sub{$err_headers.="$_[0]: $_[1]\n";1;});

    # check if the table exists and can be written
    my $stmt=$dbh->prepare("INSERT INTO $cf->{table}->[0] ".
			   "($cf->{table}->[1], $cf->{table}->[2]) ".
			   "VALUES (?, ?)")
      or do {
	$r->warn( "Cannot prepare INSERT statement: ".$dbh->errstr );
	$dbh->disconnect;
	$f->remove;
	return Apache2::Const::DECLINED;
      };

    $stmt->execute( $session.':00000001', $headers) &&
    $stmt->execute( $session.':00000002', $err_headers) &&
    $stmt->execute( $session.':00000003', $r->content_type)
      or do {
	$r->warn( "Cannot insert into $cf->{table}->[0]: ".$dbh->errstr );
	$dbh->disconnect;
	$f->remove;
	return Apache2::Const::DECLINED;
      };

    my $loc=$r->the_request;	# don't count on $r->uri or $r->unparsed_uri
				# they may have been changed
    $loc=~s/^\w+\s//;		# strip "POST " at head
    $loc=~s/[?#\s].*//;		# strip any parameters, anchor and "HTTP/1.1"
    unless( $loc=~m!^https?://! ) { # can already be for proxy requests
      my $proto=(($r->can('is_https') && $r->is_https or # using Apache::SSLLookup
		  $r->connection->can('is_https') && $r->connection->is_https or # Apache2::ModSSL
		  $r->subprocess_env('HTTPS'))
		 ? 'https'
		 : 'http');
      my $port=':'.$r->get_server_port;
      $port='' if( $port eq ':80' && $proto eq 'http' or
		   $port eq ':443' && $proto eq 'https' );
      $loc=$proto.'://'.$r->get_server_name.$port.$loc;
    }
    $loc.='?'.$cf->{location}->[0].$session;

    my $msg=$msg302;
    $msg=~s/%{location}/$loc/g;

    $r->status( Apache2::Const::REDIRECT );
    $r->status_line( Apache2::RequestUtil::get_status_line(Apache2::Const::REDIRECT) );
    $r->headers_out->clear;
    $r->err_headers_out->clear;
    $r->content_type( 'text/html; charset=iso-8859-1' );
    $r->headers_out->{'Content-Length'}=length $msg;
    $r->headers_out->{'Location'}=$loc;

    $f->ctx( {
	      dbh=>$dbh,
	      stmt=>$stmt,
	      session=>$session,
	      nr=>4,
	      msg=>$msg,
	      bs=>$cf->{blocksize}->[0],
	     } );
  }

  my $ctx=$f->ctx;
  while (my $e = $bb->first) {
    if( $e->is_eos ) {
      $ctx->{dbh}->commit;
      $e->remove;
      my $bbnew=APR::Brigade->new( $f->c->pool, $f->c->bucket_alloc );
      $bbnew->insert_tail(APR::Bucket->new( $bbnew->bucket_alloc, $ctx->{msg} ));
      $bbnew->insert_tail($e);
      $f->next->pass_brigade( $bbnew );
    } else {
      $e->read(my $buf);
      if( length $buf ) {
	if( $ctx->{bs}>0 ) {
	  my ($i, $len, $bs)=(0, length( $buf ), $ctx->{bs});
	  while( $i<$len ) {
	    $ctx->{stmt}->execute
	      ( sprintf( '%s:%08d', $ctx->{session}, $ctx->{nr}++ ),
		substr( $buf, $i, $bs ) );
	    $i+=$bs;
	  }
	} else {
	  $ctx->{stmt}->execute
	    ( sprintf( '%s:%08d', $ctx->{session}, $ctx->{nr}++ ), $buf );
	}
      }
      $e->delete;
    }
  }

  return Apache2::Const::OK;
}

1;