view release on metacpan or  search on metacpan

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

        $self->error(Apache2::Const::HTTP_METHOD_NOT_ALLOWED, sprintf("Method Not Allowed (%s)", $meth));
        return Apache2::Const::DECLINED;
    }

    # Init query object
    my $q = new CGI;
    $self->set(q => $q);

    # Init usr structure
    my %usr = ();
    foreach ($q->all_parameters) {
        next if $_ eq 'POSTDATA' or $_ eq 'PUTDATA' or $_ eq 'PATCHDATA';
        $usr{$_} = $q->param($_);
        Encode::_utf8_on($usr{$_});
    }
    $self->set(usr => \%usr);

    # Init request data from REQUEST in "as-is" format (req_data)
    my $req_data = $q->param($meth.'DATA') // $q->param('XForms:Model') // ''; # Fix: no data where content type is application/xml
    Encode::_utf8_on($req_data);
    $self->set(req_data => $req_data);

    # Set "is_exists" session variable
    $self->set_svar(is_exists => $self->lookup_handler ? 1 : 0);

    # Set debug session variable
    my $debug = 0;
    foreach ($self->get_attr("debug"), $self->get_dvar("debug")) {
        $_ //= "off";
        $debug = 1 if /(on)|(yes)|1/i;
        last if $debug;
    }
    $self->set_svar(debug => $debug);

    return Apache2::Const::OK;
}
sub hAccess { # Type: RUN_ALL
    my $self = shift;
    my $r = shift;
    $self->set_svar(remote_addr => $r->headers_in->get("x-real-ip") || $ENV{HTTP_X_REAL_IP} || $r->connection->remote_ip || $ENV{REMOTE_ADDR});
    return Apache2::Const::OK;
}
sub hAuthen { # Type: RUN_FIRST
    my $self = shift;
    my $r = shift;
    return Apache2::Const::DECLINED;
}
sub hAuthz { # Type: RUN_FIRST
    my $self = shift;
    my $r = shift;
    return Apache2::Const::DECLINED;
}
sub hType { # Type: RUN_FIRST
    my $self = shift;
    my $r = shift;

    my $meth = uc($r->method() || 'GET');
    my $is_get = $meth =~ /GET|HEAD/ ? 1 : 0;
    my $headers = $r->headers_in(); # APR::Table object

    # If content-type is predefined! Nothing to do
    my $content_type = $self->get_attr("content_type");
    if ($content_type) {
        $self->set_svar(format => _ctlookup($content_type) || FORMAT);
        $r->content_type($content_type);
        return Apache2::Const::OK;
    }

    # Content-Type Values from headers
    my $req_content_type = $headers->get("content-type") // '';
    my $req_accept = $headers->get("accept") // '';

    # Try get format from request header first and from the Accept header
    my $format = _ctlookup($req_content_type) || _ctlookup($req_accept);
    my $default_format = $format || FORMAT;
    my $default_content_type = $req_content_type || _format2ct($default_format) || CONTENT_TYPE;

    # If handler not exists
    unless ($self->get_svar("is_exists")) {
        $self->set_svar(format => $default_format);
        $r->content_type($default_content_type);
        return Apache2::Const::OK;
    }

    # If method is GET/HEAD and no need serialization (or handler is not found) --> set defaults!
    if ($is_get && !$self->get_attr("serialize")) {
        $self->set_svar(format => $default_format);
        $r->content_type($default_content_type);
        return Apache2::Const::OK;
    }

    # Return
    if ($format) { # The format detected correctly
        $self->set_svar(format => $format);
        $r->content_type(_format2ct($format));
    } else { # Format is not found
        $self->set_svar(format => $default_format);
        $r->content_type($default_content_type);
        return Apache2::Const::OK if $is_get;
        # Incorrect content type!
        $self->error(Apache2::Const::HTTP_UNSUPPORTED_MEDIA_TYPE,
            sprintf("Content-type %s is not supported", $req_content_type)) if $req_content_type;
    }

    return Apache2::Const::OK;
}
sub hFixup { # Type: RUN_ALL
    my $self = shift;
    my $r = shift;
    my $format = $self->get_svar("format");

    # Flash response data
    $self->set(res_data => "");

    # Serializer?
    return Apache2::Const::OK unless $self->get_attr("deserialize") || $self->get_attr("serialize");

    # Set Serializer
    $self->set_svar(serialize_attr => $self->get_attr("serialize_attr"));
    $self->set_svar(deserialize_attr => $self->get_attr("deserialize_attr"));
    my $serializer = new CTK::Serializer($format, attrs => $self->{_sr_attrs});
    return $self->_raise(sprintf("Can't use format %s for serializer", $format))
        unless $serializer->status;
    $self->set_svar(serializer => $serializer);

    # Deserialization (preparing input (request) data)
    return Apache2::Const::OK unless $self->get_attr("deserialize");
    my $req_data = $self->get("req_data");
    my $structure = $serializer->deserialize($format, $req_data, $self->get_svar("deserialize_attr") || $serializer->{deserialize_attr});
    $self->error(Apache2::Const::HTTP_BAD_REQUEST, $serializer->error) unless $serializer->status;