Net-HTTPServer-1.1.1/0002755000175000017500000000000010176251426015346 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/lib/0002755000175000017500000000000010176251426016114 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/lib/Net/0002755000175000017500000000000010176251426016642 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/lib/Net/HTTPServer/0002755000175000017500000000000010176251426020610 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/lib/Net/HTTPServer/Request.pm0000644000175000017500000002313510175477102022600 0ustar reatmonreatmon00000000000000############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 2003-2005 Ryan Eatmon # ############################################################################## package Net::HTTPServer::Request; =head1 NAME Net::HTTPServer::Request =head1 SYNOPSIS Net::HTTPServer::Request handles the parsing of a request. =head1 DESCRIPTION Net::HTTPServer::Request takes a full request, parses it, and then provides a nice OOP interface to pulling out the information you want from a request. =head1 METHODS =head2 Cookie([cookie]) Returns a hash reference of cookie/value pairs. If you specify a cookie, then it returns the value for that cookie, or undef if it does not exist. =head2 Env([var]) Returns a hash reference of variable/value pairs. If you specify a variable, then it returns the value for that variable, or undef if it does not exist. =head2 Header([header]) Returns a hash reference of header/value pairs. If you specify a header, then it returns the value for that header, or undef if it does not exist. =head2 Method() Returns the method of the request (GET,POST,etc...) =head2 Path() Returns the path portion of the URL. Does not include any query strings. =head2 Procotol() Returns the name and revision that the request came in with. =head2 Query() Returns the query portion of the URL (if any). You can combine the Path and the Query with a ? to get the real URL that the client requested. =head2 Request() Returns the entire request as a string. =head2 Response() Returns a Net::HTTPServer::Response object with various bits prefilled in. If you have created session via the Session() method, then the session will already be registered with the response. =head2 Session() Create a new Net::HTTPServer::Session object. If the cookie value is set, then the previous state values are loaded, otherwise a new session is started. =head2 URL() Returns the URL of the request. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT Copyright (c) 2003-2005 Ryan Eatmon . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Carp; use URI; use URI::QueryParam; use URI::Escape; use vars qw ( $VERSION ); $VERSION = "1.0.3"; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); my (%args) = @_; $self->{ARGS} = \%args; $self->{HEADERS} = {}; $self->{ENV} = {}; $self->{COOKIES} = {}; $self->{FAILURE} = ""; $self->{CHROOT} = $self->_arg("chroot",1); $self->{REQUEST} = $self->_arg("request",undef); $self->{SERVER} = $self->_arg("server",undef); $self->_parse() if defined($self->{REQUEST}); return $self; } sub Cookie { my $self = shift; my $cookie = shift; return $self->{COOKIES} unless defined($cookie); return unless exists($self->{COOKIES}->{$cookie}); return $self->{COOKIES}->{$cookie}; } sub Env { my $self = shift; my $env = shift; return $self->{ENV} unless defined($env); return unless exists($self->{ENV}->{$env}); return $self->{ENV}->{$env}; } sub Header { my $self = shift; my $header = shift; return $self->{HEADERS} unless defined($header); return unless exists($self->{HEADERS}->{lc($header)}); return $self->{HEADERS}->{lc($header)}; } sub Method { my $self = shift; return $self->{METHOD}; } sub Path { my $self = shift; return $self->{PATH}; } sub Protocol { my $self = shift; return $self->{PROTOCOL}; } sub Query { my $self = shift; return $self->{QUERY}; } sub Request { my $self = shift; return $self->{REQUEST}; } sub Response { my $self = shift; my $response = new Net::HTTPServer::Response(); if (exists($self->{SESSION})) { $response->Session($self->{SESSION}); } return $response; } sub Session { my $self = shift; return unless $self->{SERVER}->{CFG}->{SESSIONS}; if (!exists($self->{SESSION})) { my $cookie = $self->Cookie("NETHTTPSERVERSESSION"); $self->{SESSION} = new Net::HTTPServer::Session(key=>$cookie, server=>$self->{SERVER}, ); } return $self->{SESSION}; } sub URL { my $self = shift; return $self->{URL}; } ############################################################################### # # _arg - if the arg exists then use it, else use the default. # ############################################################################### sub _arg { my $self = shift; my $arg = shift; my $default = shift; return (exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default); } ############################################################################### # # _chroot - take the path and if we are running under chroot, massage it so # that is cannot leave DOCROOT. # ############################################################################### sub _chroot { my $self = shift; my $url = shift; return $url unless $self->{CHROOT}; my $change = 1; while( $change ) { $change = 0; #----------------------------------------------------------------- # Look for multiple / in a row and make them one / #----------------------------------------------------------------- while( $url =~ s/\/\/+/\// ) { $change = 1; } #----------------------------------------------------------------- # look for something/.. and remove it #----------------------------------------------------------------- while( $url =~ s/[^\/]+\/\.\.(\/|$)// ) { $change = 1; } #----------------------------------------------------------------- # Look for ^/.. and remove it #----------------------------------------------------------------- while( $url =~ s/^\/?\.\.(\/|$)/\// ) { $change = 1; } #----------------------------------------------------------------- # Look for /.../ and make it / #----------------------------------------------------------------- while( $url =~ s/(^|\/)\.+(\/|$)/\// ) { $change = 1; } } return $url; } sub _failure { my $self = shift; return $self->{FAILURE}; } sub _env { my $self = shift; my $env = shift; my $value = shift; $self->{ENV}->{$env} = $value; } sub _parse { my $self = shift; ($self->{METHOD},$self->{URL},$self->{PROTOCOL}) = ($self->{REQUEST} =~ /(\S+)\s+(\S+)\s+(.+?)\015?\012/s); my $uri = new URI($self->{URL},"http"); #------------------------------------------------------------------------- # What did they ask for? #------------------------------------------------------------------------- $self->{PATH} = $self->_chroot($uri->path()); my ($headers,$body) = ($self->{REQUEST} =~ /^(.+?)\015?\012\015?\012(.*?)$/s); my $last_header = ""; foreach my $header (split(/[\r\n]+/,$headers)) { my $folded; my $key; my $value; ($folded,$value) = ($header =~ /^(\s*)(.+?)\s*$/); if ($folded ne "") { $self->{HEADERS}->{lc($last_header)} .= $value; next; } ($key,$value) = ($header =~ /^([^\:]+?)\s*\:\s*(.+?)\s*$/); next unless defined($key); $last_header = $key; $self->{HEADERS}->{lc($key)} = $value; if ((lc($key) eq "expect") && ($value ne "100-continue")) { $self->{FAILURE} = "expect"; return; } } #------------------------------------------------------------------------- # Did they send any ?xxx=yy on the URL? #------------------------------------------------------------------------- $self->{QUERY} = $uri->query(); foreach my $key ($uri->query_param()) { $self->{ENV}->{$key} = $uri->query_param($key); } #------------------------------------------------------------------------- # If this was POST, then the body contains more xxx=yyyy #------------------------------------------------------------------------- if ($self->{METHOD} eq "POST") { my $post_uri = new URI("?$body","http"); foreach my $key ($post_uri->query_param()) { $self->{ENV}->{$key} = $post_uri->query_param($key); } } #------------------------------------------------------------------------- # Finally, parse out any cookies. #------------------------------------------------------------------------- if (exists($self->{HEADERS}->{cookie})) { foreach my $cookie ( split( /\s*;\s*/,$self->{HEADERS}->{cookie}) ) { my ($name,$value) = split("=",$cookie,2); $self->{COOKIES}->{$name} = uri_unescape($value); } } } 1; Net-HTTPServer-1.1.1/lib/Net/HTTPServer/mime.types0000644000175000017500000004152210124076512022621 0ustar reatmonreatmon00000000000000############################################################################### # # MIME-TYPES and the extensions that represent them # # This file is part of the "mime-support" package. Please send email (not a # bug report) to mime-support@packages.debian.org if you would like new types # and/or extensions to be added. # # Users can add their own types if they wish by creating a ".mime.types" # file in their home directory. Definitions included there will take # precedence over those listed here. # # Note: Compression schemes like "gzip", "bzip", and "compress" are not # actually "mime-types". They are "encodings" and hence must _not_ have # entries in this file to map their extensions. The "mime-type" of an # encoded file refers to the type of data that has been encoded, not the # type of the encoding. # ############################################################################### application/activemessage application/andrew-inset ez application/applefile application/atomicmail application/batch-SMTP application/beep+xml application/cals-1840 application/commonground application/cu-seeme csm cu application/cybercash application/dca-rft application/dec-dx application/dsptype tsp application/dvcs application/edi-consent application/edifact application/edi-x12 application/eshop application/font-tdpfr application/futuresplash spl application/ghostview application/hta hta application/http application/hyperstudio application/iges application/index application/index.cmd application/index.obj application/index.response application/index.vnd application/iotp application/ipp application/isup application/mac-compactpro cpt application/marc application/mac-binhex40 hqx application/macwriteii application/mathematica nb application/mathematica-old application/msaccess mdb application/msword doc dot application/news-message-id application/news-transmission application/octet-stream bin application/ocsp-request application/ocsp-response application/oda oda application/ogg ogg application/parityfec application/pics-rules prf application/pgp-encrypted application/pgp-keys key application/pdf pdf application/pgp-signature pgp application/pkcs10 application/pkcs7-mime application/pkcs7-signature application/pkix-cert application/pkixcmp application/pkix-crl application/postscript ps ai eps application/prs.alvestrand.titrax-sheet application/prs.cww application/prs.nprend application/qsig application/riscos application/remote-printing application/rss+xml rss application/rtf rtf application/sdp application/set-payment application/set-payment-initiation application/set-registration application/set-registration-initiation application/sgml application/sgml-open-catalog application/sieve application/slate application/smil smi smil application/timestamp-query application/timestamp-reply application/vemmi application/whoispp-query application/whoispp-response application/wita application/wordperfect5.1 wp5 application/x400-bp application/xhtml+xml xht xhtml application/xml application/xml-dtd application/xml-external-parsed-entity application/zip zip application/vnd.3M.Post-it-Notes application/vnd.accpac.simply.aso application/vnd.accpac.simply.imp application/vnd.acucobol application/vnd.aether.imp application/vnd.anser-web-certificate-issue-initiation application/vnd.anser-web-funds-transfer-initiation application/vnd.audiograph application/vnd.bmi application/vnd.businessobjects application/vnd.canon-cpdl application/vnd.canon-lips application/vnd.cinderella cdy application/vnd.claymore application/vnd.commerce-battelle application/vnd.commonspace application/vnd.comsocaller application/vnd.contact.cmsg application/vnd.cosmocaller application/vnd.ctc-posml application/vnd.cups-postscript application/vnd.cups-raster application/vnd.cups-raw application/vnd.cybank application/vnd.dna application/vnd.dpgraph application/vnd.dxr application/vnd.ecdis-update application/vnd.ecowin.chart application/vnd.ecowin.filerequest application/vnd.ecowin.fileupdate application/vnd.ecowin.series application/vnd.ecowin.seriesrequest application/vnd.ecowin.seriesupdate application/vnd.enliven application/vnd.epson.esf application/vnd.epson.msf application/vnd.epson.quickanime application/vnd.epson.salt application/vnd.epson.ssf application/vnd.ericsson.quickcall application/vnd.eudora.data application/vnd.fdf application/vnd.ffsns application/vnd.flographit application/vnd.framemaker application/vnd.fsc.weblaunch application/vnd.fujitsu.oasys application/vnd.fujitsu.oasys2 application/vnd.fujitsu.oasys3 application/vnd.fujitsu.oasysgp application/vnd.fujitsu.oasysprs application/vnd.fujixerox.ddd application/vnd.fujixerox.docuworks application/vnd.fujixerox.docuworks.binder application/vnd.fut-misnet application/vnd.grafeq application/vnd.groove-account application/vnd.groove-identity-message application/vnd.groove-injector application/vnd.groove-tool-message application/vnd.groove-tool-template application/vnd.groove-vcard application/vnd.hhe.lesson-player application/vnd.hp-HPGL application/vnd.hp-PCL application/vnd.hp-PCLXL application/vnd.hp-hpid application/vnd.hp-hps application/vnd.httphone application/vnd.hzn-3d-crossword application/vnd.ibm.MiniPay application/vnd.ibm.afplinedata application/vnd.ibm.modcap application/vnd.informix-visionary application/vnd.intercon.formnet application/vnd.intertrust.digibox application/vnd.intertrust.nncp application/vnd.intu.qbo application/vnd.intu.qfx application/vnd.irepository.package+xml application/vnd.is-xpr application/vnd.japannet-directory-service application/vnd.japannet-jpnstore-wakeup application/vnd.japannet-payment-wakeup application/vnd.japannet-registration application/vnd.japannet-registration-wakeup application/vnd.japannet-setstore-wakeup application/vnd.japannet-verification application/vnd.japannet-verification-wakeup application/vnd.koan application/vnd.lotus-1-2-3 application/vnd.lotus-approach application/vnd.lotus-freelance application/vnd.lotus-notes application/vnd.lotus-organizer application/vnd.lotus-screencam application/vnd.lotus-wordpro application/vnd.mcd application/vnd.mediastation.cdkey application/vnd.meridian-slingshot application/vnd.mif mif application/vnd.minisoft-hp3000-save application/vnd.mitsubishi.misty-guard.trustweb application/vnd.mobius.daf application/vnd.mobius.dis application/vnd.mobius.msl application/vnd.mobius.plc application/vnd.mobius.txf application/vnd.motorola.flexsuite application/vnd.motorola.flexsuite.adsi application/vnd.motorola.flexsuite.fis application/vnd.motorola.flexsuite.gotap application/vnd.motorola.flexsuite.kmr application/vnd.motorola.flexsuite.ttc application/vnd.motorola.flexsuite.wem application/vnd.mozilla.xul+xml application/vnd.ms-artgalry application/vnd.ms-asf application/vnd.ms-excel xls xlb application/vnd.ms-lrm application/vnd.ms-pki.seccat cat application/vnd.ms-pki.stl stl application/vnd.ms-powerpoint ppt pps pot application/vnd.ms-project application/vnd.ms-tnef application/vnd.ms-works application/vnd.mseq application/vnd.msign application/vnd.music-niff application/vnd.musician application/vnd.netfpx application/vnd.noblenet-directory application/vnd.noblenet-sealer application/vnd.noblenet-web application/vnd.novadigm.EDM application/vnd.novadigm.EDX application/vnd.novadigm.EXT application/vnd.osa.netdeploy application/vnd.palm application/vnd.pg.format application/vnd.pg.osasli application/vnd.powerbuilder6 application/vnd.powerbuilder6-s application/vnd.powerbuilder7 application/vnd.powerbuilder7-s application/vnd.powerbuilder75 application/vnd.powerbuilder75-s application/vnd.previewsystems.box application/vnd.publishare-delta-tree application/vnd.pvi.ptid1 application/vnd.pwg-xhtml-print+xml application/vnd.rapid application/vnd.s3sms application/vnd.seemail application/vnd.shana.informed.formdata application/vnd.shana.informed.formtemplate application/vnd.shana.informed.interchange application/vnd.shana.informed.package application/vnd.sss-cod application/vnd.sss-dtf application/vnd.sss-ntf application/vnd.stardivision.calc sdc application/vnd.stardivision.draw sda application/vnd.stardivision.impress sdd sdp application/vnd.stardivision.math smf application/vnd.stardivision.writer sdw vor application/vnd.stardivision.writer-global sgl application/vnd.street-stream application/vnd.sun.xml.calc sxc application/vnd.sun.xml.calc.template stc application/vnd.sun.xml.draw sxd application/vnd.sun.xml.draw.template std application/vnd.sun.xml.impress sxi application/vnd.sun.xml.impress.template sti application/vnd.sun.xml.math sxm application/vnd.sun.xml.writer sxw application/vnd.sun.xml.writer.global sxg application/vnd.sun.xml.writer.template stw application/vnd.svd application/vnd.swiftview-ics application/vnd.symbian.install sis application/vnd.triscape.mxs application/vnd.trueapp application/vnd.truedoc application/vnd.tve-trigger application/vnd.ufdl application/vnd.uplanet.alert application/vnd.uplanet.alert-wbxml application/vnd.uplanet.bearer-choice application/vnd.uplanet.bearer-choice-wbxml application/vnd.uplanet.cacheop application/vnd.uplanet.cacheop-wbxml application/vnd.uplanet.channel application/vnd.uplanet.channel-wbxml application/vnd.uplanet.list application/vnd.uplanet.list-wbxml application/vnd.uplanet.listcmd application/vnd.uplanet.listcmd-wbxml application/vnd.uplanet.signal application/vnd.vcx application/vnd.vectorworks application/vnd.vidsoft.vidconference application/vnd.visio application/vnd.vividence.scriptfile application/vnd.wap.sic application/vnd.wap.slc application/vnd.wap.wbxml wbxml application/vnd.wap.wmlc wmlc application/vnd.wap.wmlscriptc wmlsc application/vnd.webturbo application/vnd.wrq-hp3000-labelled application/vnd.wt.stf application/vnd.xara application/vnd.xfdl application/vnd.yellowriver-custom-menu application/x-123 wk application/x-apple-diskimage dmg application/x-bcpio bcpio application/x-bittorrent torrent application/x-cdf cdf application/x-cdlink vcd application/x-chess-pgn pgn application/x-core application/x-cpio cpio application/x-csh csh application/x-debian-package deb application/x-director dcr dir dxr application/x-doom wad application/x-dms dms application/x-dvi dvi application/x-executable application/x-font pfa pfb gsf pcf pcf.Z application/x-futuresplash spl application/x-gnumeric gnumeric application/x-go-sgf sgf application/x-graphing-calculator gcf application/x-gtar gtar tgz taz application/x-hdf hdf application/x-httpd-php phtml pht php application/x-httpd-php-source phps application/x-httpd-php3 php3 application/x-httpd-php3-preprocessed php3p application/x-httpd-php4 php4 application/x-ica ica application/x-internet-signup ins isp application/x-iphone iii application/x-java-applet application/x-java-archive jar application/x-java-bean application/x-java-jnlp-file jnlp application/x-java-serialized-object ser application/x-java-vm class application/x-javascript js application/x-kdelnk application/x-kchart chrt application/x-killustrator kil application/x-kpresenter kpr kpt application/x-koan skp skd skt skm application/x-kspread ksp application/x-kword kwd kwt application/x-latex latex application/x-lha lha application/x-lzh lzh application/x-lzx lzx application/x-maker frm maker frame fm fb book fbdoc application/x-mif mif application/x-ms-wmz wmz application/x-ms-wmd wmd application/x-msdos-program com exe bat dll application/x-msi msi application/x-netcdf nc application/x-ns-proxy-autoconfig pac application/x-nwc nwc application/x-object o application/x-oz-application oza application/x-perl pl pm application/x-pkcs7-certreqresp p7r application/x-pkcs7-crl crl application/x-quicktimeplayer qtl application/x-redhat-package-manager rpm application/x-rx application/x-sh application/x-shar shar application/x-shellscript application/x-shockwave-flash swf swfl application/x-sh sh application/x-stuffit sit application/x-sv4cpio sv4cpio application/x-sv4crc sv4crc application/x-tar tar application/x-tcl tcl application/x-tex tex application/x-tex-gf gf application/x-tex-pk pk application/x-texinfo texinfo texi application/x-trash ~ % bak old sik application/x-troff t tr roff application/x-troff-man man application/x-troff-me me application/x-troff-ms ms application/x-ustar ustar application/x-wais-source src application/x-wingz wz application/x-x509-ca-cert crt application/x-xfig fig audio/32kadpcm #audio/aiff aif aifc aiff audio/basic au snd audio/g.722.1 audio/l16 audio/midi mid midi kar audio/mp4a-latm audio/mpa-robust audio/mpeg mpga mpega mp2 mp3 audio/mpegurl m3u audio/parityfec audio/prs.sid sid audio/telephone-event audio/tone #audio/wav wav audio/vnd.cisco.nse audio/vnd.cns.anp1 audio/vnd.cns.inf1 audio/vnd.digital-winds audio/vnd.everad.plj audio/vnd.lucent.voice audio/vnd.nortel.vbk audio/vnd.nuera.ecelp4800 audio/vnd.nuera.ecelp7470 audio/vnd.nuera.ecelp9600 audio/vnd.octel.sbc audio/vnd.qcelp audio/vnd.rhetorex.32kadpcm audio/vnd.vmx.cvsd audio/x-aiff aif aiff aifc audio/x-gsm gsm audio/x-mpegurl m3u audio/x-ms-wma wma audio/x-ms-wax wax audio/x-pn-realaudio-plugin rpm audio/x-pn-realaudio ra rm ram audio/x-realaudio ra audio/x-scpls pls audio/x-sd2 sd2 audio/x-wav wav chemical/x-pdb pdb chemical/x-xyz xyz image/bmp bmp image/cgm image/g3fax image/gif gif image/ief ief image/jpeg jpeg jpg jpe image/naplps image/pcx pcx image/png png image/prs.btif image/prs.pti image/svg+xml svg svgz image/tiff tiff tif image/vnd.cns.inf2 image/vnd.dwg image/vnd.dxf image/vnd.fastbidsheet image/vnd.fpx image/vnd.fst image/vnd.fujixerox.edmics-mmr image/vnd.fujixerox.edmics-rlc image/vnd.mix image/vnd.net-fpx image/vnd.svf image/vnd.wap.wbmp wbmp image/vnd.xiff image/x-cmu-raster ras image/x-coreldraw cdr image/x-coreldrawpattern pat image/x-coreldrawtemplate cdt image/x-corelphotopaint cpt image/x-djvu djvu djv image/x-icon ico image/x-jg art image/x-jng jng image/x-ms-bmp bmp image/x-photoshop psd image/x-portable-anymap pnm image/x-portable-bitmap pbm image/x-portable-graymap pgm image/x-portable-pixmap ppm image/x-rgb rgb image/x-xbitmap xbm image/x-xpixmap xpm image/x-xwindowdump xwd inode/chardevice inode/blockdevice inode/directory-locked inode/directory inode/fifo inode/socket message/delivery-status message/disposition-notification message/external-body message/http message/s-http message/news message/partial message/rfc822 model/iges igs iges model/mesh msh mesh silo model/vnd.dwf model/vnd.flatland.3dml model/vnd.gdl model/vnd.gs-gdl model/vnd.gtw model/vnd.mts model/vnd.vtu model/vrml wrl vrml multipart/alternative multipart/appledouble multipart/byteranges multipart/digest multipart/encrypted multipart/form-data multipart/header-set multipart/mixed multipart/parallel multipart/related multipart/report multipart/signed multipart/voice-message text/calendar text/comma-separated-values csv text/css css text/directory text/english text/enriched text/h323 323 text/html htm html text/iuls uls text/mathml mml text/parityfec text/plain asc txt text diff text/prs.lines.tag text/rfc822-headers text/richtext rtx text/rtf rtf text/scriptlet sct wsc text/t140 text/texmacs tm ts text/tab-separated-values tsv text/uri-list text/vnd.abc text/vnd.curl text/vnd.DMClientScript text/vnd.flatland.3dml text/vnd.fly text/vnd.fmi.flexstor text/vnd.in3d.3dml text/vnd.in3d.spot text/vnd.IPTC.NewsML text/vnd.IPTC.NITF text/vnd.latex-z text/vnd.motorola.reflex text/vnd.ms-mediapackage text/vnd.sun.j2me.app-descriptor jad text/vnd.wap.si text/vnd.wap.sl text/vnd.wap.wml wml text/vnd.wap.wmlscript wmls text/xml xml xsl text/x-c++hdr h++ hpp hxx hh text/x-c++src c++ cpp cxx cc text/x-chdr h text/x-crontab text/x-csh csh text/x-csrc c text/x-java java text/x-makefile text/xml-external-parsed-entity text/x-moc moc text/x-pascal p pas text/x-pcs-gcd gcd text/x-server-parsed-html shtml text/x-setext etx text/x-sh sh text/x-tcl tcl tk text/x-tex tex ltx sty cls text/x-vcalendar vcs text/x-vcard vcf #video/avi avi video/dl dl video/fli fli video/gl gl video/mpeg mpeg mpg mpe video/quicktime qt mov video/mp4v-es video/parityfec video/pointer video/vnd.fvt video/vnd.motorola.video video/vnd.motorola.videop video/vnd.mpegurl mxu video/vnd.mts video/vnd.nokia.interleaved-multimedia video/vnd.vivo video/x-dv dif dv video/x-la-asf lsf lsx video/x-mng mng video/x-ms-asf asf asx video/x-ms-wm wm video/x-ms-wmv wmv video/x-ms-wmx wmx video/x-ms-wvx wvx video/x-msvideo avi video/x-sgi-movie movie x-conference/x-cooltalk ice x-world/x-vrml vrm vrml wrl Net-HTTPServer-1.1.1/lib/Net/HTTPServer/CaptureSTDOUT.pm0000644000175000017500000000276410167130566023524 0ustar reatmonreatmon00000000000000############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 2003-2005 Ryan Eatmon # ############################################################################## # # This class was borrowed from the IO::Capture module by Mark Reynolds and # Jon Morgan. I do not need all the capability of IO::Capture, nor do I # want to create a depenency on too many external modules. Thanks to Mark # and Jon for the great work. # package Net::HTTPServer::CaptureSTDOUT; sub TIEHANDLE { my $class = shift; bless [], $class; } sub PRINT { my $self = shift; push @$self, join '',@_; } sub READLINE { my $self = shift; return wantarray ? @$self : shift @$self; } sub CLOSE { my $self = shift; return close $self; } 1; Net-HTTPServer-1.1.1/lib/Net/HTTPServer/Response.pm0000644000175000017500000002512710167133530022744 0ustar reatmonreatmon00000000000000############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 2003-2005 Ryan Eatmon # ############################################################################## package Net::HTTPServer::Response; =head1 NAME Net::HTTPServer::Response =head1 SYNOPSIS Net::HTTPServer::Response handles formatting the response to the client. =head1 DESCRIPTION Net::HTTPServer::Response provides a nice OOP interface for easy control of headers, cookies, sessions, and/or the content that will be sent to the requesting client. =head1 EXAMPLES my $response = new Net::HTTPServer::Response(); my $response = new Net::HTTPServer::Response(code=>200, headers=>{ ); my $response = $request->Response(); =head1 METHODS =head2 new(%cfg) Given a config hash, return a server object that you can start, process, and stop. The config hash takes the options: body => string - The contents of the response. ( Default: "" ) code => int - The return code of this reponse. ( Default: 200 ) cookies => hashref - Hash reference to a set of cookies to send. Most people should just use the Cookie method to set these. ( Default: {} ) headers => hashref - Hash reference to the headers to send. Most people should just use the Header method. ( Default: {} ) =head2 Body([string]) Returns the current value of the response body. Sets the content of the response if a value is specified. =head2 Clear() Reset the body to "". =head2 Code(int) Returns the current value of the response code. Set the status code of the response if a value is specified. =head2 Cookie(name[,value[,%options]]) Returns the cookie value for the specified name, or undef if it is not set. If the value is also specified, then the cookie is set to the value. The optional hash options that you can provide to the cookie are: domain => string - If specified, the client will return the cookie for any hostname that is part of the domain. expires => string - When should the cookie expire. Must be formatted according to the rules: Wednesday, 30-June-2004 18:14:24 GMT Optionally you can specify "now" which will resolve to the current time. path => string - The path on the server that the client should return the cookie for. secure => 0|1 - The client will only return the cookie over an HTTPS connection. =head2 Header(name[,value]) Returns the header value for the specified name, or undef if it is not set. If the value is specified, then the header is set to the value. =head2 Print(arg1[,arg2,...,argN]) Appends the arguments to the end of the body. =head2 Redirect(url) Redirect the client to the specified URL. =head2 Session(object) Register the Net::HTTPServer::Session object with the response. When the server builds the actual reponse to the client it will set the appropriate cookie and save the session. If the response is created from the request object, and there was a session created from the request object then this, will be prepopulated with that session. =head2 CaptureSTDOUT() If you use the CGI perl module then it wants to print everything to STDOUT. CaptureSTDOUT() will put the Reponse object into a mode where it will capture all the output from the module. See ProcessSTDOUT() for more information. =head2 ProcessSTDOUT([%args]) This will harvest all of the data printed to STDOUT and put it into the Response object via a Print() call. This will also stop monitoring STDOUT and release it. You can specify some options: strip_header => 0|1 - If you use the CGI module and you print the headers then ProcessSTDOUT() can try to strip those out. The best plan is not to print them. See CaptureSTDOUT() for more information. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT Copyright (c) 2003-2005 Ryan Eatmon . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Carp; use URI::Escape; use Net::HTTPServer::CaptureSTDOUT; use vars qw ( $VERSION ); $VERSION = "1.0.3"; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); my (%args) = @_; $self->{ARGS} = \%args; $self->{CODE} = $self->_arg("code","200"); $self->{HEADERS} = $self->_arg("headers",{}); $self->{COOKIES} = $self->_arg("cookies",{}); $self->{BODY} = $self->_arg("body",""); return $self; } sub Body { my $self = shift; my $body = shift; return $self->{BODY} unless defined($body); $self->{BODY} = $body; } sub Clear { my $self = shift; $self->{BODY} = ""; } sub Code { my $self = shift; my $code = shift; return $self->{CODE} unless defined($code); $self->{CODE} = $code; } sub Cookie { my $self = shift; my $cookie = shift; my $value = shift; my (%args) = @_; return unless (defined($cookie) && defined($value)); $self->{COOKIES}->{$cookie}->{value} = $value; if (exists($args{expires})) { $self->{COOKIES}->{$cookie}->{expires} = $args{expires}; $self->{COOKIES}->{$cookie}->{expires} = &Net::HTTPServer::_date() if ($args{expires} eq "now"); } $self->{COOKIES}->{$cookie}->{domain} = $args{domain} if exists($args{domain}); $self->{COOKIES}->{$cookie}->{path} = $args{path} if exists($args{path}); $self->{COOKIES}->{$cookie}->{secure} = $args{secure} if exists($args{secure}); } sub Header { my $self = shift; my $header = shift; my $value = shift; return unless defined($header); $self->{HEADERS}->{$header} = $value if defined($value); return unless exists($self->{HEADERS}->{$header}); return $self->{HEADERS}->{$header}; } sub Print { my $self = shift; $self->{BODY} .= join("",@_); } sub Redirect { my $self = shift; my $url = shift; $self->Code(307); $self->Clear(); $self->Header("Location",$url); } sub Session { my $self = shift; my $session = shift; $self->{SESSION} = $session if defined($session); return unless exists($self->{SESSION}); return $self->{SESSION}; } sub CaptureSTDOUT { my $self = shift; if (tied *STDOUT) { croak("You cannot call CaptureSTDOUT more than once without calling ProcessSTDOUT"); } tie(*STDOUT, "Net::HTTPServer::CaptureSTDOUT"); } sub ProcessSTDOUT { my $self = shift; my (%args) = @_; my $output = join("",); #-------------------------------------------------------------------------- # Try and strip out the headers if the user printed any... #-------------------------------------------------------------------------- if (exists($args{strip_header}) && ($args{strip_header} == 1)) { $output =~ s/^.+\015?\012\015?\012//; } $self->Print($output); untie(*STDOUT); } ############################################################################### # # _arg - if the arg exists then use it, else use the default. # ############################################################################### sub _arg { my $self = shift; my $arg = shift; my $default = shift; return (exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default); } sub _build { my $self = shift; #------------------------------------------------------------------------- # Format the return headers #------------------------------------------------------------------------- my $header = "HTTP/1.1 ".$self->{CODE}."\n"; foreach my $key (sort {$a cmp $b} keys(%{$self->{HEADERS}})) { $header .= "$key: ".$self->{HEADERS}->{$key}."\n"; } #------------------------------------------------------------------------- # Session in, cookie out #------------------------------------------------------------------------- if (exists($self->{SESSION})) { my $value = $self->{SESSION}->_key(); my $delta = 4*60*60; # 4 hours from now if ($self->{SESSION}->_valid()) { $self->{SESSION}->_save(); } else { $value = ""; $delta = -(100*24*60*60); # 100 days ago } $self->Cookie("NETHTTPSERVERSESSION", $value, expires=>&Net::HTTPServer::_date(time,$delta), ); } #------------------------------------------------------------------------- # Mmmm.... Cookies.... #------------------------------------------------------------------------- foreach my $cookie (sort {$a cmp $b} keys(%{$self->{COOKIES}})) { my $value = uri_escape($self->{COOKIES}->{$cookie}->{value}); $header .= "Set-Cookie: $cookie=$value"; foreach my $key (sort {$a cmp $b} keys(%{$self->{COOKIES}->{$cookie}})) { next if ($key eq "value"); if ($key eq "secure") { if ($self->{COOKIES}->{$cookie}->{$key} == 1) { $header .= ";$key"; } } else { $header .= ";$key=".$self->{COOKIES}->{$cookie}->{$key}; } } $header .= "\n"; } chomp($header); $header .= "\r\n\r\n"; return ($header,$self->{BODY}); } 1; Net-HTTPServer-1.1.1/lib/Net/HTTPServer/Session.pm0000644000175000017500000001417210166146707022600 0ustar reatmonreatmon00000000000000############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 2003-2005 Ryan Eatmon # ############################################################################## package Net::HTTPServer::Session; =head1 NAME Net::HTTPServer::Session =head1 SYNOPSIS Net::HTTPServer::Session handles server side client sessions =head1 DESCRIPTION Net::HTTPServer::Session provides a server side data store for client specific sessions. It uses a cookie stored on the browser to tell the server which session to restore to the user. This is modelled after the PHP session concept. The session is valid for 4 hours from the last time the cookie was sent. =head1 EXAMPLES sub pageHandler { my $request = shift; my $session = $request->Session(); my $response = $request->Response(); # Logout $session->Destroy() if $request->Env("logout"); $response->Print("Hi there"); # If the user specified a username on the URL, then save it. if ($request->Env("username")) { $session->Set("username",$request->Env("username")); } # If there is a saved username, then use it. if ($session->Get("username")) { $response->Print("Hello, ",$session->Get("username"),"!"); } else { $response->Print("Hello, stranger!"); } $response->Print(""); return $response; } The above would behave as follows: http://server/page - Hello, stranger! http://server/page?username=Bob - Hello, Bob! http://server/page - Hello, Bob! http://server/page?username=Fred - Hello, Fred! http://server/page - Hello, Fred! http://server/page?logout=1 - Hello, stranger! http://server/page - Hello, stranger! =head1 METHODS =head2 Delete(var) Delete the specified variable from the session. =head2 Destroy() Destroy the session. The server side data is deleted and the cookie will be expired. =head2 Exists(var) Returns if the specified variable exists in the sesion. =head2 Get(var) Return the value of the specified variable from the session if it exists, undef otherwise. =head2 Set(var,value) Store the specified value (scalar or reference to any Perl data structure) in the session. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT Copyright (c) 2003-2005 Ryan Eatmon . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Carp; use Data::Dumper; use vars qw ( $VERSION $SESSION_COUNT %data ); $VERSION = "1.0.3"; $SESSION_COUNT = 0; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); my (%args) = @_; $self->{ARGS} = \%args; $self->{KEY} = $self->_arg("key",undef); $self->{SERVER} = $self->_arg("server",undef); return unless $self->{SERVER}->{CFG}->{SESSIONS}; $self->{KEY} = $self->_genkey() if (!defined($self->{KEY}) || ($self->{KEY} eq "") || ($self->{KEY} =~ /\//) ); $self->{FILE} = $self->{SERVER}->{CFG}->{DATADIR}."/".$self->{KEY}; #XXX Check that server (Net::HTTPServer object) is defined $self->{VALID} = 1; $self->{DATA} = {}; $self->_load(); return $self; } sub Delete { my $self = shift; my $var = shift; return unless $self->Exists($var); delete($self->{DATA}->{$var}); } sub Destroy { my $self = shift; $self->{VALID} = 0; } sub Exists { my $self = shift; my $var = shift; return unless $self->_valid(); return exists($self->{DATA}->{$var}); } sub Get { my $self = shift; my $var = shift; return unless $self->Exists($var); return $self->{DATA}->{$var}; } sub Set { my $self = shift; my $var = shift; my $value = shift; return unless $self->_valid(); $self->{DATA}->{$var} = $value if defined($value); } ############################################################################### # # _arg - if the arg exists then use it, else use the default. # ############################################################################### sub _arg { my $self = shift; my $arg = shift; my $default = shift; return (exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default); } sub _genkey { my $self = shift; $SESSION_COUNT++; my $key = "NetHTTPServerSession".$SESSION_COUNT.$$.time; if ($Net::HTTPServer::DigestMD5 == 1) { $key = Digest::MD5::md5_hex($key); } return $key; } sub _key { my $self = shift; return $self->{KEY}; } sub _load { my $self = shift; return unless $self->_valid(); return unless (-f $self->{FILE}); undef(%data); my $data; open(DATA,$self->{FILE}) || return; read(DATA, $data, (-s DATA)); close(DATA); eval $data; if (!$@) { $self->{DATA} = \%data; } } sub _save { my $self = shift; if (!$self->_valid()) { unlink($self->{FILE}) if (-f $self->{FILE}); return; } my $dumper = new Data::Dumper([$self->{DATA}],["*data"]); $dumper->Purity(1); open(DATA,">".$self->{FILE}); print DATA $dumper->Dump(); close(DATA); } sub _valid { my $self = shift; return (exists($self->{VALID}) && ($self->{VALID} == 1)); } 1; Net-HTTPServer-1.1.1/lib/Net/HTTPServer.pm0000644000175000017500000022415310175740723021155 0ustar reatmonreatmon00000000000000############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 2003-2005 Ryan Eatmon # ############################################################################## package Net::HTTPServer; =head1 NAME Net::HTTPServer =head1 SYNOPSIS Net::HTTPServer provides a lite HTTP server. It can serve files, or can be configured to call Perl functions when a URL is accessed. =head1 DESCRIPTION Net::HTTPServer basically turns a CGI script into a stand alone server. Useful for temporary services, mobile/local servers, or embedding an HTTP server into another program. =head1 EXAMPLES use Net::HTTPServer; my $server = new Net::HTTPServer(port=>5000, docroot=>"/var/www/site"); $server->Start(); $server->Process(); # Run forever ...or... while(1) { $server->Process(5); # Run for 5 seconds # Do something else... } $server->Stop(); =head1 METHODS =head2 new(%cfg) Given a config hash, return a server object that you can start, process, and stop. The config hash takes the options: chroot => 0|1 - Run the server behind a virtual chroot(). Since only root can actually call chroot, a URL munger is provided that will not allow URLs to go beyond the document root if this is specified. ( Default: 1 ) datadir => string - Path on the filesystem where you want to store the server side session files. ( Deault: "/tmp/nethttpserver.sessions" ) docroot => string - Path on the filesystem that you want to be the document root "/" for the server. If set to undef, then the server will not serve any files off the local filesystem, but will still serve callbacks. ( Default: undef ) index => list - Specify a list of file names to use as the the index file when a directory is requested. ( Default: ["index.html","index.htm"] ) log => string - Path to store the log at. If you set this to "STDOUT" then it will display to STDOUT. ( Default: access.log ) mimetypes => string - Path to an alternate mime.types file. ( Default: included in release ) numproc => int - When type is set to "forking", this tells the server how many child processes to keep running at all times. ( Default: 5 ) oldrequests => 0|1 - With the new request objects, old programs will not work. To postpone updating your code, just set this to 1 and your programs should work again. ( Default: 0 ) port => int - Port number to use. You can optionally specify the string "scan", and the server will loop through ports until it finds one it can listen on. This port is then returned by the Start() method. ( Default: 9000 ) sessions => 0|1 - Enable/disable server side session support. ( Default: 0 ) ssl => 0|1 - Run a secure server using SSL. You must specify ssl_key, ssl_cert, and ssl_ca if set this to 1. ( Default: 0 ) ssl_ca => string - Path to the SSL ca file. ( Default: undef ) ssl_cert => string - Path to the SSL cert file. ( Default: undef ) ssl_key => string - Path to the SSL key file. ( Default: undef ) type => string - What kind of server to create? Available types are: single - single process/no forking forking - preforking server (Default: "single") =head2 AddServerTokens(token,[token,...]) Adds one or more tokens onto the Server header line that the server sends back in a response. The list is seperated by a ; to distinguish the various tokens from each other. $server->AddServerTokens("test/1.3"); This would result in the following header being sent in a response: HTTP/1.1 200 Server: Net::HTTPServer/0.9 test/1.3 Content-Type: text/html ... =head2 Process(timeout) Listens for incoming requests and responds back to them. This function will block, unless a timeout is specified, then it will block for that number of seconds before returning. Useful for embedding this into other programs and still letting the other program get some CPU time. =head2 RegisterAuth(method,url,realm,function) Protect the URL using the Authentication method provided. The supported methods are: "Basic" and "Digest". When a URL with a path component that matchs the specified URL is requested the server requests that the client perform the specified of authentication for the given realm. When the URL is accessed the second time, the client provides the authentication pieces and the server parses the pieces and using the return value from the specified function answers the request. The function is called with the username and the URL they are trying to access. It is required that the function return a two item list with a return code and the users's password. The valid return codes are: 200 The user exists and is allowed to access this URL. Return the password. return( "200", password ) 401 The user does not exist. Obviously you do not have to return a password in this case. return( "401" ) 403 The user is forbidden to access this URL. (You must still return the password because if the user did not auth, then we do not want to tip off the bad people that this username is valid.) return( "403", password ) The reasoning for having the function return the password is that Digest authentication is just complicated enough that asking you to write part of logic would be considered rude. By just having you give the server the password we can keep the whole Auth interface simple. Here is an example: $server->RegisterAuth("Basic","/foo/bar.pl","Secure",\&testBasic); sub testBasic { my $url = shift; my $user = shift; my $password = &lookupPassword($user); return("401","") unless defined($password); if (($url eq "/foo/bar.pl") && ($user eq "dr_evil")) { return ("403",$password); } return ("200",$password); } sub lookupPassword { my $user = shift; my %passwd; $passwd{larry} = "wall"; $passwd{dr_evil} = "1million"; return unless exists($passwd{$user}); return $passwd{$user}; } Start a server with that, and the following RegisterURL example, and point your browser to: http://localhost:9000/foo/bar.pl?test=bing&test2=bong You should be prompted for a userid and password, entering "larry" and "wall" will allow you to see the page. Entering "dr_evil" and "1million" should result in getting a Forbidden page (and likely needing to restart your browser). Entering any other userid or password should result in you being asked again. If you have a handler for both RegisterURL and RegisterAuth, then your function for RegisterURL can find the identify of the user in the C<$env-E{'REMOTE_USER'}> hash entry. This is similar to CGI scripts. You can have multiple handlers for different URLs. If you do this, then the longest complete URL handler will be called. For example, if you have handlers for C and C, and a URL of C is called, then the handler C is called to authorize this request, but if a URL of C is called, then the handler C is called. Only complete directories are matched, so if you had a handler for C, then it would not be called for either /foo/bar.pl or C. =head2 RegisterRegex(regex,function) Register the function with the provided regular expression. When a URL that matches that regular expression is requested, the function is called and passed the environment (GET+POST) so that it can do something meaningfiul with them. For more information on how the function is called and should be used see the section on RegisterURL below. $server->RegisterRegex(".*.news$",\&news); This will match any URL that ends in ".news" and call the &news function. The URL that the user request can be retrieved via the Request object ($reg->Path()). =head2 RegisterRegex(hash ref) Instead of calling RegisterRegex a bunch of times, you can just pass it a hash ref containing Regex/callback pairs. $server->RegisterRegex({ ".*.news$" => \&news, ".*.foo$" => \&foo, }); =head2 RegisterURL(url,function) Register the function with the provided URL. When that URL is requested, the function is called and passed in the environment (GET+POST) so that it can do something meaningful with them. A simple handler looks like: $server->RegisterURL("/foo/bar.pl",\&test); sub test { my $req = shift; # Net::HTTPServer::Request object my $res = $req->Response(); # Net::HTTPServer::Response object $res->Print("\n"); $res->Print(" \n"); $res->Print(" This is a test\n"); $res->Print(" \n"); $res->Print(" \n"); $res->Print(" 
\n");

      foreach my $var (keys(%{$req->Env()}))
      {
          $res->Print("$var -> ".$req->Env($var)."\n");
      }
      
      $res->Print("
\n"); $res->Print(" \n"); $res->Print("\n"); return $res; } Start a server with that and point your browser to: http://localhost:9000/foo/bar.pl?test=bing&test2=bong You should see a page titled "This is a test" with this body: test -> bing test2 -> bong =head2 RegisterURL(hash ref) Instead of calling RegisterURL a bunch of times, you can just pass it a hash ref containing URL/callback pairs. $server->RegisterURL({ "/foo/bar.pl" => \&test1, "/foo/baz.pl" => \&test2, }); See RegisterURL() above for more information on how callbacks work. =head2 Start() Starts the server based on the config options passed to new(). Returns the port number the server is listening on, or undef if the server was unable to start. =head2 Stop() Shuts down the socket connection and cleans up after itself. =head1 SESSIONS Net::HTTPServer provides support for server-side sessions much like PHP's session model. A handler that you register can ask that the request object start a new session. It will check a cookie value to see if an existing session exists, if not it will create a new one with a unique key. You can store any arbitrary Perl data structures in the session. The next time the user accesses your handler, you can restore those values and have them available again. When you are done, simple destroy the session. =head1 HEADERS Net::HTTPServer sets a few headers automatically. Due to the timing of events, you cannot get to those headers programatically, so we will discuss them general. Obviously for file serving, errors, and authentication it sends back all of the appropriate headers. You likely do not need to worry about those cases. In RegisterURL mode though, here are the headers that are added: Accept-Ranges: none (not supported) Allow: GET, HEAD, POST, TRACE Content-Length: Connection: close (not supported) Content-Type: text/html (unless you set it) Date: Server: If you have any other questions about what is being sent, try using DEBUG (later section). =head1 DEBUG When you are writing your application you might see behavior that is unexpected. I've found it useful to check some debugging statements that I have in the module to see what it is doing. If you want to turn debugging on simply provide the debug => [ zones ] option when creating the server. You can optionally specify a file to write the log into instead of STDOUT by specifying the debuglog => file option. I've coded the modules debugging using the concept of zones. Each zone (or task) has it's own debug messages and you can enable/disable them as you want to. Here are the list of available zones: INIT - Initializing the sever PROC - Processing a request REQ - Parsing requests RESP - Returning the response (file contents are not printed) AUTH - Handling and authentication request FILE - Handling a file system request. READ - Low-level read SEND - Low-level send (even prints binary characters) ALL - Turn all of the above on. So as an example: my $server = new Net::HTTPServer(..., debug=>["REQ","RESP"],...); That would show all requests and responses. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT Copyright (c) 2003-2005 Ryan Eatmon . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Carp; use IO::Socket; use IO::Select; use FileHandle; use File::Path; use POSIX; use Net::HTTPServer::Session; use Net::HTTPServer::Response; use Net::HTTPServer::Request; use vars qw ( $VERSION %ALLOWED $SSL $Base64 $DigestMD5 ); $VERSION = "1.1.1"; $ALLOWED{GET} = 1; $ALLOWED{HEAD} = 1; $ALLOWED{OPTIONS} = 1; $ALLOWED{POST} = 1; $ALLOWED{TRACE} = 1; #------------------------------------------------------------------------------ # Do we have IO::Socket::SSL for https support? #------------------------------------------------------------------------------ if (eval "require IO::Socket::SSL;") { require IO::Socket::SSL; import IO::Socket::SSL; $SSL = 1; } else { $SSL = 0; } #------------------------------------------------------------------------------ # Do we have MIME::Base64 for Basic Authentication support? #------------------------------------------------------------------------------ if (eval "require MIME::Base64;") { require MIME::Base64; import MIME::Base64; $Base64 = 1; } else { $Base64 = 0; } #------------------------------------------------------------------------------ # Do we have Digest::MD5 for Digest Authentication support? #------------------------------------------------------------------------------ if (eval "require Digest::MD5;") { require Digest::MD5; import Digest::MD5; $DigestMD5 = 1; } else { $DigestMD5 = 0; } sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); my (%args) = @_; $self->{ARGS} = \%args; #-------------------------------------------------------------------------- # Get the hostname... #-------------------------------------------------------------------------- my $hostname = (uname)[1]; my $address = gethostbyname($hostname); if ($address) { $hostname = $address; my $temp = gethostbyaddr($address, AF_INET); $hostname = $temp if ($temp); } $self->{SERVER}->{NAME} = $hostname; $self->{CFG}->{ADMIN} = $self->_arg("admin",'webmaster@'.$hostname); $self->{CFG}->{CHROOT} = $self->_arg("chroot",1); $self->{CFG}->{DATADIR} = $self->_arg("datadir","/tmp/nethttpserver.sessions"); $self->{CFG}->{DOCROOT} = $self->_arg("docroot",undef); $self->{CFG}->{INDEX} = $self->_arg("index",["index.html","index.htm"]); $self->{CFG}->{LOG} = $self->_arg("log","access.log"); $self->{CFG}->{MIMETYPES} = $self->_arg("mimetypes",undef); $self->{CFG}->{NUMPROC} = $self->_arg("numproc",5); $self->{CFG}->{OLDREQUEST} = $self->_arg("oldrequest",0); $self->{CFG}->{PORT} = $self->_arg("port",9000); $self->{CFG}->{SESSIONS} = $self->_arg("sessions",0); $self->{CFG}->{SSL} = $self->_arg("ssl",0) && $SSL; $self->{CFG}->{SSL_KEY} = $self->_arg("ssl_key",undef); $self->{CFG}->{SSL_CERT} = $self->_arg("ssl_cert",undef); $self->{CFG}->{SSL_CA} = $self->_arg("ssl_ca",undef); $self->{CFG}->{TYPE} = $self->_arg("type","single",["single","forking"]); if ($self->{CFG}->{LOG} eq "STDOUT") { $| = 1; $self->{LOG} = \*STDOUT; } else { $self->{LOG} = new FileHandle(">>$self->{CFG}->{LOG}"); if (!defined($self->{LOG})) { croak("Could not open log $self->{CFG}->{LOG} for append:\n $!"); } } FileHandle::autoflush($self->{LOG},1); $self->{DEBUGZONES} = {}; $self->{DEBUG} = $self->_arg("debug",[]); $self->{DEBUGLOG} = $self->_arg("debuglog","STDOUT"); if ((ref($self->{DEBUG}) eq "ARRAY") && ($#{$self->{DEBUG}} > -1)) { foreach my $zone (@{$self->{DEBUG}}) { $self->{DEBUGZONES}->{$zone} = 1; } if ($self->{DEBUGLOG} eq "STDOUT") { $| = 1; $self->{DEBUGLOG} = \*STDOUT; } else { my $log = $self->{DEBUGLOG}; $self->{DEBUGLOG} = new FileHandle(">$log"); if (!defined($self->{DEBUGLOG})) { croak("Could not open log $log for write:\n $!"); } } FileHandle::autoflush($self->{DEBUGLOG},1); } delete($self->{ARGS}); if (!defined($self->{CFG}->{MIMETYPES})) { foreach my $lib (@INC) { if (-e "$lib/Net/HTTPServer/mime.types") { $self->{CFG}->{MIMETYPES} = "$lib/Net/HTTPServer/mime.types"; last; } } } $self->_mimetypes(); if ($DigestMD5) { $self->{PRIVATEKEY} = Digest::MD5::md5_hex("Net::HTTPServer/$VERSION".time); } $self->{AUTH} = {}; $self->{CALLBACKS} = {}; $self->{SERVER_TOKENS} = [ "Net::HTTPServer/$VERSION" ]; if ($self->{CFG}->{SESSIONS}) { if (-d $self->{CFG}->{DATADIR}) { File::Path::rmtree($self->{CFG}->{DATADIR}); } if (!(-d $self->{CFG}->{DATADIR})) { File::Path::mkpath($self->{CFG}->{DATADIR},0,0700); } } $self->{REGEXID} = 0; #XXX Clean up the datadir of files older than a certain time. return $self; } ############################################################################### # # AddServerTokens - Add more tokens that will be sent on the Server: header # line of a response. # ############################################################################### sub AddServerTokens { my $self = shift; my (@tokens) = @_; foreach my $token (@tokens) { if ($token =~ / /) { croak("Server token cannot contain any spaces: \"$token\""); } push(@{$self->{SERVER_TOKENS}},$token); } } ############################################################################### # # Process - Inner loop to handle connection, read requests, process them, and # respond. # ############################################################################### sub Process { my $self = shift; my $timeout = shift; if (!defined($self->{SOCK})) { croak("Process() called on undefined socket. Check the result from Start().\n "); } my $timestop = undef; $timestop = time + $timeout if defined($timeout); $self->_debug("PROC","Process: type($self->{CFG}->{TYPE})"); my $block = 1; while($block) { if ($self->{CFG}->{TYPE} eq "single") { $self->_single_process($timestop); } elsif ($self->{CFG}->{TYPE} eq "forking") { $self->_forking_process(); } $block = 0 if (defined($timestop) && (($timestop - time) <= 0)); } } ############################################################################### # # RegisterAuth - Protect the given URL using the given authentication method # and calling the supplied function to verify the username # and password. # ############################################################################### sub RegisterAuth { my $self = shift; my $method = shift; my $url = shift; my $realm = shift; my $callback = shift; $method = lc($method); if (($method ne "basic") && ($method ne "digest")) { croak("You did not specify a valid method to RegisterAuth: \"$method\"\nValid options are:\n basic, digest\n"); } if (($method eq "basic") || ($method eq "digest")) { if (!$Base64) { $self->_log("Cannot register authentication callback as MIME::Base64 is not installed..."); carp("Cannot register authentication callback as MIME::Base64 is not installed..."); } } if ($method eq "digest") { if (!$DigestMD5) { $self->_log("Cannot register authentication callback as Digest::MD5 is not installed..."); carp("Cannot register authentication callback as Digest::MD5 is not installed..."); } } $self->{AUTH}->{$url}->{method} = $method; $self->{AUTH}->{$url}->{realm} = $realm; $self->{AUTH}->{$url}->{callback} = $callback; } ############################################################################### # # RegisterRegex - given a regular expressions, call the supplied function when # it a request path matches it. # ############################################################################### sub RegisterRegex { my $self = shift; my $regex = shift; my $callback = shift; $regex =~ s/\//\\\//g; $self->{REGEXID}++; my $id = "__nethttpserver__:regex:".$self->{REGEXID}; $self->{REGEXCALLBACKS}->{$regex}->{callback} = $id; $self->{REGEXCALLBACKS}->{$regex}->{id} = $self->{REGEXID}; $self->{CALLBACKS}->{$id} = $callback; } ############################################################################### # # RegisterURL - given a URL path, call the supplied function when it is # requested. # ############################################################################### sub RegisterURL { my $self = shift; my $url = shift; if (ref($url) eq "HASH") { foreach my $hashURL (keys(%{$url})) { $self->{CALLBACKS}->{$hashURL} = $url->{$hashURL}; } } else { my $callback = shift; $self->{CALLBACKS}->{$url} = $callback; } } ############################################################################### # # Start - Just a little initialization routine to start the server. # ############################################################################### sub Start { my $self = shift; $self->_debug("INIT","Start: Starting the server"); my $port = $self->{CFG}->{PORT}; my $scan = ($port eq "scan" ? 1 : 0); $port = 8000 if $scan; $self->{SOCK} = undef; while(!defined($self->{SOCK})) { $self->_debug("INIT","Start: Attempting to listen on port $port"); if ($self->{CFG}->{SSL} == 0) { $self->{SOCK} = new IO::Socket::INET(LocalPort=>$port, Proto=>"tcp", Listen=>10, Reuse=>1, (($^O ne "MSWin32") ? (Blocking=>0) : () ), ); } else { if (!defined($self->{CFG}->{SSL_KEY}) || !defined($self->{CFG}->{SSL_CERT}) || !defined($self->{CFG}->{SSL_CA})) { croak("You must specify ssl_key, ssl_cert, and ssl_ca if you want to use SSL."); return; } $self->_debug("INIT","Start: Create an SSL socket."); $self->{SOCK} = new IO::Socket::SSL(LocalPort=>$port, Proto=>"tcp", Listen=>10, Reuse=>1, SSL_key_file=>$self->{CFG}->{SSL_KEY}, SSL_cert_file=>$self->{CFG}->{SSL_CERT}, SSL_ca_file=>$self->{CFG}->{SSL_CA}, SSL_verify_mode=> 0x01, (($^O ne "MSWin32") ? (Blocking=>0) : () ), ); } last if defined($self->{SOCK}); last if ($port == 9999); last if !$scan; $port++; } if (!defined($self->{SOCK})) { $self->_log("Could not start the server..."); if ($self->{CFG}->{SSL} == 0) { carp("Could not start the server: $!"); } else { carp("Could not start the server: ",&IO::Socket::SSL::errstr); } return; } $self->{SELECT} = new IO::Select($self->{SOCK}); if ($self->{CFG}->{TYPE} eq "forking") { $self->_debug("INIT","Start: Initializing forking"); $SIG{CHLD} = sub{ $self->_forking_reaper(); }; $self->{CHILDREN} = {}; $self->{NUMCHILDREN} = 0; } $self->_log("Server running on port $port"); $self->{SERVER}->{PORT} = $port; return $port; } ############################################################################### # # Stop - Stop the server. # ############################################################################### sub Stop { my $self = shift; $self->_debug("INIT","Stop: Stopping the server"); if ($self->{CFG}->{TYPE} eq "forking") { $self->_forking_huntsman(); } if (exists($self->{SELECT}) && defined($self->{SELECT})) { $self->{SELECT}->remove($self->{SOCK}); } if (exists($self->{SOCK}) && defined($self->{SOCK})) { $self->{SOCK}->close(); } } ############################################################################### #+----------------------------------------------------------------------------- #| Private Flow Functions #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # _HandleAuth - Make sure that the user has passed the authentication to view # this page. # ############################################################################### sub _HandleAuth { my $self = shift; my $requestObj = shift; my $authURL = $self->_checkAuth($requestObj->Path()); return unless defined($authURL); $self->_debug("AUTH","_HandleAuth: url(".$requestObj->Path().")"); $self->_debug("AUTH","_HandleAuth: authURL($authURL) method($self->{AUTH}->{$authURL}->{method})"); if ($self->{AUTH}->{$authURL}->{method} eq "basic") { return $self->_HandleAuthBasic($authURL,$requestObj); } elsif ($self->{AUTH}->{$authURL}->{method} eq "digest") { return $self->_HandleAuthDigest($authURL,$requestObj); } return; } ############################################################################### # # _HandleAuthBasic - Parse the Authentication header and make sure that the # user is allowed to see this page. # ############################################################################### sub _HandleAuthBasic { my $self = shift; my $authURL = shift; my $requestObj = shift; my $realm = $self->{AUTH}->{$authURL}->{realm}; $self->_debug("AUTH","_HandleAuthBasic: authURL($authURL) realm($realm)"); #------------------------------------------------------------------------- # Auth if they did not send an Authorization #------------------------------------------------------------------------- return $self->_AuthBasic($realm) unless $requestObj->Header("Authorization"); $self->_debug("AUTH","_HandleAuthBasic: there was an Authorization"); my ($method,$base64) = split(" ",$requestObj->Header("Authorization"),2); #------------------------------------------------------------------------- # Auth if they did not send a Basic Authorization #------------------------------------------------------------------------- return $self->_AuthBasic($realm) if (lc($method) ne "basic"); $self->_debug("AUTH","_HandleAuthBasic: it was a Basic"); my ($user,$password) = split(":",MIME::Base64::decode($base64)); my ($code,$real_password) = &{$self->{AUTH}->{$authURL}->{callback}}($requestObj->Path(),$user); $self->_debug("AUTH","_HandleAuthBasic: callback return code($code)"); #------------------------------------------------------------------------- # Return the results of the authentication handler #------------------------------------------------------------------------- return $self->_AuthBasic($realm) if ($code eq "401"); return $self->_AuthBasic($realm) if ($password ne $real_password); return $self->_Forbidden() if ($code eq "403"); #------------------------------------------------------------------------- # We authed, so set REMOTE_USER in the env hash and return #------------------------------------------------------------------------- $requestObj->_env("AUTH_TYPE","Basic"); $requestObj->_env("REMOTE_USER",$user); return; } ############################################################################### # # _HandleAuthDigest - Parse the Authentication header and make sure that the # user is allowed to see this page. # ############################################################################### sub _HandleAuthDigest { my $self = shift; my $authURL = shift; my $requestObj = shift; my %digest; $digest{algorithm} = "MD5"; $digest{nonce} = $self->_nonce(); $digest{realm} = $self->{AUTH}->{$authURL}->{realm}; $digest{qop} = "auth"; $self->_debug("AUTH","_HandleAuthDigest: authURL($authURL) realm($digest{realm})"); #------------------------------------------------------------------------- # Auth if they did not send an Authorization #------------------------------------------------------------------------- return $self->_AuthDigest(\%digest) unless $requestObj->Header("Authorization"); $self->_debug("AUTH","_HandleAuthDigest: there was an Authorization"); my ($method,$directives) = split(" ",$requestObj->Header("Authorization"),2); #------------------------------------------------------------------------- # Auth if they did not send a Digest Authorization #------------------------------------------------------------------------- return $self->_AuthDigest(\%digest) if (lc($method) ne "digest"); $self->_debug("AUTH","_HandleAuthDigest: it was a Digest"); my %authorization; foreach my $directive (split(",",$directives)) { my ($key,$value) = ($directive =~ /^\s*([^=]+)\s*=\s*\"?(.+?)\"?\s*$/); $authorization{$key} = $value; } #------------------------------------------------------------------------- # Make sure that the uri in the auth and the request are the same. #------------------------------------------------------------------------- return $self->_BadRequest() if ($requestObj->URL() ne $authorization{uri}); my ($code,$real_password) = &{$self->{AUTH}->{$authURL}->{callback}}($requestObj->Path(),$authorization{username}); $self->_debug("AUTH","_HandleAuthDigest: callback return code($code)"); my $ha1 = $self->_digest_HA1(\%authorization,$real_password); my $ha2 = $self->_digest_HA2(\%authorization,$requestObj->Method()); my $kd = $self->_digest_KD(\%authorization,$ha1,$ha2); #------------------------------------------------------------------------- # Return the results of the authentication handler #------------------------------------------------------------------------- return $self->_AuthDigest(\%digest) if ($code eq "401"); return $self->_AuthDigest(\%digest) if ($kd ne $authorization{response}); return $self->_Forbidden() if ($code eq "403"); #------------------------------------------------------------------------- # If they authed, then check over the nonce and make sure it's valid. #------------------------------------------------------------------------- my ($time,$privatekey) = split(":",MIME::Base64::decode($authorization{nonce})); if ($privatekey ne $self->{PRIVATEKEY}) { $self->_debug("AUTH","_HandleAuthDigest: nonce is stale due to key."); $digest{stale} = "TRUE"; return $self->_AuthDigest(\%digest) } if ((time - $time) > 30) { $self->_debug("AUTH","_HandleAuthDigest: nonce is stale due to time."); $digest{stale} = "TRUE"; return $self->_AuthDigest(\%digest); } # XXX - check nc for replay attack # XXX - better nonce to minimize replay attacks? #------------------------------------------------------------------------- # We authed, so set REMOTE_USER in the env hash and return #------------------------------------------------------------------------- $requestObj->_env("AUTH_TYPE","Digest"); $requestObj->_env("REMOTE_USER",$authorization{username}); return; } ############################################################################### # # _ProcessRequest - Based on the URL and Environment, figure out what they # wanted, and call the correct handler. # ############################################################################### sub _ProcessRequest { my $self = shift; my $requestObj = shift; #------------------------------------------------------------------------- # Catch some common errors/reponses without doing any real hard work #------------------------------------------------------------------------- return $self->_ExpectationFailed() if ($requestObj->_failure() eq "expect"); return $self->_MethodNotAllowed() unless exists($ALLOWED{$requestObj->Method()}); return $self->_BadRequest() unless $requestObj->Header("Host"); return $self->_LengthRequired() if ($requestObj->Header("Transfer-Encoding") && $requestObj->Header("Transfer-Encoding") ne "identity"); return $self->_Options() if ($requestObj->Method() eq "OPTIONS"); return new Net::HTTPServer::Response() if ($requestObj->Method() eq "TRACE"); my $responseObj; my $reqPath = $requestObj->Path(); my $method = "not found"; my $reqPath1 = $reqPath."/"; my ($reqPath2) = ($reqPath =~ /^(.+)\/$/); $reqPath2 = $reqPath if !defined($reqPath); if (exists($self->{CALLBACKS}->{$reqPath})) { $method = "callback"; } elsif (exists($self->{CALLBACKS}->{$reqPath1})) { $method = "callback"; $reqPath = $reqPath1; } elsif (exists($self->{CALLBACKS}->{$reqPath2})) { $method = "callback"; $reqPath = $reqPath2; } elsif (my $regex = $self->_RegexMatch($reqPath)) { $reqPath = $regex; $method = "callback"; } elsif (defined($self->{CFG}->{DOCROOT}) && (-e $self->{CFG}->{DOCROOT}."/".$reqPath)) { $method = "file"; if (-d $self->{CFG}->{DOCROOT}."/".$reqPath) { $self->_debug("PROC","_ProcessRequest: This is a directory, look for an index file."); foreach my $index (@{$self->{CFG}->{INDEX}}) { my $testPath = $reqPath; $testPath .= "/" unless ($reqPath =~ /\/$/); $testPath .= $index; $self->_debug("PROC","_ProcessRequest: index? ($testPath)"); if (exists($self->{CALLBACKS}->{$testPath})) { $self->_debug("PROC","_ProcessRequest: index: callback: ($testPath)"); $method = "callback"; $reqPath = $testPath; last; } if (-f $self->{CFG}->{DOCROOT}."/".$testPath) { $self->_debug("PROC","_ProcessRequest: index: file: ($testPath)"); $reqPath = $testPath; last; } } } } else { $self->_debug("PROC","_ProcessRequest: Might be a virtual directory... index callback?"); foreach my $index (@{$self->{CFG}->{INDEX}}) { my $testPath = $reqPath; $testPath .= "/" unless ($reqPath =~ /\/$/); $testPath .= $index; $self->_debug("PROC","_ProcessRequest: index? ($testPath)"); if (exists($self->{CALLBACKS}->{$testPath})) { $self->_debug("PROC","_ProcessRequest: index: callback: ($testPath)"); $method = "callback"; $reqPath = $testPath; last; } } } $self->_debug("PROC","_ProcessRequest: method($method)"); if ($method eq "callback") { my $auth = $self->_HandleAuth($requestObj); return $auth if defined($auth); $self->_debug("PROC","_ProcessRequest: Callback"); if ($self->{CFG}->{OLDREQUEST}) { my $response = &{$self->{CALLBACKS}->{$reqPath}}($requestObj->Env(),$requestObj->Cookie()); $responseObj = new Net::HTTPServer::Response(code=>$response->[0], headers=>$response->[1], body=>$response->[2], ); } else { $responseObj = &{$self->{CALLBACKS}->{$reqPath}}($requestObj); } } elsif ($method eq "file") { my $auth = $self->_HandleAuth($requestObj); return $auth if defined($auth); $self->_debug("PROC","_ProcessRequest: File"); $responseObj = $self->_ServeFile($reqPath); } else { $self->_debug("PROC","_ProcessRequest: Not found"); $responseObj = $self->_NotFound(); } return $responseObj; } ############################################################################### # # _ReadRequest - Take the full request, pull out the type, url, GET, POST, etc. # ############################################################################### sub _ReadRequest { my $self = shift; my $request = shift; my $requestObj = new Net::HTTPServer::Request(chroot=>$self->{CFG}->{CHROOT}, request=>$request, server=>$self, ); $self->_debug("REQ","_ReadRequest: method(".$requestObj->Method().") url(".$requestObj->URL().")"); $self->_debug("REQ","_ReadRequest: request(".$requestObj->Request().")"); $self->_log($requestObj->Method()." ".$requestObj->URL()); return $requestObj; } ############################################################################### # # _RegexMatch - loop through all of the regex callbacks and see if any match # the request path. # ############################################################################### sub _RegexMatch { my $self = shift; my $reqPath = shift; return unless exists($self->{REGEXCALLBACKS}); foreach my $regex (sort {$self->{REGEXCALLBACKS}->{$a}->{id} <=> $self->{REGEXCALLBACKS}->{$b}->{id}} keys(%{$self->{REGEXCALLBACKS}})) { return $self->{REGEXCALLBACKS}->{$regex}->{callback} if ($reqPath =~ /$regex/); } return; } ############################################################################### # # _ReturnResponse - Take all of the pieces and generate the reponse, and send # it out. # ############################################################################### sub _ReturnResponse { my $self = shift; my $client = shift; my $requestObj = shift; my $responseObj = shift; #------------------------------------------------------------------------- # If this is not a redirect... #------------------------------------------------------------------------- if (!$responseObj->Header("Location")) { #--------------------------------------------------------------------- # Initialize the content type #--------------------------------------------------------------------- $responseObj->Header("Content-Type","text/html") unless $responseObj->Header("Content-Type"); #--------------------------------------------------------------------- # Check that it's acceptable to the client #--------------------------------------------------------------------- if ($requestObj->Header("Accept")) { $responseObj = $self->_NotAcceptable() unless $self->_accept($requestObj->Header("Accept"), $responseObj->Header("Content-Type") ); } #--------------------------------------------------------------------- # Initialize any missing (and required) headers #--------------------------------------------------------------------- $responseObj->Header("Accept-Ranges","none"); $responseObj->Header("Allow",join(", ",keys(%ALLOWED))); $responseObj->Header("Content-Length",length($responseObj->Body())) unless $responseObj->Header("Content-Length"); $responseObj->Header("Connection","close"); $responseObj->Header("Date",&_date()); $responseObj->Header("Server",join(" ",@{$self->{SERVER_TOKENS}})); } #------------------------------------------------------------------------- # If this was a HEAD, then there is no response #------------------------------------------------------------------------- $responseObj->Clear() if ($requestObj->Method() eq "HEAD"); if ($requestObj->Method() eq "TRACE") { $responseObj->Header("Content-Type","message/http"); $responseObj->Body($requestObj->Request()); } my ($header,$body) = $responseObj->_build(); #------------------------------------------------------------------------- # Debug #------------------------------------------------------------------------- $self->_debug("RESP","_ReturnResponse: ----------------------------------------"); $self->_debug("RESP","_ReturnResponse: $header"); if (($responseObj->Header("Content-Type") eq "text/html") || ($responseObj->Header("Content-Type") eq "text/plain")) { $self->_debug("RESP","_ReturnResponse: $body"); } $self->_debug("RESP","_ReturnResponse: ----------------------------------------"); #------------------------------------------------------------------------- # Send the headers and response #------------------------------------------------------------------------- return unless defined($self->_send($client,$header)); return unless defined($self->_send($client,$body)); } ############################################################################### # # _ServeFile - If they asked for a valid file in the file system, then we need # to suck it in, profile it, and ship it back out. # ############################################################################### sub _ServeFile { my $self = shift; my $path = shift; my $fullpath = $self->{CFG}->{DOCROOT}."/$path"; $self->_debug("FILE","_ServeFile: fullpath($fullpath)"); if (-d $fullpath) { $self->_debug("FILE","_ServeFile: This is a directory."); if ($path !~ /\/$/) { return $self->_Redirect($path."/"); } $self->_debug("FILE","_ServeFile: Show a directory listing."); return $self->_DirList($path); } if (!(-f $fullpath)) { $self->_debug("FILE","_ServeFile: 404, File not found. Whoop! Whoop!"); return $self->_NotFound(); } my $fileHandle = new FileHandle($fullpath); return $self->_NotFound() unless defined($fileHandle); my $response = new Net::HTTPServer::Response(); my ($ext) = ($fullpath =~ /\.([^\.]+?)$/); if (($ext ne "") && exists($self->{MIMETYPES}->{$ext})) { $response->Header("Content-Type",$self->{MIMETYPES}->{$ext}); } elsif (-T $fullpath) { $response->Header("Content-Type",$self->{MIMETYPES}->{txt}); } $response->Header("Content-Length",(stat( $fullpath ))[7]); $response->Header("Last-Modified",&_date((stat( $fullpath ))[9])); $response->Body($fileHandle); return $response; } ############################################################################### #+----------------------------------------------------------------------------- #| Private Canned Responses #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # _Auth - Send an authentication response # ############################################################################### sub _Auth { my $self = shift; my $method = shift; my $args = shift; my @directives = ""; foreach my $key (keys(%{$args})) { push(@directives,$key.'="'.$args->{$key}.'"'); } my $directives = join(",",@directives); return $self->_Error("401", { 'WWW-Authenticate' => "$method $directives" }, "Unauthorized", "Authorization is required to access this object on this server." ); } ############################################################################### # # _AuthBasic - Send a Basic authentication response # ############################################################################### sub _AuthBasic { my $self = shift; my $realm = shift; return $self->_Auth("Basic",{ realm=>$realm }); } ############################################################################### # # _AuthDigest - Send a Digest authentication response # ############################################################################### sub _AuthDigest { my $self = shift; my $args = shift; return $self->_Auth("Digest",$args); } ############################################################################### # # _BadRequest - 400, someone was being naughty # ############################################################################### sub _BadRequest { my $self = shift; return $self->_Error("400", {}, "Bad Request", "You made a bad request. Something you sent did not match up.", ); } ############################################################################### # # _DirList - If they want a directory... let's give them a directory. # ############################################################################### sub _DirList { my $self = shift; my $path = shift; my $res = "Dir listing for $path\n"; opendir(DIR,$self->{CFG}->{DOCROOT}."/".$path); foreach my $file (sort {$a cmp $b} readdir(DIR)) { next if ($file eq "."); next if (($file eq "..") && ($path eq "/")); if ($file =~ /\:/) { $res .= "$file
\n"; } else { $res .= "$file
\n"; } } $res .= "\n"; return new Net::HTTPServer::Response(body=>$res); } ############################################################################### # # _Error - take a code, headers, error string, and text and return a standard # response. # ############################################################################### sub _Error { my $self = shift; my $code = shift; my $headers = shift; my $string = shift; my $body = shift; my $response = ""; $response .= "".$string."!"; $response .= ""; $response .= "

".$string."!

"; $response .= "
".$body."
"; $response .= "

Error ".$code."

"; $response .= ""; $response .= ""; return new Net::HTTPServer::Response(code=>$code, headers=>$headers, body=>$response, ); } ############################################################################### # # _ExpectationFailed - 417, sigh... I never meet anyone's expectations # ############################################################################### sub _ExpectationFailed { my $self = shift; return $self->_Error("400", {}, "Expectation Failed", "The server could not meet the expectations you had for it." ); } ############################################################################### # # _Forbidden - ahhh the equally dreaded 403 # ############################################################################### sub _Forbidden { my $self = shift; return $self->_Error("403", {}, "Forbidden", "You do not have permission to access this object on this server.", ); } ############################################################################### # # _LengthRequired - 411, we got a Transfer-Encoding that was not set to # "identity". # ############################################################################### sub _LengthRequired { my $self = shift; return $self->_Error("411", {}, "Length Required", "You must specify the length of the request.", ); } ############################################################################### # # _MethodNotAllowed - 405... you must only do what is allowed # ############################################################################### sub _MethodNotAllowed { my $self = shift; return $self->_Error("405", {}, "Method Not Allowed", "You are not allowed to do what you just tried to do..." ); } ############################################################################### # # _NotAcceptable - the client is being inflexiable... they won't accept what # we want to send. # ############################################################################### sub _NotAcceptable { my $self = shift; return $self->_Error("406", {}, "Not Acceptable", "The server wants to return a file in a format that your browser does not accept.", ); } ############################################################################### # # _NotFound - ahhh the dreaded 404 # ############################################################################### sub _NotFound { my $self = shift; return $self->_Error("404", {}, "Not Found", "The requested URL was not found on this server. If you entered the URL manually please check your spelling and try again." ); } ############################################################################### # # _Options - returns a response to an OPTIONS request # ############################################################################### sub _Options { my $self = shift; return new Net::HTTPServer::Response(code=>200, headers=>{}, body=>"", ); } ############################################################################### # # _Redirect - Excuse me. You need to be going somewhere else... # ############################################################################### sub _Redirect { my $self = shift; my $url = shift; return new Net::HTTPServer::Response(code=>"307", headers=>{ Location=>$url }, ); } ############################################################################### #+----------------------------------------------------------------------------- #| Private Socket Functions #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # _read - Read it all in. All of it. # ############################################################################### sub _read { my $self = shift; my $client = shift; $self->_nonblock($client); my $select = new IO::Select($client); my $request = ""; my $headers = ""; my $got_request = 0; my $body_length = 0; my $timeEnd = time+5; my $done = 1; my $met_expectation = 0; while(!$got_request) { while( $request !~ /\015?\012\015?\012/s) { $self->_read_chunk($select,$client,\$request); return if (time >= $timeEnd); } if ($headers eq "") { ($headers) = ($request =~ /^(.+?\015?\012\015?\012)/s); if ($headers =~ /^Content-Length\s*:\s*(\d+)\015?\012?$/im) { $body_length = $1; } } if (!$met_expectation && ($request =~ /^Expect\s*:\s*(.+?)\015?\012?$/im)) { my $expect = $1; if ($expect eq "100-continue") { $self->_send($client,"HTTP/1.1 100\n"); $met_expectation = 1; } else { return $request."\012\012"; } } $self->_debug("READ","_read: length: request (",length($request),")"); $self->_debug("READ","_read: length: headers (",length($headers),")"); $self->_debug("READ","_read: length: body (",$body_length,")"); if (length($request) == (length($headers) + $body_length)) { $self->_debug("READ","_read: Ok. We got a request."); $got_request = 1; } else { my $status = $self->_read_chunk($select,$client,\$request); return unless defined($status); $got_request = 1 if ($status == 0); return if (time >= $timeEnd); } } return $request; } ############################################################################### # # _read_chunk - Read a chunk at a time. # ############################################################################### sub _read_chunk { my $self = shift; my $select = shift; my $client = shift; my $request = shift; if ($select->can_read(.01)) { my $status = $client->sysread($$request,4*POSIX::BUFSIZ,length($$request)); if (!defined($status)) { $self->_debug("READ","_read_chunk: Something... isn't... right... whoa!"); } elsif ($status == 0) { $self->_debug("READ","_read_chunk: End of file."); } else { $self->_debug("READ","_read_chunk: status($status)\n"); $self->_debug("READ","_read_chunk: request($$request)\n"); } return $status; } return 1; } ############################################################################### # # _send - helper function to keep sending until all of the data has been # returned. # ############################################################################### sub _send { my $self = shift; my $sock = shift; my $data = shift; if (ref($data) eq "") { return unless defined($self->_send_data($sock,$data)); } if (ref($data) eq "FileHandle") { while(my $temp = <$data>) { return unless defined($self->_send_data($sock,$temp)); } } return 1; } ############################################################################### # # _send_data - helper function to keep sending until all of the data has been # returned. # ############################################################################### sub _send_data { my $self = shift; my $sock = shift; my $data = shift; my $select = new IO::Select($sock); my $length = length($data); my $offset = 0; while (($length != 0) && $select->can_write()) { $self->_debug("SEND","_send_data: offset($offset) length($length)"); my $written = $sock->syswrite($data,$length,$offset); if (defined($written)) { $self->_debug("SEND","_send_data: written($written)"); $length -= $written; $offset += $written; } else { $self->_debug("SEND","_send_data: error"); return; } } $self->_debug("SEND","_send_data: sent all data"); return 1; } ############################################################################### #+----------------------------------------------------------------------------- #| Private Server Functions #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # _forking_huntsman - Kill all of the child processes # ############################################################################### sub _forking_huntsman { my $self = shift; $self->_debug("PROC","_forking_hunstman: Killing children"); $self->_log("Killing children"); $SIG{CHLD} = 'IGNORE'; if (scalar(keys(%{$self->{CHILDREN}})) > 0) { kill("INT",keys(%{$self->{CHILDREN}})); } } ############################################################################### # # _forking_process - This is a forking model. # ############################################################################### sub _forking_process { my $self = shift; while($self->{NUMCHILDREN} < $self->{CFG}->{NUMPROC}) { $self->_forking_spawn(); } select(undef,undef,undef,0.1); } ############################################################################### # # _forking_reaper - When a child dies, have a funeral, mourn, and then move on # ############################################################################### sub _forking_reaper { my $self = shift; $SIG{CHLD} = sub{ $self->_forking_reaper(); }; my $pid = wait; if (exists($self->{CHILDREN}->{$pid})) { $self->{NUMCHILDREN}--; delete($self->{CHILDREN}->{$pid}); } } ############################################################################### # # _forking_spawn - Give birth to a new child process # ############################################################################### sub _forking_spawn { my $self = shift; my $pid; croak("Could not fork: $!") unless defined ($pid = fork); if ($pid) { $self->{CHILDREN}->{$pid} = 1; $self->{NUMCHILDREN}++; return; } else { $SIG{INT} = $SIG{TERM} = $SIG{HUP} = 'DEFAULT'; $SIG{PIPE} = 'DEFAULT'; my $max_clients = 20; # Make this a config? foreach my $i (0..$max_clients) { my $client; if($self->{SELECT}->can_read()) { $client = $self->{SOCK}->accept(); } last unless defined($client); $self->_process($client); } exit; } } ############################################################################### # # _process - Handle a client. # ############################################################################### sub _process { my $self = shift; my $client = shift; $self->_debug("PROC","_process: We have a client, let's treat them well."); $client->autoflush(1); my $request = $self->_read($client); #-------------------------------------------------------------------------- # Take the request and do the magic #-------------------------------------------------------------------------- if (defined($request)) { #---------------------------------------------------------------------- # Create the Request Object #---------------------------------------------------------------------- my $requestObj = $self->_ReadRequest($request); #---------------------------------------------------------------------- # Profile the client #---------------------------------------------------------------------- my $other_end = $client->peername(); if ($other_end) { my ($port, $iaddr) = unpack_sockaddr_in($other_end); my $ip_addr = inet_ntoa($iaddr); $requestObj->_env("REMOTE_ADDR",$ip_addr); my $hostname = gethostbyaddr($iaddr, AF_INET); $requestObj->_env("REMOTE_NAME",$hostname) if ($hostname); } $requestObj->_env("DOCUMENT_ROOT",$self->{CFG}->{DOCROOT}) if defined($self->{CFG}->{DOCROOT}); $requestObj->_env("GATEWAY_INTERFACE","CGI/1.1"); $requestObj->_env("HTTP_REFERER",$requestObj->Header("Referer")) if defined($requestObj->Header("Referer")); $requestObj->_env("HTTP_USER_AGENT",$requestObj->Header("User-Agent")) if defined($requestObj->Header("User-Agent")); $requestObj->_env("QUERY_STRING",$requestObj->Query()); $requestObj->_env("REQUEST_METHOD",$requestObj->Method()); $requestObj->_env("SCRIPT_NAME",$requestObj->Path()); $requestObj->_env("SERVER_ADMIN",$self->{CFG}->{ADMIN}); $requestObj->_env("SERVER_NAME",$self->{SERVER}->{NAME}); $requestObj->_env("SERVER_PORT",$self->{SERVER}->{PORT}); $requestObj->_env("SERVER_PROTOCOL",$requestObj->Protocol()); $requestObj->_env("SERVER_SOFTWARE",join(" ",@{$self->{SERVER_TOKENS}})); #---------------------------------------------------------------------- # Process the Request #---------------------------------------------------------------------- my $responseObj = $self->_ProcessRequest($requestObj); #---------------------------------------------------------------------- # Return the Response #---------------------------------------------------------------------- $self->_ReturnResponse($client,$requestObj,$responseObj); } #------------------------------------------------------------------ # That's it. Close down the connection. #------------------------------------------------------------------ $client->close() if ($self->{CFG}->{SSL} == 0); $client->close(SSL_no_shutdown=>1) if ($self->{CFG}->{SSL} == 1); $self->_debug("PROC","_process: Thanks for shopping with us!"); } ############################################################################### # # _single_process - This is a single process model. # ############################################################################### sub _single_process { my $self = shift; my $timestop = shift; my $client; my $clientSelect; my $wait = (defined($timestop) ? $timestop - time : 10); $self->_debug("PROC","_single_process: Wait for $wait seconds"); #------------------------------------------------------------------ # Take the request and do the magic #------------------------------------------------------------------ if ($self->{SELECT}->can_read($wait)) { $self->_debug("PROC","_single_process: Incoming traffic"); $client = $self->{SOCK}->accept(); } if (defined($client)) { $self->_process($client); } } ############################################################################### #+----------------------------------------------------------------------------- #| Private Utility Functions #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # _accept - given an Accept line and Content-Type, is it in the list? # ############################################################################### sub _accept { my $self = shift; my $accept = shift; my $contentType = shift; $accept =~ s/\s*\,\s*/\,/g; $accept =~ s/\s*\;\s*/\;/g; $accept =~ s/\s*$//; my ($mainType,$subType) = split("/",$contentType,2); foreach my $entry (split(",",$accept)) { my ($testType,$scale) = split(";",$entry,2); return 1 if ($testType eq $contentType); return 1 if ($testType eq "$mainType/*"); return 1 if ($testType eq "*/*"); } return; } ############################################################################### # # _arg - if the arg exists then use it, else use the default. # ############################################################################### sub _arg { my $self = shift; my $arg = shift; my $default = shift; my $valid = shift; my $val = (exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default); if (defined($valid)) { my $pass = 0; foreach my $check (@{$valid}) { $pass = 1 if ($check eq $val); } if ($pass == 0) { croak("Invalid value for setting '$arg' = '$val'. Valid are: ['".join("','",@{$valid})."']"); } } return $val; } ############################################################################### # # _checkAuth - return 1 if the url requires an Auth, undefined otherwise. # ############################################################################### sub _checkAuth { my $self = shift; my $url = shift; my @url = split("/",$url); foreach my $i (reverse 0..$#url) { my $check = join("/",@url[0..$i]); if($check eq "") { $check = "/"; } $self->_debug("AUTH","_checkAuth: check($check)"); return $check if exists($self->{AUTH}->{$check}); } return; } ############################################################################### # # _date - format the date correctly for the given time. # ############################################################################### sub _date { my $time = shift; my $delta = shift; $time = time unless defined($time); $time += $delta if defined($delta); my @times = gmtime($time); my $date = sprintf("%s, %02d-%s-%d %02d:%02d:%02d GMT", (qw(Sun Mon Tue Wed Thu Fri Sat))[$times[6]], $times[3], (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$times[4]], $times[5]+1900, $times[2], $times[1], $times[0] ); return $date; } ############################################################################### # # _debug - print out a debug message # ############################################################################### sub _debug { my $self = shift; my $zone = shift; my (@message) = @_; my $fh = $self->{DEBUGLOG}; print $fh "$zone: ",join("",@message),"\n" if (exists($self->{DEBUGZONES}->{$zone}) || exists($self->{DEBUGZONES}->{ALL})); } ############################################################################### # # _digest_HA1 - calculate the H(A1) per RFC2617 # ############################################################################### sub _digest_HA1 { my $self = shift; my $auth = shift; my $passwd = shift; my @raw; push(@raw,$auth->{username}); push(@raw,$auth->{realm}); push(@raw,$passwd); my $raw = join(":",@raw); #$self->_debug("AUTH","_digest_HA1: raw($raw)"); return Digest::MD5::md5_hex($raw); } ############################################################################### # # _digest_HA2 - calculate the H(A2) per RFC2617 # ############################################################################### sub _digest_HA2 { my $self = shift; my $auth = shift; my $method = shift; my @raw; push(@raw,$method); push(@raw,$auth->{uri}); my $raw = join(":",@raw); #$self->_debug("AUTH","_digest_HA2: raw($raw)"); return Digest::MD5::md5_hex($raw); } ############################################################################### # # _digest_KD - calculate the KD() per RFC2617 # ############################################################################### sub _digest_KD { my $self = shift; my $auth = shift; my $ha1 = shift; my $ha2 = shift; my @raw; push(@raw,$ha1); push(@raw,$auth->{nonce}); if(exists($auth->{qop}) && ($auth->{qop} eq "auth")) { push(@raw,$auth->{nc}); push(@raw,$auth->{cnonce}); push(@raw,$auth->{qop}); } push(@raw,$ha2); my $raw = join(":",@raw); #$self->_debug("AUTH","_digest_KD: raw($raw)"); return Digest::MD5::md5_hex($raw); } ############################################################################### # # _log - print out the message to a log with the current time # ############################################################################### sub _log { my $self = shift; my (@message) = @_; my $fh = $self->{LOG}; print $fh $self->_timestamp()," - ",join("",@message),"\n"; } ############################################################################### # # _mimetypes - Read in the mime.types file # ############################################################################### sub _mimetypes { my $self = shift; open(MT,$self->{CFG}->{MIMETYPES}); while() { next if /^\#/; next if /^\s+$/; my ($mime_type,$extensions) = /^(\S+)(.*?)$/; next if ($extensions =~ /^\s*$/); $extensions =~ s/\s+/\ /g; foreach my $ext (split(" ",$extensions)) { next if ($ext eq ""); $self->{MIMETYPES}->{$ext} = $mime_type; } } close(MT); } ############################################################################### # # _nonblock - given a socket, make it non-blocking # ############################################################################### sub _nonblock { my $self = shift; my $socket = shift; #-------------------------------------------------------------------------- # Code copied from POE::Wheel::SocketFactory... # Win32 does things one way... #-------------------------------------------------------------------------- if (($^O eq "MSWin32") || ($^O eq "cygwin")) { my $FIONBIO = 0x8004667E; my $temp = 1; ioctl( $socket, $FIONBIO, \$temp) || croak("Can't make socket nonblocking (".$^O."): $!"); return; } #-------------------------------------------------------------------------- # And UNIX does them another #-------------------------------------------------------------------------- my $flags = fcntl($socket, F_GETFL, 0) || croak("Can't get flags for socket: $!\n"); fcntl($socket, F_SETFL, $flags | O_NONBLOCK) || croak("Can't make socket nonblocking: $!\n"); } ############################################################################### # # _nonce - produce a new nonce # ############################################################################### sub _nonce { my $self = shift; return MIME::Base64::encode(time.":".$self->{PRIVATEKEY},""); } ############################################################################### # # _timestamp - generic funcion for getting a timestamp. # ############################################################################### sub _timestamp { my $self = shift; my ($sec,$min,$hour,$mday,$mon,$year,$wday) = localtime(time); my $month = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')[$mon]; $mon++; return sprintf("%d/%02d/%02d %02d:%02d:%02d",($year + 1900),$mon,$mday,$hour,$min,$sec); } 1; Net-HTTPServer-1.1.1/t/0002755000175000017500000000000010176251426015611 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/t/req_sessions/0002755000175000017500000000000010176251426020326 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/t/req_sessions/ea209023f1f3908dd9a39c256be04e550000644000175000017500000000024610124076513024542 0ustar reatmonreatmon00000000000000%data = ( 'bar' => [ '1', '2', 'b' ], 'foo' => 'bar' ); Net-HTTPServer-1.1.1/t/requests/0002755000175000017500000000000010176251426017464 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/t/requests/req20000644000175000017500000000107010124076513020247 0ustar reatmonreatmon00000000000000GET /perl-logo.jpg HTTP/1.1 Host: localhost:8001 User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2 Accept: image/png,*/*;q=0.5 Accept-Encoding: gzip,deflate Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7 Keep-Alive: 300 Connection: keep-alive Referer: http://localhost:8001/ Authorization: Digest username="foo", realm="Test", nonce="MTA4ODcxNzc1Njo5YjNjMDA2NmYzZjVjMGU5OGEwOTg0YTk2YzBiZmFkMA==", uri="/perl-logo.jpg", algorithm=MD5, response="3f0d34d8e103b2a57b3f86a74cbea3cc", qop=auth, nc=00000001, cnonce="bd25b487957ed9a2" Net-HTTPServer-1.1.1/t/requests/req50000644000175000017500000000130010124076513020246 0ustar reatmonreatmon00000000000000GET /env.pl?test1=foo&test2=bar HTTP/1.1 Host: localhost:8001 User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2 Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 Accept-Encoding: gzip,deflate Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7 Keep-Alive: 300 Connection: keep-alive Cookie: NETHTTPSERVERSESSION=ea209023f1f3908dd9a39c256be04e55 Authorization: Digest username="foo", realm="Test", nonce="MTA4ODcxODk1ODo5YmE3MWZjN2EzOGIzOWM5YWJhZjFiM2RkNjkyNTU4MQ==", uri="/env.pl?test1=foo&test2=bar", algorithm=MD5, response="ed962b59fa90def8432cf04916539a2a", qop=auth, nc=00000001, cnonce="1e0d10d8225dc588" Net-HTTPServer-1.1.1/t/requests/req40000644000175000017500000000156410124076513020261 0ustar reatmonreatmon00000000000000POST /foo/bar.pl HTTP/1.1 Host: localhost:8001 User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2 Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 Accept-Encoding: gzip,deflate Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7 Keep-Alive: 300 Connection: keep-alive Referer: http://localhost:8001/test.html Cookie: NETHTTPSERVERSESSION=ea209023f1f3908dd9a39c256be04e55 Authorization: Digest username="foo", realm="Test", nonce="MTA4ODcxODkxMzo5YmE3MWZjN2EzOGIzOWM5YWJhZjFiM2RkNjkyNTU4MQ==", uri="/foo/bar.pl", algorithm=MD5, response="ecf1ef3fcc82d9cab6849fa986118311", qop=auth, nc=00000003, cnonce="2a1b2b1e0723ba9e" Content-Type: application/x-www-form-urlencoded Content-Length: 102 file1=%2Fhome%2Freatmon%2Fdevel%2Fdiff_test%2Ftest&file2=%2Fhome%2Freatmon%2Fdevel%2Fdiff_test%2Ftest2 Net-HTTPServer-1.1.1/t/requests/req30000644000175000017500000000126310124076513020254 0ustar reatmonreatmon00000000000000GET /session HTTP/1.1 Host: localhost:8001 User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2 Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 Accept-Encoding: gzip,deflate Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7 Keep-Alive: 300 Connection: keep-alive Cookie: NETHTTPSERVERSESSION=ea209023f1f3908dd9a39c256be04e55 Authorization: Digest username="foo", realm="Test", nonce="MTA4ODcxNzg2Mzo5YmE3MWZjN2EzOGIzOWM5YWJhZjFiM2RkNjkyNTU4MQ==", uri="/session", algorithm=MD5, response="baa2e104080fb5964e0dfcc4cb2280ff", qop=auth, nc=00000002, cnonce="29d500603edc385b" Cache-Control: max-age=0 Net-HTTPServer-1.1.1/t/requests/req10000644000175000017500000000053610124076513020254 0ustar reatmonreatmon00000000000000GET / HTTP/1.1 Host: localhost:8001 User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2 Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 Accept-Encoding: gzip,deflate Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7 Keep-Alive: 300 Connection: keep-alive Net-HTTPServer-1.1.1/t/request.t0000644000175000017500000002403710124076512017464 0ustar reatmonreatmon00000000000000use lib "t/lib"; use File::Copy; use Test::More tests=>78; BEGIN{ use_ok( "Net::HTTPServer" ); use_ok( "Net::HTTPServer::Session" ); use_ok( "Net::HTTPServer::Request" ); } my $server = new Net::HTTPServer(sessions=>1,datadir=>"t/sessions",log=>"t/access.log"); ok( defined($server), "new()"); isa_ok( $server, "Net::HTTPServer"); my $request = new Net::HTTPServer::Request(); ok( defined($request), "new()"); isa_ok( $request, "Net::HTTPServer::Request"); is_deeply( $request->Cookie(), {}, "No cookies"); is_deeply( $request->Env(), {}, "No environment"); is_deeply( $request->Header(), {}, "No headers"); is( $request->Method(), undef, "No method"); is( $request->Path(), undef, "No path"); is( $request->Request(), undef, "No request"); is( $request->URL(), undef, "No URL"); #----------------------------------------------------------------------------- # requests/req1 #----------------------------------------------------------------------------- my $file1 = &readFile("t/requests/req1"); my $request1 = new Net::HTTPServer::Request(request=>$file1, server=>$server, ); ok( defined($request1), "new()"); isa_ok( $request1, "Net::HTTPServer::Request"); is_deeply( $request1->Cookie(), {}, "No cookies"); is_deeply( $request1->Env(), {}, "No environment"); is_deeply( $request1->Header(), { "host"=>"localhost:8001", "user-agent"=>"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2", "accept"=>"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5", "accept-encoding"=>"gzip,deflate", "accept-charset"=>"ISO-8859-1,utf-8;q=0.7,*;q=0.7", "keep-alive"=>"300", "connection"=>"keep-alive", }, "Some headers"); is( $request1->Method(), "GET", "method == GET"); is( $request1->Path(), "/", "path == /"); is( $request1->Request(), $file1, "Requests match"); is( $request1->URL(), "/", "URL == /"); is( $request1->Header("test"), undef, "Header(test) = undef"); is( $request1->Header("Host"), "localhost:8001", "Header(Host) = localhost:8001"); is( $request1->Header("host"), "localhost:8001", "Header(host) = localhost:8001"); is( $request1->Header("HOST"), "localhost:8001", "Header(HOST) = localhost:8001"); #----------------------------------------------------------------------------- # requests/req2 #----------------------------------------------------------------------------- my $file2 = &readFile("t/requests/req2"); my $request2 = new Net::HTTPServer::Request(request=>$file2, server=>$server, ); ok( defined($request2), "new()"); isa_ok( $request2, "Net::HTTPServer::Request"); is_deeply( $request2->Cookie(), {}, "No cookies"); is_deeply( $request2->Env(), {}, "No environment"); is_deeply( $request2->Header(), { "host"=>"localhost:8001", "user-agent"=>"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2", "accept"=>"image/png,*/*;q=0.5", "accept-encoding"=>"gzip,deflate", "accept-charset"=>"ISO-8859-1,utf-8;q=0.7,*;q=0.7", "keep-alive"=>"300", "connection"=>"keep-alive", "authorization"=>'Digest username="foo", realm="Test", nonce="MTA4ODcxNzc1Njo5YjNjMDA2NmYzZjVjMGU5OGEwOTg0YTk2YzBiZmFkMA==", uri="/perl-logo.jpg", algorithm=MD5, response="3f0d34d8e103b2a57b3f86a74cbea3cc", qop=auth, nc=00000001, cnonce="bd25b487957ed9a2"', "referer"=>"http://localhost:8001/", }, "Some headers"); is( $request2->Method(), "GET", "method == GET"); is( $request2->Path(), "/perl-logo.jpg", "path == /perl-logo.jpg"); is( $request2->Request(), $file2, "Requests match"); is( $request2->URL(), "/perl-logo.jpg", "URL == /perl-logo.jpg"); #----------------------------------------------------------------------------- # requests/req3 #----------------------------------------------------------------------------- my $file3 = &readFile("t/requests/req3"); my $request3 = new Net::HTTPServer::Request(request=>$file3, server=>$server, ); ok( defined($request3), "new()"); isa_ok( $request3, "Net::HTTPServer::Request"); is_deeply( $request3->Cookie(), { "NETHTTPSERVERSESSION"=>"ea209023f1f3908dd9a39c256be04e55", }, "One cookie"); is_deeply( $request3->Env(), {}, "No environment"); is_deeply( $request3->Header(), { "host"=>"localhost:8001", "user-agent"=>"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2", "accept"=>"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5", "accept-encoding"=>"gzip,deflate", "accept-charset"=>"ISO-8859-1,utf-8;q=0.7,*;q=0.7", "keep-alive"=>"300", "connection"=>"keep-alive", "authorization"=>'Digest username="foo", realm="Test", nonce="MTA4ODcxNzg2Mzo5YmE3MWZjN2EzOGIzOWM5YWJhZjFiM2RkNjkyNTU4MQ==", uri="/session", algorithm=MD5, response="baa2e104080fb5964e0dfcc4cb2280ff", qop=auth, nc=00000002, cnonce="29d500603edc385b"', "cache-control"=>"max-age=0", "cookie"=>"NETHTTPSERVERSESSION=ea209023f1f3908dd9a39c256be04e55", }, "Some headers"); is( $request3->Method(), "GET", "method == GET"); is( $request3->Path(), "/session", "path == /session"); is( $request3->Request(), $file3, "Requests match"); is( $request3->URL(), "/session", "URL == /session"); is( $request3->Cookie("test"),undef, "cookie(test) == undef"); is( $request3->Cookie("NETHTTPSERVERSESSION"),"ea209023f1f3908dd9a39c256be04e55", "cookie(NETHTTPSERVERSESSION) == ea209023f1f3908dd9a39c256be04e55"); File::Copy::cp("t/req_sessions/ea209023f1f3908dd9a39c256be04e55","t/sessions/ea209023f1f3908dd9a39c256be04e55"); my $session = $request3->Session(); ok( defined($session), "Session()"); isa_ok( $session, "Net::HTTPServer::Session"); ok( !$session->Exists("test"), "test does not exist"); ok( $session->Exists("foo"), "foo exists"); ok( $session->Exists("bar"), "bar exists"); is( $session->Get("foo"), "bar", "foo = bar"); is_deeply( $session->Get("bar"), ["1","2","b"], "bar = [1,2,b]" ); #----------------------------------------------------------------------------- # requests/req4 #----------------------------------------------------------------------------- my $file4 = &readFile("t/requests/req4"); my $request4 = new Net::HTTPServer::Request(request=>$file4, server=>$server, ); ok( defined($request4), "new()"); isa_ok( $request4, "Net::HTTPServer::Request"); is_deeply( $request4->Cookie(), { "NETHTTPSERVERSESSION"=>"ea209023f1f3908dd9a39c256be04e55", }, "One cookie"); is_deeply( $request4->Env(), { "file1"=>"/home/reatmon/devel/diff_test/test", "file2"=>"/home/reatmon/devel/diff_test/test2", }, "Two vars"); is_deeply( $request4->Header(), { "host"=>"localhost:8001", "user-agent"=>"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2", "accept"=>"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5", "accept-encoding"=>"gzip,deflate", "accept-charset"=>"ISO-8859-1,utf-8;q=0.7,*;q=0.7", "keep-alive"=>"300", "connection"=>"keep-alive", "authorization"=>'Digest username="foo", realm="Test", nonce="MTA4ODcxODkxMzo5YmE3MWZjN2EzOGIzOWM5YWJhZjFiM2RkNjkyNTU4MQ==", uri="/foo/bar.pl", algorithm=MD5, response="ecf1ef3fcc82d9cab6849fa986118311", qop=auth, nc=00000003, cnonce="2a1b2b1e0723ba9e"', "cookie"=>"NETHTTPSERVERSESSION=ea209023f1f3908dd9a39c256be04e55", "content-length"=>"102", "content-type"=>"application/x-www-form-urlencoded", "referer"=>"http://localhost:8001/test.html", }, "Some headers"); is( $request4->Method(), "POST", "method == POST"); is( $request4->Path(), "/foo/bar.pl", "path == /foo/bar.pl"); is( $request4->Request(), $file4, "Requests match"); is( $request4->URL(), "/foo/bar.pl", "URL == /foo/bar.pl"); is( $request4->Env("test"),undef,"env(test) == undef"); is( $request4->Env("file1"),"/home/reatmon/devel/diff_test/test","env(file1) == /home/reatmon/devel/diff_test/test"); is( $request4->Env("file2"),"/home/reatmon/devel/diff_test/test2","env(file2) == /home/reatmon/devel/diff_test/test2"); #----------------------------------------------------------------------------- # requests/req5 #----------------------------------------------------------------------------- my $file5 = &readFile("t/requests/req5"); my $request5 = new Net::HTTPServer::Request(request=>$file5, server=>$server, ); ok( defined($request5), "new()"); isa_ok( $request5, "Net::HTTPServer::Request"); is_deeply( $request5->Cookie(), { "NETHTTPSERVERSESSION"=>"ea209023f1f3908dd9a39c256be04e55", }, "One cookie"); is_deeply( $request5->Env(), { "test1"=>"foo", "test2"=>"bar", }, "Two vars"); is_deeply( $request5->Header(), { "host"=>"localhost:8001", "user-agent"=>"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7) Gecko/20040624 Debian/1.7-2", "accept"=>"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5", "accept-encoding"=>"gzip,deflate", "accept-charset"=>"ISO-8859-1,utf-8;q=0.7,*;q=0.7", "keep-alive"=>"300", "connection"=>"keep-alive", "authorization"=>'Digest username="foo", realm="Test", nonce="MTA4ODcxODk1ODo5YmE3MWZjN2EzOGIzOWM5YWJhZjFiM2RkNjkyNTU4MQ==", uri="/env.pl?test1=foo&test2=bar", algorithm=MD5, response="ed962b59fa90def8432cf04916539a2a", qop=auth, nc=00000001, cnonce="1e0d10d8225dc588"', "cookie"=>"NETHTTPSERVERSESSION=ea209023f1f3908dd9a39c256be04e55", }, "Some headers"); is( $request5->Method(), "GET", "method == GET"); is( $request5->Path(), "/env.pl", "path == /env.pl"); is( $request5->Request(), $file5, "Requests match"); is( $request5->URL(), "/env.pl?test1=foo&test2=bar", "URL == /env.pl?test1=foo&test2=bar"); is( $request5->Env("test"),undef,"env(test) == undef"); is( $request5->Env("test1"),"foo","env(test1) == foo"); is( $request5->Env("test2"),"bar","env(test2) == bar"); sub readFile { my $file = shift; open(FILE,$file); my $data = join("",); close(FILE); return $data; } Net-HTTPServer-1.1.1/t/lib/0002755000175000017500000000000010176251426016357 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/t/lib/Test/0002755000175000017500000000000010176251426017276 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/t/lib/Test/Builder.pm0000644000175000017500000007377310124076512021233 0ustar reatmonreatmon00000000000000package Test::Builder; use 5.004; # $^C was only introduced in 5.005-ish. We do this to prevent # use of uninitialized value warnings in older perls. $^C ||= 0; use strict; use vars qw($VERSION $CLASS); $VERSION = '0.17'; $CLASS = __PACKAGE__; my $IsVMS = $^O eq 'VMS'; # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; if( $] >= 5.008 && $Config{useithreads} ) { require threads; require threads::shared; threads::shared->import; } else { *share = sub { 0 }; *lock = sub { 0 }; } } use vars qw($Level); my($Test_Died) = 0; my($Have_Plan) = 0; my $Original_Pid = $$; my $Curr_Test = 0; share($Curr_Test); my @Test_Results = (); share(@Test_Results); my @Test_Details = (); share(@Test_Details); =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use Test::Builder; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(ok); my $Test = Test::Builder->new; $Test->output('my_logfile'); sub import { my($self) = shift; my $pack = caller; $Test->exported_to($pack); $Test->plan(@_); $self->export_to_level(1, $self, 'ok'); } sub ok { my($test, $name) = @_; $Test->ok($test, $name); } =head1 DESCRIPTION Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program, there is B Test::Builder object. No matter how many times you call new(), you're getting the same object. (This is called a singleton). =cut my $Test; sub new { my($class) = shift; $Test ||= bless ['Move along, nothing to see here'], $class; return $Test; } =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This is important for getting TODO tests right. =cut my $Exported_To; sub exported_to { my($self, $pack) = @_; if( defined $pack ) { $Exported_To = $pack; } return $Exported_To; } =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call plan(), don't call any of the other methods below. =cut sub plan { my($self, $cmd, $arg) = @_; return unless $cmd; if( $Have_Plan ) { die sprintf "You tried to plan twice! Second plan at %s line %d\n", ($self->caller)[1,2]; } if( $cmd eq 'no_plan' ) { $self->no_plan; } elsif( $cmd eq 'skip_all' ) { return $self->skip_all($arg); } elsif( $cmd eq 'tests' ) { if( $arg ) { return $self->expected_tests($arg); } elsif( !defined $arg ) { die "Got an undefined number of tests. Looks like you tried to ". "say how many tests you plan to run but made a mistake.\n"; } elsif( !$arg ) { die "You said to run 0 tests! You've got to run something.\n"; } } else { require Carp; my @args = grep { defined } ($cmd, $arg); Carp::croak("plan() doesn't understand @args"); } return 1; } =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the # of tests we expect this test to run and prints out the appropriate headers. =cut my $Expected_Tests = 0; sub expected_tests { my($self, $max) = @_; if( defined $max ) { $Expected_Tests = $max; $Have_Plan = 1; $self->_print("1..$max\n") unless $self->no_header; } return $Expected_Tests; } =item B $Test->no_plan; Declares that this test will run an indeterminate # of tests. =cut my($No_Plan) = 0; sub no_plan { $No_Plan = 1; $Have_Plan = 1; } =item B $plan = $Test->has_plan Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =cut sub has_plan { return($Expected_Tests) if $Expected_Tests; return('no_plan') if $No_Plan; return(undef); }; =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given $reason. Exits immediately with 0. =cut my $Skip_All = 0; sub skip_all { my($self, $reason) = @_; my $out = "1..0"; $out .= " # Skip $reason" if $reason; $out .= "\n"; $Skip_All = 1; $self->_print($out) unless $self->no_header; exit(0); } =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. $name is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if $test is true, fail if $test is false. Just like Test::Simple's ok(). =cut sub ok { my($self, $test, $name) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } lock $Curr_Test; $Curr_Test++; $self->diag(<caller; my $todo = $self->todo($pack); my $out; my $result = {}; share($result); unless( $test ) { $out .= "not "; @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } $out .= "ok"; $out .= " $Curr_Test" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } if( $todo ) { my $what_todo = $todo; $out .= " # TODO $what_todo"; $result->{reason} = $what_todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $Test_Results[$Curr_Test-1] = $result; $out .= "\n"; $self->_print($out); unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->diag(" $msg test ($file at line $line)\n"); } return $test ? 1 : 0; } =item B $Test->is_eq($got, $expected, $name); Like Test::More's is(). Checks if $got eq $expected. This is the string version. =item B $Test->is_num($got, $expected, $name); Like Test::More's is(). Checks if $got == $expected. This is the numeric version. =cut sub is_eq { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, 'eq', $expect) unless $test; return $test; } return $self->cmp_ok($got, 'eq', $expect, $name); } sub is_num { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, '==', $expect) unless $test; return $test; } return $self->cmp_ok($got, '==', $expect, $name); } sub _is_diag { my($self, $got, $type, $expect) = @_; foreach my $val (\$got, \$expect) { if( defined $$val ) { if( $type eq 'eq' ) { # quote and force string context $$val = "'$$val'" } else { # force numeric context $$val = $$val+0; } } else { $$val = 'undef'; } } return $self->diag(sprintf < $Test->isnt_eq($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the string version. =item B $Test->is_num($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the numeric version. =cut sub isnt_eq { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('ne', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, 'ne', $dont_expect, $name); } sub isnt_num { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('!=', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, '!=', $dont_expect, $name); } =item B $Test->like($this, qr/$regex/, $name); $Test->like($this, '/$regex/', $name); Like Test::More's like(). Checks if $this matches the given $regex. You'll want to avoid qr// if you want your tests to work before 5.005. =item B $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); Like Test::More's unlike(). Checks if $this B the given $regex. =cut sub like { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '=~', $name); } sub unlike { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '!~', $name); } =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); Convenience method for building testing functions that take regular expressions as arguments, but need to work before perl 5.005. Takes a quoted regular expression produced by qr//, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or undef if it's argument is not recognised. For example, a version of like(), sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $this, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($this =~ m/$usable_regex/, $name); } =cut sub maybe_regex { my ($self, $regex) = @_; my $usable_regex = undef; if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check if it looks like '/foo/' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; }; return($usable_regex) }; sub _regex_ok { my($self, $this, $regex, $cmp, $name) = @_; local $Level = $Level + 1; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless (defined $usable_regex) { $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { local $^W = 0; my $test = $this =~ /$usable_regex/ ? 1 : 0; $test = !$test if $cmp eq '!~'; $ok = $self->ok( $test, $name ); } unless( $ok ) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; $self->diag(sprintf < $Test->cmp_ok($this, $type, $that, $name); Works just like Test::More's cmp_ok(). $Test->cmp_ok($big_num, '!=', $other_big_num); =cut sub cmp_ok { my($self, $got, $type, $expect, $name) = @_; my $test; { local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! $test = eval "\$got $type \$expect"; } local $Level = $Level + 1; my $ok = $self->ok($test, $name); unless( $ok ) { if( $type =~ /^(eq|==)$/ ) { $self->_is_diag($got, $type, $expect); } else { $self->_cmp_diag($got, $type, $expect); } } return $ok; } sub _cmp_diag { my($self, $got, $type, $expect) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; return $self->diag(sprintf < $Test->BAILOUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =cut sub BAILOUT { my($self, $reason) = @_; $self->_print("Bail out! $reason"); exit 255; } =item B $Test->skip; $Test->skip($why); Skips the current test, reporting $why. =cut sub skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # skip $why\n"; $Test->_print($out); return 1; } =item B $Test->todo_skip; $Test->todo_skip($why); Like skip(), only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =cut sub todo_skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "not ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $Test->_print($out); return 1; } =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like skip(), only it skips all the rest of the tests you plan to run and terminates the test. If you're running under no_plan, it skips once and terminates the test. =end _unimplemented =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should $Test look when reporting where the test failed. Defaults to 1. Setting $Test::Builder::Level overrides. This is typically useful localized: { local $Test::Builder::Level = 2; $Test->ok($test); } =cut sub level { my($self, $level) = @_; if( defined $level ) { $Level = $level; } return $Level; } $CLASS->level(1); =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Test::Harness will accept either, but avoid mixing the two styles. Defaults to on. =cut my $Use_Nums = 1; sub use_numbers { my($self, $use_nums) = @_; if( defined $use_nums ) { $Use_Nums = $use_nums; } return $Use_Nums; } =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described in Test::Simple. If this is true, none of that will be done. =cut my($No_Header, $No_Ending) = (0,0); sub no_header { my($self, $no_header) = @_; if( defined $no_header ) { $No_Header = $no_header; } return $No_Header; } sub no_ending { my($self, $no_ending) = @_; if( defined $no_ending ) { $No_Ending = $no_ending; } return $No_Ending; } =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given $message. Normally, it uses the failure_output() handle, but if this is for a TODO test, the todo_output() handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because diag() is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =cut sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; s/^/# /gms; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; local $Level = $Level + 1; my $fh = $self->todo ? $self->todo_output : $self->failure_output; local($\, $", $,) = (undef, ' ', ''); print $fh @msgs; return 0; } =begin _private =item B<_print> $Test->_print(@msgs); Prints to the output() filehandle. =end _private =cut sub _print { my($self, @msgs) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; # Escape each line after the first with a # so we don't # confuse Test::Harness. foreach (@msgs) { s/\n(.)/\n# $1/sg; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; print $fh @msgs; } =item B $Test->output($fh); $Test->output($file); Where normal "ok/not ok" test output should go. Defaults to STDOUT. =item B $Test->failure_output($fh); $Test->failure_output($file); Where diagnostic output on test failures and diag() should go. Defaults to STDERR. =item B $Test->todo_output($fh); $Test->todo_output($file); Where diagnostics about todo test failures and diag() should go. Defaults to STDOUT. =cut my($Out_FH, $Fail_FH, $Todo_FH); sub output { my($self, $fh) = @_; if( defined $fh ) { $Out_FH = _new_fh($fh); } return $Out_FH; } sub failure_output { my($self, $fh) = @_; if( defined $fh ) { $Fail_FH = _new_fh($fh); } return $Fail_FH; } sub todo_output { my($self, $fh) = @_; if( defined $fh ) { $Todo_FH = _new_fh($fh); } return $Todo_FH; } sub _new_fh { my($file_or_fh) = shift; my $fh; unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; } else { $fh = $file_or_fh; } return $fh; } unless( $^C ) { # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush(\*TESTOUT); _autoflush(\*STDOUT); _autoflush(\*TESTERR); _autoflush(\*STDERR); $CLASS->output(\*TESTOUT); $CLASS->failure_output(\*TESTERR); $CLASS->todo_output(\*TESTOUT); } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; } =back =head2 Test Status and Info =over 4 =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test # we're on. You usually shouldn't have to set this. =cut sub current_test { my($self, $num) = @_; lock($Curr_Test); if( defined $num ) { unless( $Have_Plan ) { require Carp; Carp::croak("Can't change the current test number without a plan!"); } $Curr_Test = $num; if( $num > @Test_Results ) { my $start = @Test_Results ? $#Test_Results + 1 : 0; for ($start..$num-1) { my %result; share(%result); %result = ( ok => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef ); $Test_Results[$_] = \%result; } } } return $Curr_Test; } =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =cut sub summary { my($self) = shift; return map { $_->{'ok'} } @Test_Results; } =item B
my @tests = $Test->details; Like summary(), but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when current_test() is changed. In these cases, Test::Builder doesn't know the result of the test, so it's type is 'unkown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left undef. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since it's todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =cut sub details { return @Test_Results; } =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); todo() looks for a $TODO variable in your tests. If set, all tests will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. todo() is pretty part about finding the right package to look for $TODO in. It uses the exported_to() package to find it. If that's not set, it's pretty good at guessing the right package to look at. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly what $pack to use. =cut sub todo { my($self, $pack) = @_; $pack = $pack || $self->exported_to || $self->caller(1); no strict 'refs'; return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} : 0; } =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal caller(), except it reports according to your level(). =cut sub caller { my($self, $height) = @_; $height ||= 0; my @caller = CORE::caller($self->level + $height + 1); return wantarray ? @caller : $caller[0]; } =back =cut =begin _private =over 4 =item B<_sanity_check> _sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly error message. =cut #'# sub _sanity_check { _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); _whoa(!$Have_Plan and $Curr_Test, 'Somehow your tests ran without a plan!'); _whoa($Curr_Test != @Test_Results, 'Somehow you got a different number of results than tests ran!'); } =item B<_whoa> _whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and a note to contact the author. =cut sub _whoa { my($check, $desc) = @_; if( $check ) { die < _my_exit($exit_num); Perl seems to have some trouble with exiting inside an END block. 5.005_03 and 5.6.1 both seem to do odd things. Instead, this function edits $? directly. It should ONLY be called from inside an END block. It doesn't actually exit, that's your job. =cut sub _my_exit { $? = $_[0]; return 1; } =back =end _private =cut $SIG{__DIE__} = sub { # We don't want to muck with death in an eval, but $^S isn't # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing # with it. Instead, we use caller. This also means it runs under # 5.004! my $in_eval = 0; for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } $Test_Died = 1 unless $in_eval; }; sub _ending { my $self = shift; _sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. do{ _my_exit($?) && return } if $Original_Pid != $$; # Bailout if plan() was never called. This is so # "require Test::Simple" doesn't puke. do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; # Figure out if we passed or failed and print helpful messages. if( @Test_Results ) { # The plan? We have no plan. if( $No_Plan ) { $self->_print("1..$Curr_Test\n") unless $self->no_header; $Expected_Tests = $Curr_Test; } # 5.8.0 threads bug. Shared arrays will not be auto-extended # by a slice. Worse, we have to fill in every entry else # we'll get an "Invalid value for shared scalar" error for my $idx ($#Test_Results..$Expected_Tests-1) { my %empty_result = (); share(%empty_result); $Test_Results[$idx] = \%empty_result unless defined $Test_Results[$idx]; } my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; $num_failed += abs($Expected_Tests - @Test_Results); if( $Curr_Test < $Expected_Tests ) { $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but only ran $Curr_Test. FAIL } elsif( $Curr_Test > $Expected_Tests ) { my $num_extra = $Curr_Test - $Expected_Tests; $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but ran $num_extra extra. FAIL } elsif ( $num_failed ) { $self->diag(<<"FAIL"); Looks like you failed $num_failed tests of $Expected_Tests. FAIL } if( $Test_Died ) { $self->diag(<<"FAIL"); Looks like your test died just after $Curr_Test. FAIL _my_exit( 255 ) && return; } _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } elsif ( $Skip_All ) { _my_exit( 0 ) && return; } elsif ( $Test_Died ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL } else { $self->diag("No tests run!\n"); _my_exit( 255 ) && return; } } END { $Test->_ending if defined $Test and !$Test->no_ending; } =head1 THREADS In perl 5.8.0 and later, Test::Builder is thread-safe. The test number is shared amongst all threads. This means if one thread sets the test number using current_test() they will all be effected. =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, Test::Exception and Test::Differences all use Test::Builder. =head1 SEE ALSO Test::Simple, Test::More, Test::Harness =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 COPYRIGHT Copyright 2002 by chromatic Echromatic@wgz.orgE, Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Net-HTTPServer-1.1.1/t/lib/Test/More.pm0000644000175000017500000007467610124076512020552 0ustar reatmonreatmon00000000000000package Test::More; use 5.004; use strict; use Test::Builder; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my($file, $line) = (caller(1))[1,2]; warn @_, " at $file line $line\n"; } require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); $VERSION = '0.47'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag ); my $Test = Test::Builder->new; # 5.004's Exporter doesn't have export_to_level. sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => $Num_Tests; # or use Test::More qw(no_plan); # or use Test::More skip_all => $reason; BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); # Various ways to say "ok" ok($this eq $that, $test_name); is ($this, $that, $test_name); isnt($this, $that, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($this, qr/that/, $test_name); unlike($this, qr/that/, $test_name); cmp_ok($this, '==', $that, $test_name); is_deeply($complex_structure1, $complex_structure2, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); # Utility comparison functions. eq_array(\@this, \@that); eq_hash(\%this, \%that); eq_set(\@this, \@that); # UNIMPLEMENTED!!! my @status = Test::More::status; # UNIMPLEMENTED!!! BAIL_OUT($why); =head1 DESCRIPTION B If you're just getting started writing tests, have a look at Test::Simple first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => $Num_Tests; There are rare cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare that you have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the plan() function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; goto &plan; } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($this eq $that, $test_name); This simply evaluates any expression (C<$this eq $that> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep !defined $_, @items, 'items populated' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 18 (foo.t at line 42) This is actually Test::Simple's ok() routine. =cut sub ok ($;$) { my($test, $name) = @_; $Test->ok($test, $name); } =item B =item B is ( $this, $that, $test_name ); isnt( $this, $that, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. ok() cannot know what you are testing for (beyond the name), but is() and isnt() know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test (foo.t at line 139) # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use is() and isnt() over ok() where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! $pope->isa('Catholic') eq 1 is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); This does not check if C<$pope->isa('Catholic')> is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use ok(). ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); For those grammatical pedants out there, there's an C function which is an alias of isnt(). =cut sub is ($$;$) { $Test->is_eq(@_); } sub isnt ($$;$) { $Test->isnt_eq(@_); } *isn't = \&isnt; =item B like( $this, qr/that/, $test_name ); Similar to ok(), like() matches $this against the regex C. So this: like($this, qr/that/, 'this is like that'); is similar to: ok( $this =~ /that/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $this, '/that/', 'this is like that' ); Regex options may be placed on the end (C<'/that/i'>). Its advantages over ok() are similar to that of is() and isnt(). Better diagnostics on failure. =cut sub like ($$;$) { $Test->like(@_); } =item B unlike( $this, qr/that/, $test_name ); Works exactly as like(), only it checks if $this B match the given pattern. =cut sub unlike { $Test->unlike(@_); } =item B cmp_ok( $this, $op, $that, $test_name ); Halfway between ok() and is() lies cmp_ok(). This allows you to compare two arguments using any binary perl operator. # ok( $this eq $that ); cmp_ok( $this, 'eq', $that, 'this eq that' ); # ok( $this == $that ); cmp_ok( $this, '==', $that, 'this == that' ); # ok( $this && $that ); cmp_ok( $this, '&&', $that, 'this || that' ); ...etc... Its advantage over ok() is when the test fails you'll know what $this and $that were: not ok 1 # Failed test (foo.t at line 12) # '23' # && # undef It's also useful in those cases where you are comparing numbers and is()'s use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); =cut sub cmp_ok($$$;$) { $Test->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single can_ok() call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; unless( @methods ) { my $ok = $Test->ok( 0, "$class->can(...)" ); $Test->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! eval { $proto->can($method) } || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $Test->ok( !@nok, $name ); $Test->diag(map " $class->can('$_') failed\n", @nok); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given $object->isa($class). Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; if( $@ ) { if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. Here's the error. $@ WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if( $diag ) { $ok = $Test->ok( 0, $name ); $Test->diag(" $diag\n"); } else { $ok = $Test->ok( 1, $name ); } return $ok; } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok(). In this case, you can simply use pass() (to declare the test ok) or fail (for not ok). They are synonyms for ok(1) and ok(0). Use these very, very, very sparingly. =cut sub pass (;$) { $Test->ok(1, @_); } sub fail (;$) { $Test->ok(0, @_); } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test (foo.t at line 52) # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it it won't interfere with the test. =cut sub diag { $Test->diag(@_); } =back =head2 Module tests You usually want to test if the module you're testing loads ok, rather than just vomiting if its load fails. For such purposes we have C and C. =over 4 =item B BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } =cut sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $pack = caller; local($@,$!); # eval sometimes interferes with $! eval <import(\@imports); USE my $ok = $Test->ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $Test->diag(< require_ok($module); Like use_ok(), except it requires the $module. =cut sub require_ok ($) { my($module) = shift; my $pack = caller; local($!, $@); # eval sometimes interferes with $! eval <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $Test->diag(<. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut #'# sub skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->skip($why); } local $^W = 0; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". Test::Harness will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. Test::Harness will interpret them as passing. =cut sub todo_skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->todo_skip($why); } local $^W = 0; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like fork() or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Comparison functions Not everything is a simple eq check or regex. There are times you need to see if two arrays are equivalent, for instance. For these instances, Test::More provides a handful of useful functions. B These are NOT well-tested on circular references. Nor am I quite sure what will happen with filehandles. =over 4 =item B is_deeply( $this, $that, $test_name ); Similar to is(), except that if $this and $that are hash or array references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. Barrie Slaymaker's Test::Differences module provides more in-depth functionality along these lines, and it plays well with Test::More. B Display of scalar refs is not quite 100% =cut use vars qw(@Data_Stack); my $DNE = bless [], 'Does::Not::Exist'; sub is_deeply { my($this, $that, $name) = @_; my $ok; if( !ref $this || !ref $that ) { $ok = $Test->is_eq($this, $that, $name); } else { local @Data_Stack = (); if( _deep_check($this, $that) ) { $ok = $Test->ok(1, $name); } else { $ok = $Test->ok(0, $name); $ok = $Test->diag(_format_stack(@Data_Stack)); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{$Stack[-1]{vals}}[0,1]; my @vars = (); ($vars[0] = $var) =~ s/\$FOO/ \$got/; ($vars[1] = $var) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : $val eq $DNE ? "Does not exist" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } =item B eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $ok = 0; my $eq; { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; if( $e1 eq $e2 ) { $ok = 1; } else { if( UNIVERSAL::isa($e1, 'ARRAY') and UNIVERSAL::isa($e2, 'ARRAY') ) { $ok = eq_array($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'HASH') and UNIVERSAL::isa($e2, 'HASH') ) { $ok = eq_hash($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'REF') and UNIVERSAL::isa($e2, 'REF') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( UNIVERSAL::isa($e1, 'SCALAR') and UNIVERSAL::isa($e2, 'SCALAR') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); } else { push @Data_Stack, { vals => [$e1, $e2] }; $ok = 0; } } } return $ok; } =item B eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. B By historical accident, this is not a true set comparision. While the order of elements does not matter, duplicate elements do. =cut # We must make sure that references are treated neutrally. It really # doesn't matter how we sort them, as long as both arrays are sorted # with the same algorithm. sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of Test::Builder which provides a single, unified backend for any test library to use. This means two test libraries which both use Test::Builder B. If you simply want to do a little tweaking of how the tests behave, you can access the underlying Test::Builder object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the Test::Builder object underlying Test::More for you to play with. =cut sub builder { return Test::Builder->new; } =back =head1 NOTES Test::More is B tested all the way back to perl 5.004. Test::More is thread-safe for perl 5.8.0 and up. =head1 BUGS and CAVEATS =over 4 =item Making your own ok() If you are trying to extend Test::More, don't. Use Test::Builder instead. =item The eq_* family has some caveats. =item Test::Harness upgrades no_plan and todo depend on new Test::Harness features and fixes. If you're going to distribute tests that use no_plan or todo your end-users will have to upgrade Test::Harness to the latest one on CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness will work fine. If you simply depend on Test::More, it's own dependencies will cause a Test::Harness upgrade. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's Test module. I was largely unaware of its existence when I'd first written my own ok() routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L for more ways to test complex data structures. And it plays well with Test::More. L is the old testing module. Its main benefit is that it has been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. L describes a very featureful unit testing interface. L shows the idea of embedded testing. L is another approach to embedded testing. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, chromatic and the perl-qa gang. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Net-HTTPServer-1.1.1/t/lib/Test/Simple.pm0000644000175000017500000001456510124076512021070 0ustar reatmonreatmon00000000000000package Test::Simple; use 5.004; use strict 'vars'; use vars qw($VERSION); $VERSION = '0.47'; use Test::Builder; my $Test = Test::Builder->new; sub import { my $self = shift; my $caller = caller; *{$caller.'::ok'} = \&ok; $Test->exported_to($caller); $Test->plan(@_); } =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first! ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); ok() is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { $Test->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets Test::Harness know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test (t/film.t at line 14) ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.004. Test::Simple is thread-safe in perl 5.8.0 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More (i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L The original Perl testing module. =item L Elaborate unit testing. =item L, L Embed tests in your code! =item L Interprets the output of your test program. =back =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Net-HTTPServer-1.1.1/t/2_new.t0000644000175000017500000000031710124076512017001 0ustar reatmonreatmon00000000000000use lib "t/lib"; use Test::More tests=>3; BEGIN{ use_ok( "Net::HTTPServer" ); } my $server = new Net::HTTPServer(log=>"t/access.log"); ok( defined($server), "new()"); isa_ok( $server, "Net::HTTPServer"); Net-HTTPServer-1.1.1/t/1_load.t0000644000175000017500000000012210124076512017120 0ustar reatmonreatmon00000000000000use lib "t/lib"; use Test::More tests=>1; BEGIN{ use_ok( "Net::HTTPServer" ); } Net-HTTPServer-1.1.1/t/session.t0000644000175000017500000000457410124076512017463 0ustar reatmonreatmon00000000000000use lib "t/lib"; use Test::More tests=>33; BEGIN{ use_ok( "Net::HTTPServer" ); use_ok( "Net::HTTPServer::Session" ); } my $server = new Net::HTTPServer(datadir=>"./t/sessions", sessions=>1, log=>"t/access.log", ); ok( defined($server), "new()"); isa_ok( $server, "Net::HTTPServer"); my $session = new Net::HTTPServer::Session(server=>$server); ok( defined($session), "new()"); isa_ok( $session, "Net::HTTPServer::Session"); ok( !$session->Exists("test1"), "!Exists(test1)"); $session->Set("test1","test1"); ok( $session->Exists("test1"), "Exists(test1)"); is( $session->Get("test1"), "test1", "Get(test1)==test1"); isnt( $session->Get("test1"), "test2", "Get(test1)!=test2"); ok( !$session->Exists("test2"), "!Exists(test2)"); $session->Set("test2",["a","b","c"]); ok( $session->Exists("test2"), "Exists(test2)"); is_deeply( $session->Get("test2"), ["a","b","c"], "Get(test2)==[a,b,c]"); isnt( $session->Get("test2"), "test1", "Get(test2)!=test1"); ok( !$session->Exists("test3"), "!Exists(test3)"); $session->Set("test3","test3"); ok( $session->Exists("test3"), "Exists(test3)"); is( $session->Get("test3"), "test3", "Get(test3)==test3"); $session->Delete("test3"); ok( !$session->Exists("test3"), "!Exists(test3)"); $session->_save(); ok( -f "./t/sessions/".$session->_key(), "Session file exists"); my $session2 = new Net::HTTPServer::Session(key=>$session->_key(), server=>$server); ok( defined($session2), "new()"); isa_ok( $session2, "Net::HTTPServer::Session"); ok( $session2->Exists("test1"), "Exists(test1)"); is( $session2->Get("test1"), "test1", "Get(test1)==test1"); isnt( $session2->Get("test1"), "test2", "Get(test1)!=test2"); ok( $session2->Exists("test2"), "Exists(test2)"); is_deeply( $session2->Get("test2"), ["a","b","c"], "Get(test2)==[a,b,c]"); isnt( $session2->Get("test2"), "test1", "Get(test2)!=test1"); ok( !$session->Exists("test3"), "!Exists(test3)"); ok( -f "./t/sessions/".$session->_key(), "Session file exists"); unlink("./t/sessions/".$session->_key()); ok( !(-f "./t/sessions/".$session->_key()), "Session file doesn't exist"); ok( $session2->_valid(), "Is valid?"); $session2->Destroy(); ok( !$session2->_valid(), "Is not valid?"); $session2->_save(); ok( !(-f "./t/sessions/".$session->_key()), "Session file doesn't exist"); Net-HTTPServer-1.1.1/t/response.t0000644000175000017500000000526110124076512017630 0ustar reatmonreatmon00000000000000use lib "t/lib"; use Test::More tests=>26; BEGIN{ use_ok( "Net::HTTPServer::Response" ); } my $response = new Net::HTTPServer::Response(); ok( defined($response), "new()"); isa_ok( $response, "Net::HTTPServer::Response"); my @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 200\r\n\r\n",""] , "_build: Blank" ); $response->Header("Test","test"); ok( $response->Header("Test"), "Header Test exists"); is( $response->Header("Test"), "test", "Header Test == test"); @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 200\nTest: test\r\n\r\n",""] , "_build: Header" ); $response->Cookie("Test","test"); @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 200\nTest: test\nSet-Cookie: Test=test\r\n\r\n",""] , "_build: Cookie" ); $response->Cookie("Test","test",expires=>"expires",domain=>"domain",path=>"path",secure=>1); @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 200\nTest: test\nSet-Cookie: Test=test;domain=domain;expires=expires;path=path;secure\r\n\r\n",""] , "_build: Full cookie" ); is( $response->Code(), 200, "Code == 200"); $response->Code(400); isnt( $response->Code(), 200, "Code != 200"); is( $response->Code(), 400, "Code == 400"); @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 400\nTest: test\nSet-Cookie: Test=test;domain=domain;expires=expires;path=path;secure\r\n\r\n",""] , "_build: New code" ); is( $response->Body(), "", "Body == " ); $response->Body("Test body"); is( $response->Body(), "Test body", "Body == Test body" ); @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 400\nTest: test\nSet-Cookie: Test=test;domain=domain;expires=expires;path=path;secure\r\n\r\n","Test body"] , "_build: Body" ); is( $response->Body(), "Test body", "Body == Test body" ); $response->Clear(); is( $response->Body(), "", "Body == " ); @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 400\nTest: test\nSet-Cookie: Test=test;domain=domain;expires=expires;path=path;secure\r\n\r\n",""] , "_build: Clear" ); is( $response->Body(), "", "Body == " ); $response->Print("Test"); is( $response->Body(), "Test", "Body == Test" ); $response->Print(" body"); is( $response->Body(), "Test body", "Body == Test body" ); @build = $response->_build(); is_deeply( \@build, ["HTTP/1.1 400\nTest: test\nSet-Cookie: Test=test;domain=domain;expires=expires;path=path;secure\r\n\r\n","Test body"] , "_build: Print" ); my $response2 = new Net::HTTPServer::Response(); ok( defined($response2), "new()"); isa_ok( $response2, "Net::HTTPServer::Response"); $response2->Redirect("http://www.server.com/path"); @build = $response2->_build(); is_deeply( \@build, ["HTTP/1.1 307\nLocation: http://www.server.com/path\r\n\r\n",""] , "_build: Redirect" ); Net-HTTPServer-1.1.1/MANIFEST0000644000175000017500000000112110176251307016466 0ustar reatmonreatmon00000000000000CHANGES README LICENSE.LGPL MANIFEST MANIFEST.SKIP Makefile.PL examples/simple_test.pl lib/Net/HTTPServer.pm lib/Net/HTTPServer/CaptureSTDOUT.pm lib/Net/HTTPServer/Request.pm lib/Net/HTTPServer/Response.pm lib/Net/HTTPServer/Session.pm lib/Net/HTTPServer/mime.types t/1_load.t t/2_new.t t/lib/Test/Builder.pm t/lib/Test/More.pm t/lib/Test/Simple.pm t/req_sessions/ea209023f1f3908dd9a39c256be04e55 t/request.t t/requests/req1 t/requests/req2 t/requests/req3 t/requests/req4 t/requests/req5 t/response.t t/session.t META.yml Module meta-data (added by MakeMaker) Net-HTTPServer-1.1.1/MANIFEST.SKIP0000644000175000017500000000004410124076512017232 0ustar reatmonreatmon00000000000000Makefile$ TODO blib tests .swp$ CVS Net-HTTPServer-1.1.1/CHANGES0000644000175000017500000001064510176251352016343 0ustar reatmonreatmon000000000000001.1.1 ===== - Forgot a file in the MANIFEST. 1.1 === - Added most of the CGI environment variables into the Env hash. - docroot now defaults to undef which turns off file serving. - Added support for CGI via CaptureSTDOUT() and ProcessSTDOUT(). - Fixed bugs with / on directories. - Added support for RegisterRegex. - Fixed bug with _date and missing Sep(tember) entry in the date. - Fixed bug with some error conditions. - Added support for OPTIONS. 1.0.2 ===== - If you register a callback /some/path/index.foo, AND you set the index list to include index.foo then /some/path/ will resolve to the callback. Thanks to John Jones for this request. 1.0.1 ===== - Fixed Response to normalize the output so that the tests can come out the same for each run. Basically, cookies were printing out in a different order then what was hard coded in the test. 1.0 === - Added PHP style session support. - Moved to more object oriented model: object for request, object for reply. - Added cookie support. 0.9.4 ===== - Fixed more of the required HTTP/1.1 headers. Thanks again to Jamie Lockier. 0.9.3 ===== - Fixed bug in Windows support and nonblocking. Turns out that ActivePerl doesn't like the Blocking=>0 call in IO::Socket::INET creation, and my call to ioctl was wrong. This should fix everyone who was having problems. 0.9.2 ===== - Fixed bug with interaction with Internet Explorer. I was parsing the headers incorrectly. 0.9.1 ===== - Fixed directory listing code when the file name contains :. This confused Mozilla (and likely other browsers) thinking that everything before the : was a protocol name (http:..). Now we append the path of the request on those files. 0.9 === - Added support for Digest Authentication. - Added more of the required HTTP/1.1 headers. Added support for HEAD, and TRACE. Thanks to Jamie Lockier for pointing out those deficiencies. - Added support for Basic Authentication. Thanks to Alan Barclay for this feature. - Added the ability to present other tokens on the Server: line using the AddServerTokens function. Thanks to Darren Chamberlain for this feature. 0.8.1 ===== - Big bug. If you write too fast then sometimes syswrite returns undef even though it was not *really* an error. Use select to wait on this. Hopefully this won't create more problems. 0.8 === - Fixed but in writing. If there was an error on write the server was sent spinning into an endless loop. - Fixed bug in win32 nonblocking. Thanks to Bytewolf and dliouville for finding this. 0.7 === - Fixed IO::Socket::SSL interface problem. Accessing multiple pages would result in SSL errors about not having a context. The lesson for the day is: Forking does weird things. In this case it *appears* that the SSL part of the socket was being closed when we sent the web page. Much reading shows us the SSL_no_shutdown option to close does not shutdown the SSL. This seems to fix the problem. - Reworked forking inner loop. There were some performance issues. 0.6.5 ===== - Removed a rogue debug statement. 0.6 === - Added code to detect a failed Start() and throw errors if Process() was called. - Fixed problem where a failed Start() would cause Stop() to crater since the socket and selects might be undefined. 0.5 === - Fixed bug with SSL support. I had hard coded paths and a bad check for the SSL options. 0.4 === - Allow for the reponse to be a FileHandle that _send will read and send in one go. This should make serving files faster (at least big files). - Fixed typo and mistake in logic with IO::Socket::SSL check. 0.3 === - Fixed logic to check for IO::Socket::SSL (didn't work very well with Perl2Exe). - Added tests for make test. 0.2 === - Fixed bug in read code where it would not finish reading a request. - If IO::Socket::SSL is installed, you can run a secure server. - Added a preforking server type "forking" (default is "single"). You can confiugre the number of child processes via the numproc config option. 0.1 === - Auto-find the mime.types in the module directories. - Port scanning for embeded on the fly servers. - Redirects directories without / to same dir with /: foo/bar -> foo/bar/ - Lists directories - Serves files - Allow for registering of functions to URLs so that it gets called when the URL is requested. Net-HTTPServer-1.1.1/META.yml0000644000175000017500000000054110176251425016614 0ustar reatmonreatmon00000000000000# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Net-HTTPServer version: 1.1.1 version_from: lib/Net/HTTPServer.pm installdirs: site requires: URI: 1.27 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Net-HTTPServer-1.1.1/LICENSE.LGPL0000644000175000017500000006143710124076512017113 0ustar reatmonreatmon00000000000000 GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! Net-HTTPServer-1.1.1/examples/0002755000175000017500000000000010176251426017164 5ustar reatmonreatmon00000000000000Net-HTTPServer-1.1.1/examples/simple_test.pl0000644000175000017500000000307110124076512022042 0ustar reatmonreatmon00000000000000#!/usr/bin/perl -w use strict; use Net::HTTPServer; my $server = new Net::HTTPServer(); $server->RegisterURL("/test/env",\&test_env); $server->RegisterURL("/test/auth",\&test_auth); $server->RegisterAuth("basic","/test/auth","Test Auth",\&auth); if ( $server->Start() ) { $server->Process(); } else { print "Could not start the server.\n"; } sub test_env { my $req = shift; # Net::HTTPServer::Request object my $res = $req->Response(); # Net::HTTPServer::Response object $res->Print("\n"); $res->Print(" \n"); $res->Print(" This is a test\n"); $res->Print(" \n"); $res->Print(" \n"); $res->Print(" 
\n");
    
    foreach my $var (keys(%{$req->Env()}))
    {
        $res->Print("$var -> ".$req->Env($var)."\n");
    }
    
    $res->Print("
\n"); $res->Print(" \n"); $res->Print("\n"); return $res; } sub auth { my $url = shift; my $user = shift; if ($user eq "test") { return ("200","pass"); } return ("401"); } sub test_auth { my $req = shift; # Net::HTTPServer::Request object my $res = $req->Response(); # Net::HTTPServer::Response object $res->Print("\n"); $res->Print(" \n"); $res->Print(" This is a test\n"); $res->Print(" \n"); $res->Print(" \n"); $res->Print(" This page required authentication.\n"); $res->Print(" \n"); $res->Print("\n"); return $res; } Net-HTTPServer-1.1.1/Makefile.PL0000644000175000017500000000052410124076512017311 0ustar reatmonreatmon00000000000000use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Net::HTTPServer', 'PREREQ_PM' => { 'URI' => 1.27 }, 'VERSION_FROM' => 'lib/Net/HTTPServer.pm', 'dist' => { 'COMPRESS' => 'gzip --best' } ); Net-HTTPServer-1.1.1/README0000644000175000017500000000257210124076512016224 0ustar reatmonreatmon00000000000000Net::HTTPServer This is a light weight HTTP server that serves files as well as attaching function calls to URL requests. This allows you to do a lot of things: - embed the web server into your program and serve up anything your program can do - make a file available for download that you created - just take you CGI program and turn it into a stand alone HTTP server that you can run on any machine. - lots lots more Ryan Eatmon reatmon@mail.com REQUIREMENTS - URI - Handles all of the URL magic OPTIONAL - IO::Socket::SSL - Allows for a secure web server - MIME::Base64 - Allows for Basic Authentication - Digest::MD5 - Allows for Digest Autentication INSTALLATION perl Makefile.PL make make install STATUS This update contains a new OOP style interface for requests and replies. I also added support for PHP style server side sessions. The result of moving to the OOP interface is that the calling and return structure for handlers has changed. For those that want to upgrade to this version of the module but do not want to have to rewrite your handlers immediately there is a config option for the server. 'oldrequests'=>1 will put the entire server back into the pre-1.0 style of handlers. Giving you a chance to install the module and play with it before undertaking the conversion. Aplogies for the change. DATE 2004/07/03