view release on metacpan or  search on metacpan

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

    unless( $_isInit ){
        doInit($r, $req) ;
        $_isInit = 1 ;
    }

    ## Response object
    my $resp = Apache2::REST::Response->new() ;
    my $retCode = undef ;

    my $uri = $req->uri() ;
    if ( my $base = $r->dir_config('Apache2RESTAPIBase')){
        $uri =~ s/^\Q$base\E// ;
    }

    ## Get the requested format
    my $wtMethod = $r->dir_config('Apache2RESTWriterSelectMethod') || 'param' ;
    my $format = '' ;
    if ( $wtMethod eq 'param' ){ $format = $req->param('fmt') || '' ; }
    if ( $wtMethod eq 'extension'){ ( $format ) = ( $uri =~ /\.(\w+)$/ ) ; $uri =~ s/\.\w+$// ;  $format ||= '' ;}
    if ( $wtMethod eq 'header' ){ $format = $_MIME2wtClass->{$r->headers_in->{'Accept'}}; }


    # Let Apache2::REST::Request know about requested_format
    $req->requestedFormat($format) ;


    ## Application level authorisation part
    my $appAuth = $r->dir_config('Apache2RESTAppAuth') || '' ;
    if ( $appAuth ){
        eval "require $appAuth;";
        if ( $@ ){
            die "Cannot find AppAuth class $appAuth (from conf Apache2RESTAppAuth)\n" ;
        }
        my $appAuth = $appAuth->new() ;
        $appAuth->init($req) ;
        ## The header
        ## Ok the header is there
        ## Authorize will set message and return true (authorize) or false.
        my $isAuth = $appAuth->authorize($req , $resp ) ;
        unless( $isAuth ){
            $retCode = Apache2::Const::HTTP_UNAUTHORIZED ;
            goto output ;
        }
    }


    my $handlerRootClass = $r->dir_config('Apache2RESTHandlerRootClass') || 'Apache2::REST::Handler' ;

    eval "require $handlerRootClass;";
    if ( $@ ){
        die "Cannot find root class $handlerRootClass (from conf Apache2RESTHandlerRootClass): $@\n" ;
    }

    my $topHandler = $handlerRootClass->new() ;
    my $conf = Apache2::REST::Conf->new() ;
    $conf->Apache2RESTErrorOutput($r->dir_config('Apache2RESTErrorOutput') || 'both' );
    $topHandler->conf($conf);

    my @stack = split('\/+' , $uri);
    # Protect against empty fragments.
    @stack = grep { length($_)>0 } @stack ;



    $retCode = $topHandler->handle(\@stack , $req , $resp ) ;

  output:
    ## Load the writer for the given format
    my $defaultWriter = $r->dir_config('Apache2RESTWriterDefault') || 'xml' ;
    my $wClass = $_wtClasses->{$req->requestedFormat()} || $_wtClasses->{$defaultWriter}  ;
    if ($resp->stream()){
        $wClass .= '_stream';
    } elsif ($resp->multipart_stream()) {
        $wClass .= '_multipart';
    }
    eval "require $wClass;" ;
    if ( $@ ){
        warn "Cannot load $wClass:$@\n" ;
        ## Silently fail to default writer
        require Apache2::REST::Writer::xml ;
        $wClass = 'Apache2::REST::Writer::xml' ;
    }
    my $writer = $wClass->new() ;

    if($writer->can('handleModPerlResponse')){
        ## Use that instead of the legacy code below. (See TODO)
        return $writer->handleModPerlResponse($r,$resp,$retCode);
    }

    ## TODO: Refactor that so it goes in a writer specific method
    $r->content_type($writer->mimeType($resp)) ;
    $resp->cleanup() ;
    my $respTxt = $writer->asBytes($resp) ;
    if ( $retCode && ( $retCode  != Apache2::Const::HTTP_OK ) ){
        $r->status($retCode);
    }
    if ( $retCode && $retCode =~ /^2/ ){
        $r->headers_out()->add('Content-length' , length($respTxt)) ;
    }else{
        $r->err_headers_out()->add('Content-length' , length($respTxt)) ;
    }

    binmode STDOUT ;
    print $respTxt  ;
    return  Apache2::Const::OK ;

}


=head1 AUTHORS

Jerome Eteve, C<< <jerome at eteve.net> >>

Scott Thoman, C<< <scott dot thoman at steeleye dot com> >>

=head1 BUGS

Please report any bugs or feature requests to

L<http://code.google.com/p/apache2rest/issues/list>