mark: A photo of Mark kneeling on top of the Taal Volcano in the Philippines. It was a long hike. (Default)
Mark Smith ([staff profile] mark) wrote in [site community profile] changelog2010-02-17 04:57 am

[dw-free] DW::Request::Standard

[commit: http://hg.dwscoalition.org/dw-free/rev/09ce6d0bca17]

http://bugs.dwscoalition.org/show_bug.cgi?id=2313

Add DW::Request::Standard.

Patch by [personal profile] exor674.

Files modified:
  • cgi-bin/DW/Request/Standard.pm
--------------------------------------------------------------------------------
diff -r 6198b849e8ec -r 09ce6d0bca17 cgi-bin/DW/Request/Standard.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DW/Request/Standard.pm	Wed Feb 17 04:57:01 2010 +0000
@@ -0,0 +1,281 @@
+#!/usr/bin/perl
+#
+# DW::Request::Standard
+#
+# Abstraction layer for standard HTTP::Request/HTTP::Response based systems.
+# We don't care who's giving us the data, ...
+#
+# Authors:
+#      Mark Smith <mark@dreamwidth.org>
+#      Andrea Nall <anall@andreanall.com>
+#
+# Copyright (c) 2010 by Dreamwidth Studios, LLC.
+#
+# This program is free software; you may redistribute it and/or modify it under
+# the same terms as Perl itself.  For a copy of the license, please reference
+# 'perldoc perlartistic' or 'perldoc perlgpl'.
+#
+
+package DW::Request::Standard;
+
+use strict;
+use Carp qw/ confess cluck /;
+use HTTP::Request;
+use HTTP::Response;
+use HTTP::Status qw//;
+
+use fields (
+            'req',       # The HTTP::Request object
+            'res',       # a HTTP::Response object
+            'notes',
+            'pnotes',
+
+            # these are mutually exclusive; if you use one you can't use the other
+            'content',   # raw content
+            'post_args', # hashref of POST arguments
+            'get_args',  # hashref of GET arguments
+
+            # we have to parse these out ourselves
+            'uri',
+            'querystring',
+        );
+
+# creates a new DW::Request object, based on what type of server environment we
+# are running under
+sub new {
+    my DW::Request::Standard $self = $_[0];
+    $self = fields::new( $self ) unless ref $self;
+
+    # setup object
+    $self->{req}         = $_[1];
+    $self->{res}         = HTTP::Response->new( 200 );
+    $self->{post_args}   = undef;
+    $self->{content}     = undef;
+    $self->{uri}         = $self->{req}->uri;
+    $self->{notes}       = {};
+    $self->{pnotes}      = {};
+    
+    # now stick ourselves as the primary request ...
+    unless ( $DW::Request::cur_req ) {
+        $DW::Request::determined = 1;
+        $DW::Request::cur_req = $self;
+    }
+
+    # done
+    return $self;
+}
+
+# current document root
+sub document_root {
+    confess "Not implemented, doesn't matter here ...\n";
+}
+
+# method string GET, POST, etc
+sub method {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{req}->method;
+}
+
+# the URI requested (does not include host:port info)
+sub uri {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{uri}->path;
+}
+
+sub content_type {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{req}->content_type( $_[1] );
+}
+
+# returns the query string
+sub query_string {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{uri}->query;
+}
+
+# returns the raw content of the body; note that this can be particularly
+# slow, so you should only call this if you really need it...
+sub content {
+    my DW::Request::Standard $self = $_[0];
+
+    die "already loaded post_args\n"
+        if defined $self->{post_args};
+
+    # keep a local copy ... bloats memory, and useless, why?
+    return $self->{content} if defined $self->{content};
+    return $self->{content} = $self->{req}->content;
+}
+
+# content of our response object
+sub response_content {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{res}->content;
+}
+
+# return a response as a string
+sub response_as_string {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{res}->as_string;
+}
+
+# get POST arguments as an APR::Table object (which is a tied hashref)
+sub post_args {
+    my DW::Request::Standard $self = $_[0];
+
+    die "already loaded content\n"
+        if defined $self->{content};
+
+    return $self->{post_args} if defined $self->{post_args};
+
+    # get the content and parse it.  I would have expected there to be some
+    # official method of doing this on HTTP::Request?  guess not.
+    return $self->{post_args} = { LJ::parse_args( $self->{req}->content ) };
+}
+
+sub get_args {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{get_args} if defined $self->{get_args};
+    return $self->{get_args} = { LJ::parse_args( $self->query_string ) };
+}
+
+# searches for a given note and returns the value, or sets it
+sub note {
+    my DW::Request::Standard $self = $_[0];
+    if ( scalar( @_ ) == 2 ) {
+        return $self->{notes}->{$_[1]};
+    } else {
+        return $self->{notes}->{$_[1]} = $_[2];
+    }
+}
+
+# searches for a given pnote and returns the value, or sets it
+sub pnote {
+    my DW::Request::Standard $self = $_[0];
+    if ( scalar( @_ ) == 2 ) {
+        return $self->{pnotes}->{$_[1]};
+    } else {
+        return $self->{pnotes}->{$_[1]} = $_[2];
+    }
+}
+
+# searches for a given header and returns the value, or sets it
+sub header_in {
+    my DW::Request::Standard $self = $_[0];
+    if ( scalar( @_ ) == 2 ) {
+        return $self->{req}->header( $_[1] );
+    } else {
+        return $self->{req}->header( $_[1] => $_[2] );
+    }
+}
+
+# searches for a given header and returns the value, or sets it
+sub header_out {
+    my DW::Request::Standard $self = $_[0];
+    if ( scalar( @_ ) == 2 ) {
+        return $self->{res}->header( $_[1] );
+    } else {
+        return $self->{res}->header( $_[1] => $_[2] );
+    }
+}
+
+# this may not be precisely correct?  maybe we need to maintain our
+# own set of headers that are separate for errors... FIXME: investigate
+*err_header_out = \&header_out;
+
+# returns the ip address of the connected person
+sub get_remote_ip {
+    my DW::Request::Standard $self = $_[0];
+
+    # FIXME: this needs to support more than just the header ... what if we're not
+    # running behind a proxy?  can we use the environment?  do we fake it?  for now,
+    # assume that if there is no X-Forwarded-For or we don't trust it, we just put in
+    # a bogus IP...
+    return '127.0.0.100' unless $LJ::TRUST_X_HEADERS;
+    
+    my @ips = split /\s*,\s*/, $self->{req}->header( 'X-Forwarded-For' );
+    return '127.0.0.101' unless @ips && $ips[0];
+    
+    return $ips[0];
+}
+
+# sets last modified, this is called so that we set it up on the response object
+sub set_last_modified {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{res}->header( 'Last-Modified' => LJ::time_to_http( $_[1] ) );
+}
+
+# this is a response method
+sub status {
+    my DW::Request::Standard $self = $_[0];
+    if ( scalar( @_ ) == 2 ) {
+        # Set message to a default string, just setting code won't do it.
+        my $code = $_[1] || 500;
+        $self->{res}->code( $code );
+        $self->{res}->message( HTTP::Status::status_message($code) );
+    }
+    return $self->{res}->code;
+}
+
+# build or return a status line (RESPONSE)
+sub status_line {
+    my DW::Request::Standard $self = $_[0];
+    if ( scalar( @_ ) == 2 ) {
+        # We must set code and message seperately.
+        if ( $_[1] =~ m/^(\d+)\s+(.+)$/ ) {
+            $self->{res}->code( $1 );
+            $self->{res}->message( $2 );
+        }
+    }
+    return $self->{res}->status_line;
+}
+
+# meets conditions
+sub meets_conditions {
+    my DW::Request::Standard $self = $_[0];
+
+    # FIXME: this should be pretty easy ... check the If headers (only time ones?)
+    # and see if they're good or not.  return proper status code here (OK, NOT_MODIFIED)
+    # go see the one caller in ljfeed
+    return 0;
+}
+
+sub print {
+    my DW::Request::Standard $self = $_[0];
+    $self->{res}->add_content( $_[1] );
+    return;
+}
+
+sub read {
+    my DW::Request::Standard $self = shift;
+    confess "Reading not implemented.\n";
+}
+
+# return the internal Standard request object... in this case, we are
+# just going to return ourself, as anybody that needs the request object
+# is probably an old Apache style caller that needs updating
+sub r {
+    my DW::Request::Standard $self = $_[0];
+    cluck "DW::Request::Standard->r called, please update the caller.\n";
+    return $self;
+}
+
+# calls the method as a handler.
+sub call_response_handler {
+    return $_[1]->();
+}
+
+sub call_bml {
+    confess "call_bml not (yet) supported\n";
+}
+
+# constants sometimes used
+sub OK        { return 200; }
+sub REDIRECT  { return 302; }
+sub NOT_FOUND { return 404; }
+
+# spawn a process for an external program
+sub spawn {
+    confess "Sorry, spawning not implemented.\n";
+}
+
+1;
--------------------------------------------------------------------------------

Post a comment in response:

This account has disabled anonymous posting.
If you don't have an account you can create one now.
No Subject Icon Selected
More info about formatting

If you are unable to use this captcha for any reason, please contact us by email at support@dreamwidth.org