#!/usr/bin/perl ################################################################################ # # # fsweblog 0.9.9.2 http://swoolley.org/blog.cgi?get=src # # # # Copyright (c) 2003/4/5/6/7/8 Seth Alan Woolley, under the GNU GPL >= v.3 # # See http://www.fsf.org/licenses/gpl.txt for a copy of the license. # # # ################################################################################ # configuration variables $hometitle = "Seth Woolley's Blog"; # required per RSS spec. $homedescr = "Occasional Musings"; # required per RSS spec. $homeicbm = "45.5438, -122.6295"; # ICBM address, geourl.org $homeTZ = "-08:00"; # for RSS timezone spec. (-08:00 is PST) $homelang = "en-US"; # for RSS language spec. $homecss = "$ENV{SCRIPT_NAME}?get=css"; # change to use non-builtin CSS $homecss = "/man.cgi/c=1"; # non-builtin CSS $turing = "fsweblog"; # turing test for commenters if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) { $contenttype= "text/html"; # xhtml 1.1 isn't "truly" supported in MSIE } else { $contenttype= "application/xhtml+xml";# xhtml 1.1 validation requires this } # or edit the CSS below. $relpath = "blog/"; # relative path to paths below (from here) $datadir = $relpath . "blogs"; # relative to the script for blogs. $commentdir = $relpath . "comments"; # relative to the script for comments. $categorydir= $relpath . "categories";# relative to the script for categories. $noquery = 1; # 1 if PATH_INFO, undef for QUERY_STRING $line = 70; # when to wrap text $dotplan = $relpath . "plan/plan";# point ~/.plan to here via symlink # (or undef to disable) $webroot = "/var/www/"; # needed for dotplan support $refsfile = "referindex.tab"; # referrers file, relative to docroot $blogstart = 1; # start number of blogs to display $rdfstart = 1; # start number of blogs to display w/RDF $blogmax = 10; # maximum number of blogs to display $rdfmax = 10; # maximum number of blogs to display w/RDF # latest blog image: ?get=jpeg or ?get=png @bg = (000,000,000); # background color of image, RGB, 0-255 @fg = (255,255,255); # foreground color of image, RGB, 0-255 $tp = undef; # transparent bg of image? make 1 or undef # installation instructions # # Copy this file into a directory on your server with all execute permissions. # Make sure to rename it "index.cgi" without ?get=src at the end (no quotes). # Execute permissions are a+x, 755, or all with execute, and can be setup in # your ftp program or by using the chmod unix utility: chmod 755 index.cgi # # Make a directory in the same directory as this file called $datadir # ("blogs", by default). Set its permissions to 755 as well (the same as # the script). This is where you upload or write your blogs directly to. # The blogs are simply text files with the name set to the subject you want. # Use the unix commands: mkdir blogs; chmod 755 blogs # # Make another directory in the same directory as this file called $commentdir # ("comments", by default). Set its permissions to 775, a+xg+w, or all # with execute and group with write in addition to its normal permissions. # Change its group to the webserver group, typically apache, nogroup, or httpd. # Use the commands: mkdir comments; chmod 775 comments; chgrp nogroup comments # # If you want to not enable comments, set the comments permissions to 755 # instead of 775. Then to enable comments on a blog-by-blog basis, create # a directory the same name as the blog you created with 775 permissions, # with a group of nogroup (or whatever your web server group is). # Commands: mkdir comments; chmod 755 comments; chgrp nogroup comments; # mkdir comments/blogtitle; chmod 775 comments/*; chgrp nogroup comments/* # Repeat the second line of commands above when you create a new # commentable blog. # # Security note: Anybody with permissions to the webserver group can then # edit the comments on your site. To avoid this problem, have your # administrator setup setgid permissions on the webserver to have your # htdocs directory set to your group and then use your group instead of # nogroup, or run in a virtual private server. To be safest, don't enable # comments. # # If you are unable to find out your webserver group and/or change your # directories' group to nogroup, then you can do what the GreyMatter # install says, and do: chmod 777 comments # # That of course means you don't have to do any of the chgrp commands # either, but you will have to have made the appropriate directories. # # If you want category support, then create a categorydir: # mkdir categorydir; chmod 755 categorydir # # Inside that directory, create directories for each category you want. # inside each category directory, create a hard link to (not a symbolic # link) with the same name of each blog entry you want in that category. # # Then, change the first line that says #!/bin/perl to #!/usr/bin/perl # or #!/usr/local/bin/perl depending on your perl installation location. # # Lastly, edit the templates in the source code as you please, but remember # that $ and @ are variable interpolating characters, so, so put \$ or \@ # if you want to use the characters literally. The unescaped $ and @ # references are subroutines and variables that can be used at any point # within the template. Remember that the backquote character ` should be # escaped if you want to use it literally as well because it's the template # quoting character. It's used inside templates for example to do the dirty # trick of repeating "for" loops. In the Content-type area at the top of each # template, you can send your own headers, but be sure that carriage returns # in the header and in the separating newline are "\r\n" instead of just the # standard newline "\n", or the webserver will not know what you're doing. # # Optional latest blog image support simply requires GD installed on the # server. For a phpBB latest blog image in your signature: # [url=http://example.com/][img]http://example.com/index.cgi?get=png[/img][/url] # # To check for if GD is installed: perl -e 'use GD' # To install GD if you don't have it: perl -MCPAN -e 'install GD' # # To use the .plan support, define your $webroot and $dotplan and make a # directory called $datadir/plan with webserver group permissions -- the script # will make a file called $datadir/plan/plan that is a symlink to the latest # blog file. Then symlink ~/.plan to the $datadir/plan/plan file so finger can # read it: mkdir plan; chgrp nogroup plan; chmod 775 plan # ################################################################################ #print "Content-type: text/plain\r\n\r\n$ENV{SCRIPT_NAME} $ENV{HTTP_HOST} $0 $ENV{PATH_INFO}"; ($basename, $filename) = ($ENV{SCRIPT_NAME} =~ /^(.*\/)(.*)$/); $homeurl = "http://$ENV{HTTP_HOST}$basename"; if ($filename eq "") { $filename = $0 } my $PI = $ENV{PATH_INFO}; $PI =~ s!^/!!; if ($PI ne '') { if ($PI !~ m!/!) { $ENV{QUERY_STRING} = ';get=post;post=' . $PI . ';' . $ENV{QUERY_STRING}; } else { # prevent response-splitting by filtering out newline stuff my ($entry, $cmd5) = ($PI =~ m!([^/\r\n\l\f]*)/?([^\r\n\l\f]*)!); if ($cmd5 ne '') { print "Location: $homeurl$filename/$entry#id$cmd5\r\n\r\n"; } else { print "Location: $homeurl$filename/$entry\r\n\r\n"; } exit 1; } } my ($QS, %args, $argsarray, %filetype, %filedata); &parsequerystring(); my (%entry, %entries, %comments, $commentglobal, %commentsenable); &grabdata(); # use Data::Dumper; # print STDERR Data::Dumper->Dump( # [ \%entries ], # [ 'entries'] # ); if (defined($dotplan)) { my @entries = reverse sort keys %entries; my $text = $entries{$entries[0]}{entry}; my $link = readlink "$dotplan"; my $target = "$webroot$datadir/$text"; #print STDERR qq{symlink $target, $dotplan}; if ($target ne $link) { unlink $dotplan or warn "$!"; #print STDERR qq{symlink $target, $dotplan}; symlink $target, $dotplan or warn "$!"; } } if ($args{"post"} ne '' and $entry{$args{"post"}} eq undef) { ################################################## 404 TEMPLATE BEGIN print qq`Status: 404 Entry Not Found\r @{[&htmlheader("@{[&plaintext($hometitle)]} - @{[&plaintext($homedescr)]}")]}
The requested entry @{[&plaintext($QS)]} could not be found.
This blog is empty.
':'']}`; for my $entry (grep { $args{category} eq "" or $entries{$_}{categories}{$args{category}} == 1} (reverse sort keys %entries)[$lbb .. $lbe]) { print qq`If you would like to comment, make a blog entry that links to me, and in due time it will show up in the references section (if you aren't a spammer or use things like google ads). No, I do not support the broken spam-harboring protocols known as trackback and pingback, and I never will. There's already a standard: HTTP/1.1, RFC2616 of the IETF.
@{[scalar localtime($entries{$entry}{mti})]} --@{[($link)?(($commentsenable{$entry})?qq| Post (Comments: @{[scalar keys %{$comments{$entry}}]}) --|:qq| Post (No Comments Allowed) --|):'']} @{[&plaintext($entries{$entry}{entry})]}
@{[scalar localtime($comments{$entry}{$comment}{mti})]} -- Comment @{[&plaintext($comments{$entry}{$comment}{csub})]} -- by @{[&plaintext($comments{$entry}{$comment}{caut})]}
@{[&plaintext($comments{$entry}{$comment}{ctxt},8)]}
' . &filteroutcode($1) . "<\/pre>\n\n"/gse; return $_; } sub unplaintext() { local $_ = shift; return $_; } sub prettify() { local $_ = "
" . shift() . "
"; # subheaders s/(?:|)[\n\t\r\l ]*==== ([^\n=]+) ====[\n\t\r\l ]*(?:<\/p>|)/
$1<\/h6>/gs; s/(?:
|)[\n\t\r\l ]*=== ([^\n=]+) ===[\n\t\r\l ]*(?:<\/p>|)/
$1<\/h5>/gs; s/(?:
|)[\n\t\r\l ]*== ([^\n=]+) ==[\n\t\r\l ]*(?:<\/p>|)/
$1<\/h4>/gs; s/(?:
|)[\n\t\r\l ]*= ([^\n=]+) =[\n\t\r\l ]*(?:<\/p>|)/
$1<\/h3>/gs; # linkify links s/([^"a-z])([a-z]+\:\/\/[A-Z0-9a-z.-:]+\/?[^\t\n\l\r<" ]*)/$1$2<\/a>/gs; # nested unordered lists s/^(\ \;| )+\* (.*)/
$1\n
- $2<\/li>\n<\/ul>$1/gm; s/<\/li>\n<\/ul>(\ \;| )\n
\n\1\n//gs; s/<\/li>\n<\/ul>\ \;\n
\n/\n
/gs; s/
<\/li>\n<\/ul> \n
\n\ \;/<\/li>\n<\/ul><\/li>/gs; s/
- /<\/li>\n
- /g; s/(
)(\ \;| )/<\/p>\n$1/g; s/(<\/ul>)(\ \;| )/$1\n
/g; s/
<\/li>\n<\/ul>/<\/li>\n<\/ul>\n/g; # dictionary lists s/^(\ \;| )+\= (.*)/$1\n
- $2<\/dt>\n<\/dl>$1/gm; s/<\/dt>\n<\/dl>(\ \;| )\n
\n\1\n//gs; s/<\/dt>\n<\/dl>\ \;\n
\n/\n
/gs; s/
<\/dt>\n<\/dl> \n
\n\ \;/<\/dd>/gs; s/
\n\n
- /<\/dt>\n
- /g; s/(
)(\ \;| )/ <\/p>\n$1/g; s/(<\/dl>)(\ \;| )/$1\n
/g; s/(?:
|)<\/dt>\n<\/dl>/<\/dd>\n<\/dl>/g; s/- /<\/dd>\n
- /g; # clear out extra breaks s/
\n
\n /\n <\/p>\n\n /gs; s/
\n(?: \n){0,1}/\n/gs; s/([\n\t\r\l ]*)(.*?<\/h[2-6]>)([\n\t\r\l ]*)(<\/p>)/$3$4$1$2/gs; s/
\n
\n /\n <\/p>\n\n /gs; s/
\n(?: \n){0,1}/\n/gs; s/^[\n\t\r\l ]*<\/p>//s; # support blockquoting s/\n((?: [^\n]*\n)+) <\/p>/"
\n" . &blockquote($1) . " <\/p><\/blockquote>"/gse; return &wraplong($_) } sub blockquote() { local $_ = shift; s/^ / /gm; return $_; } sub wraplong() { local $_ = shift; s/([^<>\t\n\l\r\007 ]{@{[$line-1]}})/$1\\
\n /gs; s/(]+)\\
\n (.*?>)/$1 . $2/gse; s/(]+>) (.*?) (<\/a>)/$1$2$3/gs; s/\007//g; # untag the code return $_; } sub filterouturl() { local $_ = shift; s/\\
\n //gs; return $_; } sub filteroutcode() { local $_ = shift; #print "Content-type: text/plain\r\n\r\n--\n$_\n--\n"; s/\\
\n //gs; s/
\n /\n/gs; s/./$&\007/g; # tag code with \007 chars to prevent further processing in prettify. return $_; } sub plaintext() { local $_ = shift; my $mval = shift; my $mstr = ' ' x $mval; s/\t/ /g; s/ +$//mg; s/&/&/g; s/"/"/g; # s/'/'/g; s/</g; s/>/>/g; s/ / /g; s/ / /g; if ($mval) { s/\n/
\n/g; s/\n/\n$mstr /gs; return "\n$mstr $_\n$mstr"; } else { s/\n/ /gs; return $_; } } sub cuttext() { local $_ = shift; my $l = shift; s/ / /g; s/[ \t\n\l\r\f]+/ /gs; if(length($_)<$l) { return $_; } else { $_ = substr($_,0,$l+1); s/ ?[^ ]*$/.../g; return $_; } } sub cuturl() { local $_ = shift; my $l = shift; s/ / /g; s/[ \t\n\l\r\f]+/ /gs; if(length($_)<$l) { return $_; } else { $_ = substr($_,0,$l+1); s/[\/?]?[^\/?]*$/.../; return $_; } } sub dctime() { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(shift()); return sprintf("%04d",(1900+$year)) . "-" . sprintf("%02d",($mon+1)) . "-" . sprintf("%02d",$mday) . "T" . sprintf("%02d",$hour) . ":" . sprintf("%02d",$min) . ":" . sprintf("%02d",$sec) . "$homeTZ"; } sub securityclean { local $_ = shift; s/ +- +/-/g; # ' - ' is used to delimit author and subject s/[\/\\\<\>\&\n\r\l\0]/\?/g; s/^[\.]/\?/; # only at beginning of line # s/^[\;]/\?/g; not needed # s/[\/\\\;\<\>\&\.\n\r\l\0]/\?/g; clears them all # / used to delimit directories, \ used to escape characters # ; used to end shell expansions and end entity references, # < and > used in html, & used for entity references, # . used to make hidden files, make extensions for scripts, # do backtracking, or to reference the current directory, # \n, \r, and \l used to end lines, \0 is null return $_; } sub commentpost { if($args{"body"} ne "" and $args{"turing"} eq $turing and $ENV{"REQUEST_METHOD"} eq "POST") { my $post = &securityclean($args{"post"}); my $subject = &securityclean($args{"subject"}); my $name = &securityclean($args{"name"}); my $secret = &securityclean($args{"secret"}); if ($subject eq "") { $subject = "no subject"; } if ($name eq "") { $name = "anonymous"; } if ($secret eq "") { $secret = rand(localtime())*(2**48) ; } if ($post eq "") { $post = "no text"; } eval "use Digest::MD5 qw(md5 md5_hex md5_base64)"; my $file = md5_hex("$homeurl$post$name$subject$secret") . " - $name - $subject"; mkdir "$commentdir/$post/"; open(COMMENTPOST, ">", "$commentdir/$post/$file"); print COMMENTPOST $args{body}; close(COMMENTPOST); print "Location: $homeurl$filename\r\n\r\n"; exit; } } sub uriescape { local $_ = shift; s/([^0-9A-Za-z\:\/])/&es($1)/gse; return $_; sub es { my $b = ord(shift()); # return '+' if $b == 32; # apache can't do + inside urls, only in query_strings my $a = int($b/16); $b = $b - $a * 16; return '%' . &hx($a) . &hx($b); } sub hx { my $a = shift; $a = $a>9 ? chr($a+55) : $a; return $a; } } sub idescape { local $_ = shift; s/([^0-9A-Za-z])/&ides($1)/gse; return $_; sub ides { my $b = ord(shift()); my $a = int($b/16); $b = $b - $a * 16; return '_' . &idhx($a) . &idhx($b); } sub idhx { my $a = shift; $a = $a>9 ? chr($a+55) : $a; return $a; } } sub linkup { my $blog = shift; my $comment = shift; if ($noquery) { if ($comment eq '') { return "/$blog"; } else { return "/$blog/$comment"; } } else { return "?get=post;post=$blog#id$comment"; } } sub search { my $search = shift; if ($search eq '') { return ''; } $search = substr($search,0,$line); my ($results, $resultstotal, $resultscount); $results = ''; $resultstotal = 0; $resultscount = 0; for my $entry (sort keys %entries) { $string = qq{Regarding $entries{$entry}{esub} - Status Changed @{[scalar localtime($entries{$entry}{cti})]} - Last Modified @{[scalar localtime($entries{$entry}{mti})]} - Category @{[join(" - Category ", keys %{$entries{$entry}{categories}}) ]} - $entries{$entry}{etxt}}; ($resultscountpart, $resultstotalpart, $resultspart) = (@{&resultfind($search, $string, $line, $entry, 1)}); $resultscount += $resultscountpart; $resultstotal += $resultstotalpart; $results .= $resultspart; } my $resultstore = &resultsprint ($search, $results, $resultscount, $resultstotal, 'entry', 'entries'); $results = ''; $resultstotal = 0; $resultscount = 0; for my $entry (sort keys %comments) { for my $comment (sort keys %{$comments{$entry}}) { $string = "$comments{$entry}{$comment}{cmd5} - By $comments{$entry}{$comment}{caut} - In reply to $comments{$entry}{$comment}{entry} - Regarding $comments{$entry}{$comment}{csub} - Status Changed @{[scalar localtime($comments{$entry}{$comment}{cti})]} - Last Modified @{[scalar localtime($comments{$entry}{$comment}{mti})]} - $comments{$entry}{$comment}{ctxt}"; ($resultscountpart, $resultstotalpart, $resultspart) = (@{&resultfind($search, $string, $line, $entry, $comment)}); $resultscount += $resultscountpart; $resultstotal += $resultstotalpart; $results .= $resultspart; } } return "$resultstore " . &resultsprint ($search, $results, $resultscount, $resultstotal, 'comment', 'comments'); } sub resultfind { my $search = shift; my $string = shift; my $line = shift; my $entry = shift; my $arg = shift; $string =~ s/[\n\r\t\l ]+/ /gs; my $padding = int($line / 2); $string = (" " x $padding) . $string . (" " x $padding); my $resultset = ''; my $resultscount = ''; my $resultstotal = ''; $string =~ s/(.{$padding})($search)/($returnstuff, $resultset, $resultscount) = (@{&resultparse($1,$2,$',$resultset,$resultscount,$line)}), $returnstuff/gise; if ($resultset ne '') { $resultset =~ s/&/&/g; $resultset =~ s/</g; $resultset =~ s/($search)/$1<\/strong>/gis; $resultset =~ s/ / /g; $resultset =~ s/\n/
\n /g; my $resulthead; if ($arg eq '1') { $resulthead = &entryheader($entry, $arg) } else { $resulthead = &commentheader($entry, $arg) } $resultset = qq`$resulthead`; $resultstotal++; } return [$resultscount, $resultstotal, $resultset]; } sub resultsprint { my $search = shift; my $results = shift; my $resultscount = shift; my $resultstotal = shift; my $type = shift; my $types = shift; #print STDERR "$search, $string, $line, $entry, 1\n$resultscount += $resultscountpart; $resultstotal += $resultstotalpart; $results .= $resultspart;\n"; if ($results ne '') { return qq`$resultset
$results"; } else { return qq`$resultscount ` . ($resultscount==1?'match':'matches') . " found in $resultstotal " . ($resultstotal==1?$type:$types) . " for search term @{[&plaintext($search)]}:
"; } } sub resultparse { $ls = shift; $re = shift; $rs = shift; local $resultset = shift(); local $resultscount = shift(); $line = shift; $re = substr($re,0,$line); $lp = int(($line - length($re)) / 2 + .5); $rp = int(($line - length($re)) / 2 - .5); $ls = substr($ls,length($ls)-$lp,$lp); $rs = substr($rs,0,$rp); $resultset .= "$ls$re$rs\n"; $resultscount++; return ["$ls$re", $resultset, $resultscount]; } sub grabrefs { my $search = shift; my @refsdata = @{shift()}; my $searchregex = $search; ($prefix) = ($searchregex =~ /^(.*)\Q$filename\E/); $searchregex =~ s/^.*?\Q$filename\E//; $searchregex = "$prefix$filename" . &uriescape($searchregex); #print "Content-type: text/plain\r\n\r\n$searchregex\n\n"; my @refsgood = grep {m!^\Q$searchregex\E!} @refsdata; my %hash = (); my $returnstring = ''; my ($uri, $ref, $tit); for (@refsgood) { ($uri, $ref, $tit) = (/^([^\t]*)\t([^\t]*)\t([^\t]*)\n$/); $hash{$uri}{$ref}++; $hashtit{$ref} = $tit; } for $uri (sort keys %hash) { $returnstring .= qq`No match found in any $type` . " for search term @{[&plaintext($search)]}.
- @{[&plaintext($uri)]}
\n`; my %refhash = (); for $ref (keys %{$hash{$uri}}) { $refhash{$hash{$uri}{$ref}} .= qq`- \n`; } for $ref (reverse sort keys %refhash) { $returnstring .= $refhash{$ref}; } } return "
- $hash{$uri}{$ref}:@{[&plaintext(&cuturl($ref,60))]}
- @{[&plaintext($hashtit{$ref})]}
\n$returnstring
"; } sub grabdata { opendir(BLOGDIR, "$datadir"); @entries = grep { !(/^\./) && -r "$datadir/$_" } readdir(BLOGDIR); $commentglobal = -w "$commentdir" && -x _ && -r _; for my $entry (@entries) { s/\///g; open(BLOGFILE, "<", "$datadir/$entry"); my ($dev,$ino,$mod,$nln,$uid,$gid,$rdv,$siz,$ati,$mti,$cti,$bsz,$blk) = stat(BLOGFILE); { local $/; $etxt =; $etxt =~ s/\n+$//s; } $entries{"$mti$entry"} = { 'cti' => $cti, 'entry' => $entry, 'etxt' => $etxt, 'mti' => $mti }; $entry{$entry} = "$mti$entry"; close(BLOGFILE); my $cdb = "$commentdir/$entry"; if ( $commentglobal or (-w $cdb && -x _ && -r _)) { $commentsenable{"$mti$entry"} = 1; opendir(COMMENTDIR, "$cdb"); @comments = grep { !(/^\./) && -x $cdb && -r _ } readdir(COMMENTDIR); my $index = "$mti$entry"; for my $comment (@comments) { s/\///g; open(COMMENTFILE, "<", "$cdb/$comment"); my ($dev,$ino,$mod,$nln,$uid,$gid,$rdv,$siz,$ati,$mti,$cti,$bsz,$blk) = stat(COMMENTFILE); { local $/; $ctxt = ; $ctxt =~ s/\n+$//s; } my ($cmd5, $caut, $csub) = ($comment =~ /^(.*?) - (.*?) - (.*)$/); $comments{"$index"}{"$mti$comment"} = { 'cti' => $cti, 'comment' => $comment, 'ctxt' => $ctxt, 'mti' => $mti, 'cmd5' => $cmd5, 'caut' => $caut, 'csub' => $csub, 'entry' => $entry }; close(COMMENTFILE); } close(COMMENTDIR); } } closedir(BLOGDIR); if ( -d "$categorydir" && -x _ && -r _ ) { opendir(CATDIR, "$categorydir"); @categories = grep { !(/^\./) && -d "$categorydir/$_" && -x _ } readdir(CATDIR); for my $category (@categories) { opendir(ENDIR, "$categorydir/$category"); @entries = grep { !(/^\./) } readdir(ENDIR); for my $entry (grep { -r "$datadir/$_" } @entries) { $categories{$category}{$entry} = 1; $entries{$entry{$entry}}{categories}{$category} = 1; } close(ENDIR); } close(CATDIR); } } sub parsequerystring { if (($ENV{"REQUEST_METHOD"} eq "GET") or ($ENV{"REQUEST_METHOD"} eq "POST")) { # if the request is get, grab the variables from the query, post, from stdin if ($ENV{"REQUEST_METHOD"} eq "GET") { $QS = $ENV{"QUERY_STRING"}; $rawQS = $QS; } else { my $head = ''; my $name = ''; my $body = ''; my $cnttype = ''; read STDIN, $data, $ENV{"CONTENT_LENGTH"}; $data .= "\n"; ($ENV{"QUERY_STRING"}) = ($data =~ /(.*?)\n/s); $QS = $ENV{"QUERY_STRING"}; $QS =~ s/\n|\r|\f//gs; $rawQS = $QS; @files = split(/\Q$QS\E/,$data); foreach $file (@files) { $file =~ s/\Q$QS\E//g; ($head, $body) = ($file =~ /^(.*?)\r\n\r\n(.*)/s); $head .= "\r\n"; ($name) = ($head =~ /name\=\"(.*?)\"/); ($cnttype) = ($head =~ /Content\-Type: *([^\;\r]*)[\;\r]/i); ($body) = ($body =~ /(.*[^\n\r\f])[\n\r\f]{1,2}/s); $filedata{$name} = $body; $filetype{$name} = $cnttype; } } #fix bad # anchor implementations $QS =~ s/\#.*//s; # parse the arguments @elements = split(/[&|;]/, $QS); # split at the & or ; parts %argsarray = (); %args = (); foreach $pair (@elements) # foreach segment... { ($key, $value) = split(/=/, $pair); $value =~ s/\+/ /g; $value =~ s/%([0-9A-Fa-f]{2})/pack("c", hex($1))/ge; $args{$key} = $value; if ($argsarray{$key} eq undef) { @{$argsarray{$key}} = (); } if ($value ne "") { push(@{$argsarray{$key}}, $value); } } #repair QS $QS = ''; for my $key (keys %args) { for my $i (0 .. $#{$argsarray{$key}} ) { $QS .= $key . '=' . &uriescape(${$argsarray{$key}}[$i]) . ';'; } } } }