Perlbal-XS-HTTPHeaders-0.20/0000755000175000017500000000000011324006271015601 5ustar dormandodormandoPerlbal-XS-HTTPHeaders-0.20/headers.h0000644000175000017500000000457611324003013017370 0ustar dormandodormando/****************************************************************************** * Perlbal XS HTTPHeaders class * * Written by Mark Smith (junior@sixapart.com) * * * * This program is free software; you can redistribute it and/or modify it * * under the same terms as Perl itself. * * * * Copyright 2004 Danga Interactive, Inc. * * Copyright 2005 Six Apart, Ltd. * ******************************************************************************/ #ifndef __HEADERS_H #define __HEADERS_H extern "C" { #include "EXTERN.h" #include "perl.h" #include "XSUB.h" } /* some general purpose defines we use */ #define H_REQUEST 1 #define H_RESPONSE 2 /* setup method constants */ #define M_GET 1 #define M_POST 2 #define M_OPTIONS 3 #define M_PUT 4 #define M_DELETE 5 #define M_HEAD 6 /* some structs we use for storing header information */ struct Header { int keylen; /* 14 */ char *key; /* Content-length */ SV *sv_value; /* 5 */ Header *prev, *next; }; /* the main headers class */ class HTTPHeaders { private: int versionNumber, statusCode, headersType, method; SV *sv_uri, *sv_firstLine, *sv_methodString; Header *hdrs, *hdrtail; Header *findHeader(char *which, int len = 0); void freeHeader(Header *hdr); public: /* constructor and destructor */ HTTPHeaders(); ~HTTPHeaders(); int parseHeaders(SV *headers); /* reconstructor */ SV *getReconstructed(); /* get and set header values */ SV *getHeader(char *which); void setHeader(char *which, char *value); /* extra getters that we use to speed stuff up */ int getMethod(); SV *getMethodString(); int getStatusCode(); void setStatusCode(int code); void setVersionNumber(int version); int getVersionNumber(); bool isRequest(); bool isResponse(); void setCodeText(int code, char *codetext); SV *getURI(); SV *setURI(char *uri); SV *getHeadersList(); }; #endif Perlbal-XS-HTTPHeaders-0.20/README0000644000175000017500000000321711323752360016472 0ustar dormandodormandoPerlbal::XS::HTTPHeaders ======================== This module is a parser for HTTP headers, written in C++. It uses classes internally to provide a fast and easy to use interface to parsing, creating, and working with HTTP headers. This module is designed for use in Perlbal, a software HTTP load balancer by Danga Interactive. In order to use this module, you will need the Perl development libraries along with a C++ compiler and some random assorted things that convert XS files into C (etc). (Not sure if this is part of the Perl development libraries or not... but it should be pretty standard.) INSTALLATION To install this module type the following: perl Makefile.PL make make test make install Alternately, if you're on Debian... dh-make-perl --build dpkg -i ../libperlbal-xs-httpheaders Once you have the files installed, you can instruct Perlbal to use them by typing 'xs enable headers' in a management console (or putting that in your configuration file). Note you will have to restart Perlbal after the module is installed in order for it to notice they exist. DEPENDENCIES Don't think there are any dependencies for this module. AUTHOR/CONTACT Written by Mark Smith (junior@danga.com). Please send feedback/bug reports to our mailing list. You can join at: http://lists.danga.com/mailman/listinfo/perlbal COPYRIGHT AND LICENSE Copyright (C) 2004 Danga Interactive, Inc. Copyright (C) 2005 Six Apart, Ltd. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.4 or, at your option, any later version of Perl 5 you may have available. Perlbal-XS-HTTPHeaders-0.20/Makefile.PL0000644000175000017500000000403111323752360017557 0ustar dormandodormandouse 5.008; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'Perlbal::XS::HTTPHeaders', VERSION_FROM => 'lib/Perlbal/XS/HTTPHeaders.pm', # finds $VERSION PREREQ_PM => { 'Perlbal' => 0, 'Perlbal::HTTPHeaders' => 0, }, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/Perlbal/XS/HTTPHeaders.pm', # retrieve abstract from module AUTHOR => 'Mark Smith ') : ()), LIBS => ['-lstdc++'], # e.g., '-lm' DEFINE => '', # e.g., '-DHAVE_SOMETHING' INC => '-I.', # e.g., '-I. -I/usr/include/other' # Un-comment this if you add C files to link with later: OBJECT => 'headers.o HTTPHeaders.o', # link all the C files too XSOPT => '-C++', CCFLAGS => '-g', CC => 'g++', ); if (eval {require ExtUtils::Constant; 1}) { # If you edit these definitions to change the constants used by this module, # you will need to use the generated const-c.inc and const-xs.inc # files to replace their "fallback" counterparts before distributing your # changes. my @names = (qw(H_REQUEST H_RESPONSE M_DELETE M_GET M_OPTIONS M_POST M_PUT M_HEAD)); ExtUtils::Constant::WriteConstants( NAME => 'Perlbal::XS::HTTPHeaders', NAMES => \@names, DEFAULT_TYPE => 'IV', C_FILE => 'const-c.inc', XS_FILE => 'const-xs.inc', ); } else { use File::Copy; use File::Spec; foreach my $file ('const-c.inc', 'const-xs.inc') { my $fallback = File::Spec->catfile('fallback', $file); copy ($fallback, $file) or die "Can't copy $fallback to $file: $!"; } } Perlbal-XS-HTTPHeaders-0.20/headers.cpp0000644000175000017500000005066211324003013017720 0ustar dormandodormando/****************************************************************************** * Perlbal XS HTTPHeaders class * * Written by Mark Smith (junior@sixapart.com) * * * * This program is free software; you can redistribute it and/or modify it * * under the same terms as Perl itself. * * * * Copyright 2004 Danga Interactive, Inc. * * Copyright 2005 Six Apart, Ltd. * ******************************************************************************/ #include "headers.h" #include "stdio.h" #include "stdlib.h" #include "string.h" using namespace std; /****************************************************************************** * HELPER FUNCTIONS *********************************************************** ******************************************************************************/ int skip_spaces(char **ptr) { // should be safe, as string terminates with \0, so we won't hit that // as long as we're looking to match spaces only int i = 0; while (**ptr == ' ') { i++; (*ptr)++; } return i; } int skip_to_space(char **ptr) { // safe as we stop incrementing if we hit a \n or a \0 int i = 0; while (**ptr != ' ' && **ptr != '\0') { // only increase length if this isn't an \r... we only want to count real stuff i++; (*ptr)++; } return i; } // FIXME: the following two functions can be optimized so as not to do the \r check in // the main loop; just look for \r in the while and increment *ptr by two if we have an // \r\n after the while loop... I'm too lazy to do it now int skip_to_eol(char **ptr) { // safe as we stop incrementing if we hit a \n or a \0 int i = 0; while (**ptr != '\n' && **ptr != '\0') { // only increase length if this isn't an \r... we only want to count real stuff if (**ptr != '\r') i++; (*ptr)++; } if (**ptr == '\n') (*ptr)++; return i; } int skip_to_colon(char **ptr) { // safe as we stop incrementing if we hit a colon, \n, or \0 int i = 0; while (**ptr != ':') { if (**ptr == '\r' || **ptr == '\n' || **ptr == '\0') return 0; // invalid line? make them bomb i++; (*ptr)++; } if (**ptr == ':') (*ptr)++; return i; } int parseVersionNumber(char *ptr, char **newptr) { int i = 0, j = 0; // find width of first number while (isdigit(ptr[i])) i++; if (i == 0 || i > 4 || ptr[i] != '.') return 0; // find width of second number while (isdigit(ptr[i+j+1])) j++; if (j == 0 || j > 4) return 0; // update newptr with data *newptr = (ptr + i + j + 1); // now extract into ret int ret = atoi(ptr) * 1000 + atoi(ptr+i+1); return ret; } /****************************************************************************** * HTTPHEADERS CLASS ********************************************************** ******************************************************************************/ HTTPHeaders::HTTPHeaders() { /* initialize our internal data */ versionNumber = 0; statusCode = 0; headersType = 0; method = 0; sv_uri = NULL; sv_firstLine = NULL; sv_methodString = NULL; hdrs = NULL; hdrtail = NULL; } HTTPHeaders::~HTTPHeaders() { if (sv_uri) { SvREFCNT_dec(sv_uri); } if (sv_firstLine) { SvREFCNT_dec(sv_firstLine); } if (sv_methodString) { SvREFCNT_dec(sv_methodString); } /* free header structs we're using */ Header *next = NULL; while (hdrs) { next = hdrs->next; freeHeader(hdrs); hdrs = next; } } void HTTPHeaders::freeHeader(Header *hdr) { // now free this header Safefree(hdr->key); SvREFCNT_dec(hdr->sv_value); Safefree(hdr); } int HTTPHeaders::parseHeaders(SV *headers) { // make sure headers is a reference if (!SvROK(headers)) return 0; // setup variables we're going to use int state = 0; // 0 = parsing first line, 1 = parsing headers int len = 0; char *initial = SvPV_nolen(SvRV(headers)); // point to the beginning of headers char *pptr, *ptr = initial; Header *lasthdr = NULL; // loop while we haven't hit the end while (*ptr != '\0') { // state 0 is when we haven't gotten anything and we're reading in // the first line for processing if (state == 0) { if (!strncmp(ptr, "HTTP/", 5)) { headersType = H_RESPONSE; // FIXME: this probably isn't safe if the headers are really short // because we're just randomly referencing into headers versionNumber = parseVersionNumber(ptr + 5, &ptr); if (versionNumber <= 0) return 0; // now we want to get the code, which should be next after some spaces skip_spaces(&ptr); // get the code statusCode = strtol(ptr, &ptr, 10); // now skip to the end of line skip_to_eol(&ptr); // now copy our first line. we do this weird thing with \r and \n in order // to remove any trailing \r\ns from our first line. len = ptr - initial; while (initial[len - 1] == '\r' || initial[len - 1] == '\n') len--; sv_firstLine = newSVpvn(initial, len); if (!sv_firstLine) return 0; // now continue on to doing actual header parsing state = 1; continue; } // must be a request headersType = H_REQUEST; if (!strncmp(ptr, "GET ", 4)) { ptr += 4; method = M_GET; } else if (!strncmp(ptr, "POST ", 5)) { ptr += 5; method = M_POST; } else if (!strncmp(ptr, "HEAD ", 5)) { ptr += 5; method = M_HEAD; } else if (!strncmp(ptr, "OPTIONS ", 8)) { ptr += 8; method = M_OPTIONS; } else if (!strncmp(ptr, "PUT ", 4)) { ptr += 4; method = M_PUT; } else if (!strncmp(ptr, "DELETE ", 7)) { ptr += 7; method = M_DELETE; } else { pptr = ptr; len = skip_to_space(&ptr); if (len) { sv_methodString = newSVpvn(pptr, len); if (!sv_methodString) return 0; } else { // nothing, error return 0; } skip_spaces(&ptr); } // now we need to read in the URI pptr = ptr; len = skip_to_space(&ptr); if (len) { // now get the URI sv_uri = newSVpvn(pptr, len); if (!sv_uri) return 0; } // now we need to determine the version skip_spaces(&ptr); if (!strncmp(ptr, "HTTP/", 5)) { // FIXME: this probably isn't safe if the headers are really short // because we're just randomly referencing into headers versionNumber = parseVersionNumber(ptr + 5, &ptr); if (versionNumber <= 0) return 0; skip_to_eol(&ptr); // now copy our first line. we do this weird thing with \r and \n in order // to remove any trailing \r\ns from our first line. len = ptr - initial; while (initial[len - 1] == '\r' || initial[len - 1] == '\n') len--; sv_firstLine = newSVpvn(initial, len); if (!sv_firstLine) return 0; } else { return 0; } // cool, start parsing the headers now state = 1; } else if (state == 1) { // if it starts with space or tab then go ahead and append to previous header if (*ptr == ' ' || *ptr == '\t') { // we have to have lasthdr, or something drastically bad happened if (!lasthdr) return 0; // get the whole line, the whole thing is just being appended pptr = ptr; len = skip_to_eol(&ptr); // len should never be 0 in this case, but in case it is... if (!len) return 0; // append this data to the end sv_catpv(lasthdr->sv_value, "\r\n"); sv_catpvn(lasthdr->sv_value, pptr, len); continue; } // normal case; we're going to get something. first see if we're up against a blank line // or the end of string marker, and if so, we're done (but successfully!) if (*ptr == '\r' || *ptr == '\n' || *ptr == '\0') return 1; // now let's find a colon if we can pptr = ptr; len = skip_to_colon(&ptr); // if skip_to_colon returns 0, it hit the end with no colon, so this isn't a valid request if (!len) return 0; // jump 'ptr' to the beginning of this line's data skip_spaces(&ptr); // now see if we have another copy of this header already Header *hdr = findHeader(pptr, len); if (hdr) { // basically, responses can have Set-Cookie headers... if we're in a response // and handling a Set-Cookie header, we just want to append it to our header // list like normal. in requests, or in non-Set-Cookie headers, we want to // append to our previous header if (isRequest() || strncasecmp(hdr->key, "Set-Cookie", len)) { // find out how long this line is pptr = ptr; len = skip_to_eol(&ptr); // simply append ", " and our data sv_catpvn(hdr->sv_value, ", ", 2); sv_catpvn(hdr->sv_value, pptr, len); continue; } } // now create a new header to store this line's data New(0, hdr, 1, Header); if (!hdr) return 0; Poison(hdr, 1, Header); // set it up hdr->keylen = len; hdr->prev = NULL; hdr->next = NULL; hdr->key = NULL; hdr->sv_value = NULL; hdrtail = hdr; // copy in the header name... note we don't have to insert a null // at the end of hdr->key because we use Newz which zeros the allocated space Newz(0, hdr->key, len + 1, char); if (!hdr->key) return 0; Copy(pptr, hdr->key, len, char); // and jump to the end of the line, fail if we got nothing pptr = ptr; len = skip_to_eol(&ptr); // copy this as our value hdr->sv_value = newSVpvn(pptr, len); if (!hdr->sv_value) return 0; // now insert this into our list if (lasthdr) { hdr->prev = lasthdr; lasthdr->next = hdr; lasthdr = hdr; } else { hdrs = hdr; lasthdr = hdr; } } } // if we get here we're done, so return state return state; } SV *HTTPHeaders::getReconstructed() { // reconstitute the header we got... pretty much just firstLine + all the headers SV *res = newSVpvn("", 0); if (!res) return &PL_sv_undef; SvGROW(res, 768); // print in the first line if (!sv_firstLine) { SvREFCNT_dec(res); return &PL_sv_undef; } sv_catsv(res, sv_firstLine); sv_catpv(res, "\r\n"); // now over each header for (Header *cur = hdrs; cur; cur = cur->next) { if (!cur->key) { SvREFCNT_dec(res); return &PL_sv_undef; } sv_catpv(res, cur->key); sv_catpv(res, ": "); if (!cur->sv_value) { SvREFCNT_dec(res); return &PL_sv_undef; } sv_catsv(res, cur->sv_value); sv_catpv(res, "\r\n"); } // tack on final \r\n sv_catpv(res, "\r\n"); // return our scalar return res; } Header *HTTPHeaders::findHeader(char *which, int len) { // make sure we got something if (!which) return NULL; int wlen = len ? len : strlen(which); if (!wlen) return NULL; // now iterate and find the header for (Header *cur = hdrs; cur; cur = cur->next) { // very fast shortcut; check lengths which will rule out most of the // headers that we have in our list, as most don't share a length if (wlen != cur->keylen) continue; // do a bytewise comparison... if (!strncasecmp(cur->key, which, wlen)) return cur; } // failure return NULL; } SV *HTTPHeaders::getHeader(char *which) { Header *hdr = findHeader(which); if (!hdr) return &PL_sv_undef; // return a reference to our sv after incrementing its refcount SvREFCNT_inc(hdr->sv_value); return hdr->sv_value; } void HTTPHeaders::setHeader(char *which, char *value) { Header *hdr = findHeader(which); // now get the length of value int vlen = value ? strlen(value) : 0; // behavior changes depending on whether we're setting or unsetting if (vlen) { // if we have no header in the lineup, we need to create one and stick it on the end if (!hdr) { // nope, create a new one New(0, hdr, 1, Header); if (!hdr) return; // FIXME: way to report error here? :/ Poison(hdr, 1, Header); // initialize this header hdr->key = NULL; hdr->keylen = 0; hdr->prev = NULL; hdr->next = NULL; hdr->sv_value = NULL; // link this in (hdrtail becomes our prev, us its next, we the new tail) // don't you love dealing with everything manually? if (hdrtail) { hdrtail->next = hdr; hdr->prev = hdrtail; } if (!hdrs) hdrs = hdr; hdrtail = hdr; } // free up header value, as we're giving it a new one if (hdr->sv_value) { SvREFCNT_dec(hdr->sv_value); } // now copy the new value hdr->sv_value = newSVpvn(value, vlen); if (!hdr->sv_value) return; // FIXME: as above, error? // free up old key if we had one if (hdr->key) { Safefree(hdr->key); } // copy in the header name int wlen = strlen(which); Newz(0, hdr->key, wlen + 1, char); Copy(which, hdr->key, wlen, char); hdr->keylen = wlen; } else { // return if we don't have a header (unset what doesn't exist? sure thing!) if (!hdr) return; // no value, so they're removing it if (hdr->prev) { // previous implies we're a link in the chain, so point our previous // header to point at the next one past us (drop us from the link) hdr->prev->next = hdr->next; } else { // no previous, so this was the head header hdrs = hdr->next; } // and now update our next to point to our previous... if (hdr->next) { // we have someone after us, point them up at the top hdr->next->prev = hdr->prev; } else { // nothing past us, so we were the last header, so point hdrtail at // the one before us now hdrtail = hdr->prev; } freeHeader(hdr); } } int HTTPHeaders::getMethod() { return method; } SV *HTTPHeaders::getMethodString() { if (sv_methodString) { SvREFCNT_inc(sv_methodString); return sv_methodString; } else return &PL_sv_undef; } int HTTPHeaders::getStatusCode() { return statusCode; } int HTTPHeaders::getVersionNumber() { return versionNumber; } bool HTTPHeaders::isRequest() { return headersType == H_REQUEST; } bool HTTPHeaders::isResponse() { return headersType == H_RESPONSE; } SV *HTTPHeaders::getURI() { if (sv_uri) { SvREFCNT_inc(sv_uri); return sv_uri; } else return &PL_sv_undef; } SV *HTTPHeaders::getHeadersList() { if (hdrs) { AV *header_names = (AV*) sv_2mortal((SV*)newAV()); for (Header *cur = hdrs; cur; cur = cur->next) { av_push(header_names, newSVpv(cur->key, cur->keylen)); } return newRV((SV*)header_names); } else return &PL_sv_undef; } SV *HTTPHeaders::setURI(char *uri) { int urilen = uri ? strlen(uri) : 0; SV *temp_uri = newSVpvn(uri, urilen); if (!temp_uri) return &PL_sv_undef; // Select which method we're using and turn it into a string const char *methodstr; switch(method) { case M_GET: methodstr = "GET"; break; case M_POST: methodstr = "POST"; break; case M_OPTIONS: methodstr = "OPTIONS"; break; case M_PUT: methodstr = "PUT"; break; case M_DELETE: methodstr = "DELETE"; break; case M_HEAD: methodstr = "HEAD"; break; default: if (sv_methodString) { methodstr = SvPV_nolen(sv_methodString); break; } else return &PL_sv_undef; } // Reconstruct the first line SV *temp_firstLine; if (versionNumber) temp_firstLine = newSVpvf("%s %s HTTP/%d.%d", methodstr, uri, int(versionNumber / 1000), versionNumber % 1000); else temp_firstLine = newSVpvf("%s %s", methodstr, uri); // Overwrite the SVs we were preparing if (sv_uri) SvREFCNT_dec(sv_uri); sv_uri = temp_uri; if (sv_firstLine) SvREFCNT_dec(sv_firstLine); sv_firstLine = temp_firstLine; // Increment refcount and put sv_uri on the return stack to indicate success. SvREFCNT_inc(sv_uri); return sv_uri; } void HTTPHeaders::setStatusCode(int code) { statusCode = code; } void HTTPHeaders::setCodeText(int code, char *codetext) { // only if response if (isRequest()) return; // nothing if they're the same if (statusCode == code) return; // verify we have a line (already got headers) if (!sv_firstLine) return; // set and rebuild sv_firstLine statusCode = code; SV *temp = newSVpvf("HTTP/%d.%d %d %s", int(versionNumber / 1000), versionNumber % 1000, code, codetext); // save our new line, get rid of old one SvREFCNT_dec(sv_firstLine); sv_firstLine = temp; } void HTTPHeaders::setVersionNumber(int version) { // if we don't have a first line, die if (!sv_firstLine) return; // generate new sv with new HTTP/ etc SV *temp = newSVpvf("HTTP/%d.%d", int(version / 1000), version % 1000); char *initial = SvPV_nolen(sv_firstLine); char *ptr = initial; // variable codepaths if (isResponse()) { // responses are easy... find first space, and concat from that point on // onto the end of temp skip_to_space(&ptr); sv_catpv(temp, ptr); } else { // requests are more difficult, we have to find the last space... skip_to_space(&ptr); skip_spaces(&ptr); skip_to_space(&ptr); skip_spaces(&ptr); // now create in temp2 what we need SV *temp2 = newSVpvn(initial, ptr - initial); sv_catsv(temp2, temp); SvREFCNT_dec(temp); temp = temp2; } // free up our first line, it's now temp SvREFCNT_dec(sv_firstLine); sv_firstLine = temp; // store for people to get at versionNumber = version; } Perlbal-XS-HTTPHeaders-0.20/MANIFEST0000644000175000017500000000040211324003637016731 0ustar dormandodormandoChanges HTTPHeaders.xs Makefile.PL MANIFEST ppport.h README headers.cpp headers.h typemap t/HTTPHeaders.t fallback/const-c.inc fallback/const-xs.inc lib/Perlbal/XS/HTTPHeaders.pm META.yml Module meta-data (added by MakeMaker) Perlbal-XS-HTTPHeaders-0.20/t/0000755000175000017500000000000011324006271016044 5ustar dormandodormandoPerlbal-XS-HTTPHeaders-0.20/t/HTTPHeaders.t0000644000175000017500000001372411323752357020327 0ustar dormandodormando# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl HTTPHeaders.t' ######################### # change 'tests => 2' to 'tests => last_test_to_print'; #die('update use test more line'); use Test::More tests => 40; BEGIN { use_ok('Perlbal::XS::HTTPHeaders') }; my $fail = 0; foreach my $constname (qw( H_REQUEST H_RESPONSE M_DELETE M_GET M_OPTIONS M_POST M_PUT M_HEAD)) { next if (eval "my \$a = $constname; 1"); if ($@ =~ /^Your vendor has not defined HTTPHeaders macro $constname/) { print "# pass: $@"; } else { print "# fail: $@"; $fail = 1; } } ok( $fail == 0 , 'Constants' ); ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. ################################################################################ ## create some headers for future testing my $reqstr = "GET / HTTP/1.1\r\nAccept: */*\r\nReferer: http://10.0.1.2/login.bml\r\nAccept-Language: en-us\r\nAccept-Encoding: gzip, deflate\r\nUser-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)\r\nHost: 10.0.1.2\r\nConnection: Keep-Alive\r\nCookie: ljsession=ws:test:8:1nB88NhuYz; BMLschemepref=dystopia\r\n\r\n"; my $resstr = "HTTP/1.0 200 OK\r\nContent-type: text/html\r\nContent-length: 15\r\nContent-language: en\r\nConnection: close\r\nDate: Mon, 25 Oct 2004 06:18:35 GMT\r\nETag: \"c756d7656d27e81f06e1ed31c2b47392\"\r\nServer: Apache/1.3.31 (Debian GNU/Linux) mod_perl/1.29\r\n\r\n"; ################################################################################ ## make sure we can create a headers object my $hdr = Perlbal::XS::HTTPHeaders->new(\$reqstr); isa_ok($hdr, 'Perlbal::XS::HTTPHeaders'); ################################################################################ ## verify that we parsed it right is($hdr->getReconstructed(), $reqstr, 'request 1 reconstruction (1)'); is($hdr->getHeader('Referer'), "http://10.0.1.2/login.bml", 'header retrieval 1'); is($hdr->getHeader('Host'), "10.0.1.2", 'header retrieval 2'); is($hdr->getHeader('Not-Real'), undef, 'header retrieval 3'); is($hdr->getReconstructed(), $reqstr, 'request 1 reconstruction (2)'); ################################################################################ ## do some more header parsing etc $hdr->setHeader('Host', 'random garbage'); is($hdr->getHeader('Host'), 'random garbage', 'header retrieval 4'); is($hdr->getHeader('host'), 'random garbage', 'header retrieval 5'); is($hdr->getHeader('HOST'), 'random garbage', 'header retrieval 6'); isnt($hdr->getReconstructed(), $reqstr, 'request 1 reconstruction (3)'); $hdr->setHeader('Host', '10.0.1.2'); is($hdr->getHeader('Host'), "10.0.1.2", 'header retrieval 8'); is($hdr->getReconstructed(), $reqstr, 'request 1 reconstruction (4)'); isnt($hdr->getURI(), "/foo.txt", "Haven't set the uri yet"); unlike($hdr->to_string(), qr{^GET /foo\.txt}, "First line doesn't contain foo.txt"); $hdr->setURI('/foo.txt'); is($hdr->getURI(), "/foo.txt", "We set the uri now"); like($hdr->to_string(), qr{^GET /foo\.txt}, "First line does contain foo.txt"); isnt($hdr->request_uri(), "/bar.txt", "Haven't set the uri yet"); unlike($hdr->to_string(), qr{^GET /bar\.txt}, "First line doesn't contain bar.txt"); $hdr->set_request_uri('/bar.txt'); is($hdr->request_uri(), "/bar.txt", "We set the uri now"); like($hdr->to_string(), qr{^GET /bar\.txt}, "First line does contain bar.txt"); my $headers_list = $hdr->headers_list; is_deeply([sort @$headers_list], [qw/ Accept Accept-Encoding Accept-Language Connection Cookie Host Referer User-Agent /], 'headers_list'); ################################################################################ ## and yet some more $hdr->setHeader('Host', undef); is($hdr->getHeader('Host'), undef, 'header retrieval 7'); $hdr->setHeader('Host', '10.0.1.2'); is($hdr->getHeader('Host'), '10.0.1.2', 'header retrieval 8'); ################################################################################ ## let's test out reference stuff $hdr = Perlbal::XS::HTTPHeaders->new(\$resstr); isa_ok($hdr, 'Perlbal::XS::HTTPHeaders'); is($hdr->to_string, $resstr, 'response 1 reconstruction (1)'); my $ref = $hdr->to_string_ref; is($$ref, $resstr, 'response 1 reconstruction (2)'); ################################################################################ ## new_response testing $hdr = Perlbal::XS::HTTPHeaders->new_response(304); isa_ok($hdr, 'Perlbal::XS::HTTPHeaders'); is($hdr->getStatusCode(), 304, 'new_response test 1'); is($hdr->getHeader('Test'), undef, 'new_response test 2'); $hdr->setHeader('Test', 'Testing'); is($hdr->getHeader('Test'), 'Testing', 'new_response test 3'); $hdr->setHeader('Test', undef); is($hdr->getHeader('Test'), undef, 'new_response test 4'); ################################################################################ ## make sure we can't get the old style invalid headers $hdr = Perlbal::XS::HTTPHeaders->new(\"HTTP/"); is($hdr, undef, 'old bad header test'); ################################################################################ ## check mapping from old to new Perlbal::XS::HTTPHeaders::enable(); $hdr = Perlbal::HTTPHeaders->new(\$reqstr); isa_ok($hdr, 'Perlbal::XS::HTTPHeaders'); $hdr = Perlbal::HTTPHeaders->new(\$resstr); isa_ok($hdr, 'Perlbal::XS::HTTPHeaders'); ################################################################################ ## regression test to make sure this bug isn't reintroduced $hdr = Perlbal::XS::HTTPHeaders->new(\"GET / HTTP/1.0\r\nHost: dog\r\n\r\n"); my $a = $hdr->getReconstructed(); $hdr->header('Host', undef); $a = $hdr->getReconstructed(); $hdr->header('Cat', 'dog'); $a = $hdr->getReconstructed(); is(1, 1, 'regression test 1'); # test setting codetext $hdr = Perlbal::XS::HTTPHeaders->new_response(404); ok($hdr->getStatusCode() == 404, "code is 404"); $hdr->code(200, undef); ok($hdr->getStatusCode() == 200, "code changed to 200"); like($hdr->to_string, qr/200 OK/, "firstLine set fine"); # vim: filetype=perl Perlbal-XS-HTTPHeaders-0.20/typemap0000644000175000017500000000153711323752360017217 0ustar dormandodormandoTYPEMAP HTTPHeaders * HTTPHEADERS_REF char * STRINGMAYBEUNDEF OUTPUT HTTPHEADERS_REF // used to use "CLASS" sv_setref_pv( $arg, "Perlbal::XS::HTTPHeaders", (void*)$var ); STRINGMAYBEUNDEF warn(\"${Package}::$func_name() -- UNABLE TO RETURN CHAR *\"); INPUT HTTPHEADERS_REF if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV($arg)); else { warn(\"${Package}::$func_name() -- $var is not a blessed SV reference\"); XSRETURN_UNDEF; } STRINGMAYBEUNDEF if ($arg == &PL_sv_undef) $var = NULL; else $var = (char *)SvPV_nolen($arg); Perlbal-XS-HTTPHeaders-0.20/ppport.h0000644000175000017500000007214111323752360017311 0ustar dormandodormando /* ppport.h -- Perl/Pollution/Portability Version 2.011 * * Automatically Created by Devel::PPPort on Sun Oct 24 12:49:39 2004 * * Do NOT edit this file directly! -- Edit PPPort.pm instead. * * Version 2.x, Copyright (C) 2001, Paul Marquess. * Version 1.x, Copyright (C) 1999, Kenneth Albanowski. * This code may be used and distributed under the same license as any * version of Perl. * * This version of ppport.h is designed to support operation with Perl * installations back to 5.004, and has been tested up to 5.8.1. * * If this version of ppport.h is failing during the compilation of this * module, please check if a newer version of Devel::PPPort is available * on CPAN before sending a bug report. * * If you are using the latest version of Devel::PPPort and it is failing * during compilation of this module, please send a report to perlbug@perl.com * * Include all following information: * * 1. The complete output from running "perl -V" * * 2. This file. * * 3. The name & version of the module you were trying to build. * * 4. A full log of the build that failed. * * 5. Any other information that you think could be relevant. * * * For the latest version of this code, please retreive the Devel::PPPort * module from CPAN. * */ /* * In order for a Perl extension module to be as portable as possible * across differing versions of Perl itself, certain steps need to be taken. * Including this header is the first major one, then using dTHR is all the * appropriate places and using a PL_ prefix to refer to global Perl * variables is the second. * */ /* If you use one of a few functions that were not present in earlier * versions of Perl, please add a define before the inclusion of ppport.h * for a static include, or use the GLOBAL request in a single module to * produce a global definition that can be referenced from the other * modules. * * Function: Static define: Extern define: * newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL * */ /* To verify whether ppport.h is needed for your module, and whether any * special defines should be used, ppport.h can be run through Perl to check * your source code. Simply say: * * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc] * * The result will be a list of patches suggesting changes that should at * least be acceptable, if not necessarily the most efficient solution, or a * fix for all possible problems. It won't catch where dTHR is needed, and * doesn't attempt to account for global macro or function definitions, * nested includes, typemaps, etc. * * In order to test for the need of dTHR, please try your module under a * recent version of Perl that has threading compiled-in. * */ /* #!/usr/bin/perl @ARGV = ("*.xs") if !@ARGV; %badmacros = %funcs = %macros = (); $replace = 0; foreach () { $funcs{$1} = 1 if /Provide:\s+(\S+)/; $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/; $replace = $1 if /Replace:\s+(\d+)/; $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/; $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/; } foreach $filename (map(glob($_),@ARGV)) { unless (open(IN, "<$filename")) { warn "Unable to read from $file: $!\n"; next; } print "Scanning $filename...\n"; $c = ""; while () { $c .= $_; } close(IN); $need_include = 0; %add_func = (); $changes = 0; $has_include = ($c =~ /#.*include.*ppport/m); foreach $func (keys %funcs) { if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) { if ($c !~ /\b$func\b/m) { print "If $func isn't needed, you don't need to request it.\n" if $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m); } else { print "Uses $func\n"; $need_include = 1; } } else { if ($c =~ /\b$func\b/m) { $add_func{$func} =1 ; print "Uses $func\n"; $need_include = 1; } } } if (not $need_include) { foreach $macro (keys %macros) { if ($c =~ /\b$macro\b/m) { print "Uses $macro\n"; $need_include = 1; } } } foreach $badmacro (keys %badmacros) { if ($c =~ /\b$badmacro\b/m) { $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm); print "Uses $badmacros{$badmacro} (instead of $badmacro)\n"; $need_include = 1; } } if (scalar(keys %add_func) or $need_include != $has_include) { if (!$has_include) { $inc = join('',map("#define NEED_$_\n", sort keys %add_func)). "#include \"ppport.h\"\n"; $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m; } elsif (keys %add_func) { $inc = join('',map("#define NEED_$_\n", sort keys %add_func)); $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m; } if (!$need_include) { print "Doesn't seem to need ppport.h.\n"; $c =~ s/^.*#.*include.*ppport.*\n//m; } $changes++; } if ($changes) { open(OUT,">/tmp/ppport.h.$$"); print OUT $c; close(OUT); open(DIFF, "diff -u $filename /tmp/ppport.h.$$|"); while () { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; } close(DIFF); unlink("/tmp/ppport.h.$$"); } else { print "Looks OK\n"; } } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef PERL_REVISION # ifndef __PATCHLEVEL_H_INCLUDED__ # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef ERRSV # define ERRSV perl_get_sv("@",FALSE) #endif #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) /* Replace: 1 */ # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_defgv defgv # define PL_dirty dirty # define PL_dowarn dowarn # define PL_hints hints # define PL_na na # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfpv rsfp # define PL_stdingv stdingv # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes /* Replace: 0 */ #endif #ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif #else # define PERL_UNUSED_DECL #endif #ifndef dNOOP # define NOOP (void)0 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP # define dTHXa(x) dNOOP # define dTHXoa(x) dNOOP #endif #ifndef pTHX # define pTHX void # define pTHX_ # define aTHX # define aTHX_ #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif /* IV could also be a quad (say, a long long), but Perls * capable of those should have IVSIZE already. */ #if !defined(IVSIZE) && defined(LONGSIZE) # define IVSIZE LONGSIZE #endif #ifndef IVSIZE # define IVSIZE 4 /* A bold guess, but the best we can make. */ #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) #else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) #endif #define NUM2PTR(any,d) (any)(PTRV)(d) #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) #if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) #else # define PTR2ul(p) INT2PTR(unsigned long,p) #endif #endif /* !INT2PTR */ #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif #ifndef gv_stashpvn # define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) #endif #ifndef newRV_inc /* Replace: 1 */ # define newRV_inc(sv) newRV(sv) /* Replace: 0 */ #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef newRV_noinc # ifdef __GNUC__ # define newRV_noinc(sv) \ ({ \ SV *nsv = (SV*)newRV(sv); \ SvREFCNT_dec(sv); \ nsv; \ }) # else # if defined(USE_THREADS) static SV * newRV_noinc (SV * sv) { SV *nsv = (SV*)newRV(sv); SvREFCNT_dec(sv); return nsv; } # else # define newRV_noinc(sv) \ (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv) # endif # endif #endif /* Provide: newCONSTSUB */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63)) #if defined(NEED_newCONSTSUB) static #else extern void newCONSTSUB(HV * stash, char * name, SV *sv); #endif #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void newCONSTSUB(stash,name,sv) HV *stash; char *name; SV *sv; { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)) /* before 5.003_22 */ start_subparse(), #else # if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22) /* 5.003_22 */ start_subparse(0), # else /* 5.003_23 onwards */ start_subparse(FALSE, 0), # endif #endif newSVOP(OP_CONST, 0, newSVpv(name,0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* newCONSTSUB */ #ifndef START_MY_CXT /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #else /* single interpreter */ #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif #endif /* START_MY_CXT */ #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */ # define AvFILLp AvFILL #endif #ifdef SvPVbyte # if PERL_REVISION == 5 && PERL_VERSION < 7 /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */ # undef SvPVbyte # define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp)) static char * my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } # endif #else # define SvPVbyte SvPV #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_nolen(sv)) static char * sv_2pv_nolen(pTHX_ register SV *sv) { STRLEN n_a; return sv_2pv(sv, &n_a); } #endif #ifndef get_cv # define get_cv(name,create) perl_get_cv(name,create) #endif #ifndef get_sv # define get_sv(name,create) perl_get_sv(name,create) #endif #ifndef get_av # define get_av(name,create) perl_get_av(name,create) #endif #ifndef get_hv # define get_hv(name,create) perl_get_hv(name,create) #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef eval_pv # define eval_pv perl_eval_pv #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1)) #define I32_CAST #else #define I32_CAST (I32*) #endif #ifndef grok_hex static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) { NV r = scan_hex(string, *len, I32_CAST len); if (r > UV_MAX) { *flags |= PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = r; return UV_MAX; } return (UV)r; } # define grok_hex(string, len, flags, result) \ _grok_hex((string), (len), (flags), (result)) #endif #ifndef grok_oct static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) { NV r = scan_oct(string, *len, I32_CAST len); if (r > UV_MAX) { *flags |= PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = r; return UV_MAX; } return (UV)r; } # define grok_oct(string, len, flags, result) \ _grok_oct((string), (len), (flags), (result)) #endif #if !defined(grok_bin) && defined(scan_bin) static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) { NV r = scan_bin(string, *len, I32_CAST len); if (r > UV_MAX) { *flags |= PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = r; return UV_MAX; } return (UV)r; } # define grok_bin(string, len, flags, result) \ _grok_bin((string), (len), (flags), (result)) #endif #ifndef IN_LOCALE # define IN_LOCALE \ (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 # define IS_NUMBER_NOT_INT 0x04 # define IS_NUMBER_NEG 0x08 # define IS_NUMBER_INFINITY 0x10 # define IS_NUMBER_NAN 0x20 #endif #ifndef grok_numeric_radix # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send) #define grok_numeric_radix Perl_grok_numeric_radix bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1)) if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif /* PERL_VERSION */ #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif /* grok_numeric_radix */ #ifndef grok_number #define grok_number Perl_grok_number int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif /* grok_number */ #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Perlbal-XS-HTTPHeaders-0.20/Changes0000644000175000017500000000743411324003131017074 0ustar dormandodormandoRevision history for Perl extension HTTPHeaders. See README for info. 0.20 Thu Jan 14 22:08:00 PDT 2010 - allow module to be 'enabled' multiple times without error - allow all methods, but only accelerate some of them. - add setter for uri field, and test 0.19 Tue Sep 19 07:54:51 UTC 2006 - fix number of tests from 28 to 31 to enable successfull make test 0.18 Wed Jul 20 18:35:51 UTC 2005 - allow setting the status code and text - add dependency on Perlbal and Perlbal::HTTPHeaders 0.17 Tue Jul 19 13:41:23 PDT 2005 - library now inherits from Perlbal::HTTPHeaders - removed debugging code - further cleanup for CVS commit 0.16 Mon Jul 18 17:13:58 PDT 2005 - fix bug causing headers to be considered invalid when they contained no content (should be allowed, per spec) 0.15 Mon Mar 7 15:55:29 PST 2005 - cleaned up a bunch of stuff for initial public release 0.14 Tue Feb 1 10:19:28 PST 2005 - fix bug in failing to adequately reset pointers in header deletion (found by LiveJournal user nothings) - use delete instead of Safefree for object deletion (found by LiveJournal user keturner) - added debug output for object creation/deletion (for memory leak tracking) 0.13 Thu Jan 27 10:20:47 PST 2005 - added failure checks on all memory allocations - switched some Newz calls to New+Poison calls to help catch errors - fixed bug with removing the last header breaking ability to add more headers 0.12 Fri Jan 14 10:31:14 PST 2005 - fixed problem with invalid pointers in one case - fixed calling of SvREFCNT_dec on possibly NULL pointer - fixed so you can't enable XS module twice in a row with weird behavior - fixed last call to delete to be a Safefree call - removed extraneous printfs and comments from XS code 0.11 Tue Jan 11 10:41:40 PST 2005 - removed some unused variables - removed and cleaned up extraneous comments 0.10 Mon Jan 10 10:39:05 PST 2005 - fixed a memory leak in header replacement code - updated res_keep_alive function to fix bug in 1.1 keep-alive handling - revamped getReconstructed function to be more paranoid about inputs 0.09 Fri Jan 7 17:47:53 PST 2005 - fixed bug causing incorrect parsing of empty header strings 0.08 Thu Nov 4 17:16:10 PST 2004 - implemented header combining (comma separated header values) - fixed a bunch of calls to C functions in Perl code for compatibility - added a few more test cases 0.07 Wed Nov 3 17:51:56 PST 2004 - fixed segfault with returning NULL instead of Perl's undef - implemented set_version, req_keep_alive, res_keep_alive, etc - made XS interface for Perlbal to enable/disable XS headers - modified object blesser so we always bless into Perlbal::XS::HTTPHeaders 0.06 Tue Oct 26 13:26:30 PDT 2004 - fixed bug where calling setHeader to create a header failed - converted to_string_ref from Perl module to XS module - made constructor take SV * instead of char * - updated findHeader to use strncasecmp (thanks Brad) - made parseHeaders get called by XS, not automatically by new - firstLine is now an SV * 0.05 Tue Oct 26 12:14:04 PDT 2004 - modified typemap for char * to support undef inputs - made all char * returns be SV * returns 0.04 Mon Oct 25 11:36:02 PDT 2004 - implemented most of Perlbal::HTTPHeaders API in XS - fixed setHeader('Foo', '') to also remove header 0.03 Mon Oct 25 09:37:03 PDT 2004 - added to_string function that was missing - added typemap to the manifest so it's included in the package 0.02 Sun Oct 24 22:54:00 PDT 2004 - first operational beta release; almost function complete 0.01 Sun Oct 24 12:49:39 PDT 2004 - original version; created by h2xs 1.23 with options -x -n HTTPHeaders headers.h Perlbal-XS-HTTPHeaders-0.20/lib/0000755000175000017500000000000011324006271016347 5ustar dormandodormandoPerlbal-XS-HTTPHeaders-0.20/lib/Perlbal/0000755000175000017500000000000011324006271017730 5ustar dormandodormandoPerlbal-XS-HTTPHeaders-0.20/lib/Perlbal/XS/0000755000175000017500000000000011324006271020262 5ustar dormandodormandoPerlbal-XS-HTTPHeaders-0.20/lib/Perlbal/XS/HTTPHeaders.pm0000644000175000017500000001357611324006262022707 0ustar dormandodormandopackage Perlbal::XS::HTTPHeaders; use 5.008; use strict; use warnings; use Carp; require Exporter; use AutoLoader; use Perlbal; use Perlbal::HTTPHeaders; # inherit things from Perlbal::HTTPHeaders when we can our @ISA = qw(Exporter Perlbal::HTTPHeaders); # flag we set when we are enabled or disabled our $Enabled = 0; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # This allows declaration use HTTPHeaders ':all'; # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK # will save memory. our %EXPORT_TAGS = ( 'all' => [ qw( H_REQUEST H_RESPONSE M_DELETE M_GET M_OPTIONS M_POST M_PUT M_HEAD ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( H_REQUEST H_RESPONSE M_DELETE M_GET M_OPTIONS M_POST M_PUT M_HEAD ); our $VERSION = '0.20'; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. my $constname; our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; croak "&Perlbal::XS::HTTPHeaders::constant not defined" if $constname eq 'constant'; my ($error, $val) = constant($constname); if ($error) { croak $error; } { no strict 'refs'; # Fixed between 5.005_53 and 5.005_61 #XXX if ($] >= 5.00561) { #XXX *$AUTOLOAD = sub () { $val }; #XXX } #XXX else { *$AUTOLOAD = sub { $val }; #XXX } } goto &$AUTOLOAD; } require XSLoader; XSLoader::load('Perlbal::XS::HTTPHeaders', $VERSION); # create a very bare response to send to a user (mostly used internally) sub new_response { my $code = $_[1]; my $msg = $Perlbal::HTTPHeaders::HTTPCode->{$code} || ""; my $hdr = Perlbal::XS::HTTPHeaders->new(\"HTTP/1.0 $code $msg\r\n\r\n"); return $hdr; } # do some magic to determine content length sub content_length { my Perlbal::XS::HTTPHeaders $self = $_[0]; if ($self->isRequest()) { return 0 if $self->getMethod() == M_HEAD(); } else { my $code = $self->getStatusCode(); if ($code == 304 || $code == 204 || ($code >= 100 && $code <= 199)) { return 0; } } if (defined (my $clen = $self->getHeader('Content-length'))) { return $clen+0; } return undef; } sub set_version { my Perlbal::XS::HTTPHeaders $self = $_[0]; my $ver = $_[1]; die "Bogus version" unless $ver =~ /^(\d+)\.(\d+)$/; my ($ver_ma, $ver_mi) = ($1, $2); $self->setVersionNumber($ver_ma * 1000 + $ver_mi); return $self; } sub clone { return Perlbal::XS::HTTPHeaders->new( $_[0]->to_string_ref ); } ### Perlbal::XS interface implementation my @subs = qw{ new new_response DESTROY getReconstructed getHeader setHeader getMethod getStatusCode getVersionNumber setVersionNumber isRequest isResponse setStatusCode getURI setURI header to_string to_string_ref code request_method request_uri headers_list set_request_uri response_code res_keep_alive req_keep_alive set_version content_length clone http_code_english }; sub enable { return 1 if $Enabled; $Enabled = 1; *Perlbal::HTTPHeaders::new = *Perlbal::XS::HTTPHeaders::new; *Perlbal::HTTPHeaders::new_response = *Perlbal::XS::HTTPHeaders::new_response; return 1; } sub disable { return unless $Enabled; *Perlbal::HTTPHeaders::new_response = *Perlbal::HTTPHeaders::new_response_PERL; *Perlbal::HTTPHeaders::new = *Perlbal::HTTPHeaders::new_PERL; $Enabled = 0; return 1; } sub code { my Perlbal::XS::HTTPHeaders $self = shift; my ($code, $msg) = @_; $msg ||= $self->http_code_english($code); $self->setCodeText($code, $msg); } # save pointer to the old way of creating new objects $Perlbal::XSModules{headers} = 'Perlbal::XS::HTTPHeaders'; #enable(); # Preloaded methods go here. # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__ # Below is stub documentation for your module. You'd better edit it! # Right, I'm editing it. =head1 NAME Perlbal::XS::HTTPHeaders - Perlbal extension for processing HTTP headers. =head1 SYNOPSIS use HTTPHeaders; my $hdr = Perlbal::XS::HTTPHeaders->new("GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n"); if ($hdr->getMethod == M_GET()) { print "GET: ", $hdr->getURI(), "\n"; print "Connection: ", $hdr->getHeader('Connection'), "\n"; } =head1 DESCRIPTION This module is used to read HTTP headers from a string and to parse them into an internal storage format for easy access and modification. You can also ask the module to reconstitute the headers into one big string, useful if you're writing a proxy and need to read and write headers while maintaining the ability to modify individual parts of the whole. The goal is to be fast. This is a lot faster than doing all of the text processing in Perl directly, and a lot of the flexibility of Perl is maintained by implementing the library in Perl and descending from Perlbal::HTTPHeaders. =head2 Exportable constants H_REQUEST H_RESPONSE M_GET M_POST M_HEAD M_OPTIONS M_PUT M_DELETE =head1 KNOWN BUGS There are no known bugs at this time. Please report any you find! =head1 SEE ALSO Perlbal, and by extension this module, can be discussed by joining the Perlbal mailing list on http://lists.danga.com/. Please see the original HTTPHeaders module implemented entirely in Perl in the Perlbal source tree available at http://cvs.danga.com/ in the wcmtools repository perlbal/lib/Perlbal/ directory. =head1 AUTHOR Mark Smith, Ejunior@danga.comE =head1 COPYRIGHT AND LICENSE Copyright (C) 2004 by Danga Interactive, Inc. Copyright (C) 2005 by Six Apart, Ltd. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.4 or, at your option, any later version of Perl 5 you may have available. =cut Perlbal-XS-HTTPHeaders-0.20/fallback/0000755000175000017500000000000011324006271017340 5ustar dormandodormandoPerlbal-XS-HTTPHeaders-0.20/fallback/const-c.inc0000644000175000017500000001004711324005751021405 0ustar dormandodormando#define PERL_constant_NOTFOUND 1 #define PERL_constant_NOTDEF 2 #define PERL_constant_ISIV 3 #define PERL_constant_ISNO 4 #define PERL_constant_ISNV 5 #define PERL_constant_ISPV 6 #define PERL_constant_ISPVN 7 #define PERL_constant_ISSV 8 #define PERL_constant_ISUNDEF 9 #define PERL_constant_ISUV 10 #define PERL_constant_ISYES 11 #ifndef NVTYPE typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ #endif #ifndef aTHX_ #define aTHX_ /* 5.6 or later define this for threading support. */ #endif #ifndef pTHX_ #define pTHX_ /* 5.6 or later define this for threading support. */ #endif static int constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { /* Initially switch on the length of the name. */ /* When generated this function returned values for the list of names given in this section of perl code. Rather than manually editing these functions to add or remove constants, which would result in this comment and section of code becoming inaccurate, we recommend that you edit this section of code, and use it to regenerate a new set of constant functions which you then use to replace the originals. Regenerate these constant functions by feeding this entire source file to perl -x #!/usr/bin/perl -w use ExtUtils::Constant qw (constant_types C_constant XS_constant); my $types = {map {($_, 1)} qw(IV)}; my @names = (qw(H_REQUEST H_RESPONSE M_DELETE M_GET M_HEAD M_OPTIONS M_POST M_PUT)); print constant_types(); # macro defs foreach (C_constant ("Perlbal::XS::HTTPHeaders", 'constant', 'IV', $types, undef, 3, @names) ) { print $_, "\n"; # C constant subs } print "#### XS Section:\n"; print XS_constant ("Perlbal::XS::HTTPHeaders", $types); __END__ */ switch (len) { case 5: /* Names all of length 5. */ /* M_GET M_PUT */ /* Offset 2 gives the best switch position. */ switch (name[2]) { case 'G': if (memEQ(name, "M_GET", 5)) { /* ^ */ #ifdef M_GET *iv_return = M_GET; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'P': if (memEQ(name, "M_PUT", 5)) { /* ^ */ #ifdef M_PUT *iv_return = M_PUT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } break; case 6: /* Names all of length 6. */ /* M_HEAD M_POST */ /* Offset 2 gives the best switch position. */ switch (name[2]) { case 'H': if (memEQ(name, "M_HEAD", 6)) { /* ^ */ #ifdef M_HEAD *iv_return = M_HEAD; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'P': if (memEQ(name, "M_POST", 6)) { /* ^ */ #ifdef M_POST *iv_return = M_POST; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } break; case 8: if (memEQ(name, "M_DELETE", 8)) { #ifdef M_DELETE *iv_return = M_DELETE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 9: /* Names all of length 9. */ /* H_REQUEST M_OPTIONS */ /* Offset 8 gives the best switch position. */ switch (name[8]) { case 'S': if (memEQ(name, "M_OPTION", 8)) { /* S */ #ifdef M_OPTIONS *iv_return = M_OPTIONS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "H_REQUES", 8)) { /* T */ #ifdef H_REQUEST *iv_return = H_REQUEST; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } break; case 10: if (memEQ(name, "H_RESPONSE", 10)) { #ifdef H_RESPONSE *iv_return = H_RESPONSE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } Perlbal-XS-HTTPHeaders-0.20/fallback/const-xs.inc0000644000175000017500000000521011324005751021611 0ustar dormandodormandovoid constant(sv) PREINIT: #ifdef dXSTARG dXSTARG; /* Faster if we have it. */ #else dTARGET; #endif STRLEN len; int type; IV iv; /* NV nv; Uncomment this if you need to return NVs */ /* const char *pv; Uncomment this if you need to return PVs */ INPUT: SV * sv; const char * s = SvPV(sv, len); PPCODE: /* Change this to constant(aTHX_ s, len, &iv, &nv); if you need to return both NVs and IVs */ type = constant(aTHX_ s, len, &iv); /* Return 1 or 2 items. First is error message, or undef if no error. Second, if present, is found value */ switch (type) { case PERL_constant_NOTFOUND: sv = sv_2mortal(newSVpvf("%s is not a valid Perlbal::XS::HTTPHeaders macro", s)); PUSHs(sv); break; case PERL_constant_NOTDEF: sv = sv_2mortal(newSVpvf( "Your vendor has not defined Perlbal::XS::HTTPHeaders macro %s, used", s)); PUSHs(sv); break; case PERL_constant_ISIV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHi(iv); break; /* Uncomment this if you need to return NOs case PERL_constant_ISNO: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHs(&PL_sv_no); break; */ /* Uncomment this if you need to return NVs case PERL_constant_ISNV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHn(nv); break; */ /* Uncomment this if you need to return PVs case PERL_constant_ISPV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHp(pv, strlen(pv)); break; */ /* Uncomment this if you need to return PVNs case PERL_constant_ISPVN: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHp(pv, iv); break; */ /* Uncomment this if you need to return SVs case PERL_constant_ISSV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHs(sv); break; */ /* Uncomment this if you need to return UNDEFs case PERL_constant_ISUNDEF: break; */ /* Uncomment this if you need to return UVs case PERL_constant_ISUV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHu((UV)iv); break; */ /* Uncomment this if you need to return YESs case PERL_constant_ISYES: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHs(&PL_sv_yes); break; */ default: sv = sv_2mortal(newSVpvf( "Unexpected return type %d while processing Perlbal::XS::HTTPHeaders macro %s, used", type, s)); PUSHs(sv); } Perlbal-XS-HTTPHeaders-0.20/META.yml0000644000175000017500000000062211324006271017052 0ustar dormandodormando# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Perlbal-XS-HTTPHeaders version: 0.20 version_from: lib/Perlbal/XS/HTTPHeaders.pm installdirs: site requires: Perlbal: 0 Perlbal::HTTPHeaders: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30 Perlbal-XS-HTTPHeaders-0.20/HTTPHeaders.xs0000644000175000017500000001062511324003013020223 0ustar dormandodormando/****************************************************************************** * Perlbal XS HTTPHeaders class * * Written by Mark Smith (junior@sixapart.com) * * * * This program is free software; you can redistribute it and/or modify it * * under the same terms as Perl itself. * * * * Copyright 2004 Danga Interactive, Inc. * * Copyright 2005 Six Apart, Ltd. * ******************************************************************************/ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "headers.h" #include "const-c.inc" MODULE = Perlbal::XS::HTTPHeaders PACKAGE = Perlbal::XS::HTTPHeaders INCLUDE: const-xs.inc HTTPHeaders * HTTPHeaders::new( headers, junk = 0 ) SV *headers int junk CODE: RETVAL = new HTTPHeaders(); if (!RETVAL) XSRETURN_UNDEF; if (!RETVAL->parseHeaders( headers )) { delete RETVAL; XSRETURN_UNDEF; } OUTPUT: RETVAL void HTTPHeaders::DESTROY() SV * HTTPHeaders::getReconstructed() SV * HTTPHeaders::getHeader( which ) char *which void HTTPHeaders::setHeader( which, value ) char *which char *value int HTTPHeaders::getMethod() int HTTPHeaders::getStatusCode() int HTTPHeaders::getVersionNumber() void HTTPHeaders::setVersionNumber( version ) int version bool HTTPHeaders::isRequest() bool HTTPHeaders::isResponse() void HTTPHeaders::setStatusCode( code ) int code void HTTPHeaders::setCodeText( code, codetext ) int code char *codetext SV * HTTPHeaders::getURI() SV * HTTPHeaders::setURI( uri ) char *uri ################################################################################ ## setup functions that call through to our native functions; this is the ## interface definition that Perlbal expects to use when we're a replacement ## for the standard library SV * HTTPHeaders::header( which, value = NULL ) char *which char *value PROTOTYPE: $;$ CODE: // THIS is first argument, so we expect 2 or 3 if (items > 2) { THIS->setHeader( which, value ); if (GIMME_V != G_VOID && value) { RETVAL = THIS->getHeader( which ); } else { XSRETURN_UNDEF; } } else RETVAL = THIS->getHeader( which ); OUTPUT: RETVAL SV * HTTPHeaders::to_string() CODE: RETVAL = THIS->getReconstructed(); OUTPUT: RETVAL SV * HTTPHeaders::to_string_ref() CODE: SV *temp = THIS->getReconstructed(); RETVAL = newRV_noinc(temp); OUTPUT: RETVAL SV * HTTPHeaders::request_method() CODE: switch ( THIS->getMethod() ) { case M_GET: RETVAL = newSVpvn("GET", 3); break; case M_HEAD: RETVAL = newSVpvn("HEAD", 4); break; case M_POST: RETVAL = newSVpvn("POST", 4); break; case M_OPTIONS: RETVAL = newSVpvn("OPTIONS", 7); break; case M_PUT: RETVAL = newSVpvn("PUT", 3); break; case M_DELETE: RETVAL = newSVpvn("DELETE", 6); break; default: RETVAL = THIS->getMethodString(); } OUTPUT: RETVAL SV * HTTPHeaders::request_uri() CODE: RETVAL = THIS->getURI(); OUTPUT: RETVAL SV * HTTPHeaders::headers_list() CODE: RETVAL = THIS->getHeadersList(); OUTPUT: RETVAL SV * HTTPHeaders::set_request_uri( uri = NULL ) char *uri CODE: RETVAL = THIS->setURI(uri); OUTPUT: RETVAL int HTTPHeaders::response_code() CODE: RETVAL = THIS->getStatusCode(); OUTPUT: RETVAL int HTTPHeaders::version_number( value = 0 ) int value CODE: // do a set if we have 2 parameters if (items == 2) { THIS->setVersionNumber( value ); RETVAL = value; } else RETVAL = THIS->getVersionNumber(); OUTPUT: RETVAL