#!/usr/bin/perl ################################################################################ # # # fsweblog 0.9.7.3 http://seth.positivism.org/blog.cgi?get=src # # # # Copyright (c) 2003/4/5 Seth Alan Woolley, released under the GNU GPL >= v.2 # # See http://www.fsf.org/licenses/gpl.txt for a copy of the license. # # # ################################################################################ # configuration variables $hometitle = "ashanks' blog"; # required per RSS spec. $homedescr = "This is fsweblog."; # required per RSS spec. $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 = "http://swoolley.org/man.cgi/c=1"; # non-builtin CSS $turing = "fsweblog"; # turing test for commenters # or edit the CSS below. $relpath = "fsweblog/"; # 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. $noquery = 1; # 1 if PATH_INFO, undef for QUERY_STRING $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. # # 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' # ################################################################################ #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; } 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'] #); my $get = $args{"get"}; if($get eq "") { my ($lbb, $lbe) = &bound(scalar keys %entries, 'blog', $blogstart, $blogmax); ################################################## FRONT TEMPLATE BEGIN print qq`Content-type: text/html\r\n\r @{[&plaintext($hometitle)]} - @{[&plaintext($homedescr)]}

@{[&plaintext($hometitle)]}

@{[&plaintext($homedescr)]}

@{[$#entries==-1?'

This blog is empty.

':'']}`; for my $entry ((reverse sort keys %entries)[$lbb .. $lbe]) { print qq`
@{[&entryheader($entry, 1)]} @{[&entrybody($entry)]}
`; } print qq`

[ Show All | Search | RDF RSS 1.0 Feed ( Raw ) | Last Blog Image (PNG) (JPEG) | Browse Archive | XHTML 1.1 Valid | RSS 1.0 Valid | CSS Level 3 Valid | CSS File | PERL Source Code ]

user, system, child user, child system: @{[join(', ',times)]} seconds

`; ################################################## FRONT TEMPLATE END } elsif($get eq "post") { &commentpost(); local $entry = $entry{$args{"post"}}; ################################################## POST TEMPLATE BEGIN print qq`Content-type: text/html\r\n\r @{[&plaintext($hometitle)]} - @{[&plaintext($homedescr)]}

@{[&plaintext($hometitle)]}

@{[&plaintext($homedescr)]}

@{[&entryheader($entry, undef)]} @{[&entrybody($entry)]}
`; for my $comment (reverse sort keys %{$comments{$entry}}) { print qq`@{[&commentheader($entry, $comment)]} @{[&commentbody($entry, $comment)]}`; } print qq`
@{[($commentsenable{$entry})?qq|

Leave A Comment

Secret is used for editing your own comment. If subject, secret, and name all are the same as a previous comment, it will be overwritten. Turing is the name of this program (look at the Source Code link on the front page), used to see if you are human.

|:qq||]}
`; ################################################## POST TEMPLATE END } elsif($get eq "rdf") { my ($lbb, $lbe) = &bound(scalar keys %entries, 'blog', $rdfstart, $rdfmax); ################################################## RDF TEMPLATE BEGIN print qq`Content-type: text/xml\r\n\r @{[&plaintext($hometitle)]} $homeurl @{[&plaintext($homedescr)]} $homelang `; for my $entry ((reverse sort keys %entries)[$lbb .. $lbe]) { print qq` `; } print qq` `; for my $entry ((reverse sort keys %entries)[$lbb .. $lbe]) { print qq` @{[&plaintext($entries{$entry}{entry})]} @{[&cuttext(&plaintext($entries{$entry}{etxt}),100)]} @{[&linktype($entry, $args{type})]} @{[&dctime($entries{$entry}{mti})]} `; } print qq` `; ################################################## RDF TEMPLATE END } elsif($get eq "css") { ################################################## CSS TEMPLATE BEGIN print qq`Content-type: text/css\r \r body { font-family: monospace; } `; ################################################## CSS TEMPLATE END } elsif($get eq "search") { ################################################## SEARCH TEMPLATE BEGIN print qq`Content-type: text/html\r\n\r @{[&plaintext($hometitle)]} - @{[&plaintext($homedescr)]}

@{[&plaintext($hometitle)]}

@{[&plaintext($homedescr)]}

Search Entries and Comments

@{[&search($args{search})]}
`; ################################################## SEARCH TEMPLATE END } elsif(($get eq "png") || ($get eq "jpeg")) { my $height = 12; # per character my $width = 6; # per character my $maxtext = 100; # max text chars my @entries = reverse sort keys %entries; my $text = $entries{$entries[0]}{entry}; eval "use GD;"; binmode(STDOUT); $text = substr($text,0,$maxtext); $length = length($text) * $width + 2; my $im = new GD::Image($length,$height+1); $bg = $im->colorAllocate($bg[0],$bg[1],$bg[2]); $fg = $im->colorAllocate($fg[0],$fg[1],$fg[2]); if ($tp) { $im->transparent($bg) } $im->string(GD::Font->Small, 1, -1, $text, $fg); my $imdata; if ($get eq "png") { $imdata = $im->png } else { $imdata = $im->jpeg } my $imdatalen = length($imdata); print "Content-type: image/$get\r\nContent-length: $imdatalen\r\n\r\n$imdata"; } elsif($get eq "src") { print "Content-type: text/plain\r\n\r\n"; open(SOURCE, "<$filename"); { local $/; print ; } close(SOURCE); } else { print qq`Content-type: text/plain\r\n\r\nInvalid get type.`; } ################################################## TEMPLATE SUBROUTINES BEGIN sub entryheader { my $entry = shift; my $link = shift; # boolean return qq`

@{[scalar localtime($entries{$entry}{mti})]} --@{[($link)?(($commentsenable{$entry})?qq| Post (Comments: @{[scalar keys %{$comments{$entry}}]}) --|:qq| Post (No Comments Allowed) --|):'']} @{[&plaintext($entries{$entry}{entry})]}

`; } sub entrybody { my $entry = shift; return qq`

@{[&prettify(&plaintext($entries{$entry}{etxt},8))]}

`; } sub commentheader { my $entry = shift; my $comment = shift; return qq`

@{[scalar localtime($comments{$entry}{$comment}{mti})]} -- Comment @{[&plaintext($comments{$entry}{$comment}{csub})]} -- by @{[&plaintext($comments{$entry}{$comment}{caut})]}

`; } sub commentbody { my $entry = shift; my $comment = shift; return qq`

@{[&prettify(&plaintext($comments{$entry}{$comment}{ctxt},8))]}

`; } sub linktype { my $entry = shift; my $type = shift; return ($type ne "raw") ? "$homeurl$filename@{[&linkup(&uriescape($entries{$entry}{entry}))]}" : "$homeurl$datadir/@{[&uriescape($entries{$entry}{entry})]}"; } ################################################## TEMPLATE SUBROUTINES END sub bound() { my $entries = shift; my $name = shift; my $start = shift; my $max = shift; my $lstart = ($args{"${name}start"})?$args{"${name}start"} : $start ; $lstart = ($lstart <= "0") ? 10000000000000000000 : $lstart; $lstart = ($lstart > $entries) ? $entries : $lstart; my $entrymax = $entries - $lstart; my $lmax = ($args{"${name}max"})?$args{"${name}max"}-1 : $max - 1; $lmax = ($lmax < "0") ? 1000000000000000000000 : $lmax ; $lmax = ($lmax > $entrymax) ? $entrymax : $lmax ; return ($lstart - 1, $lstart + $lmax - 1); } sub prettify() { local $_ = shift; s/([a-z]+\:\/\/[A-Z0-9a-z.-]+(?:\/[^\t\n\l\r<" ]*|))/$1<\/a>/gs; return &wraplong($_) } sub wraplong() { local $_ = shift; s/([^<>\t\n\l\r ]{77})/$1\\ /gs; s/(<[^>]+)\\ ([^>]*>)/$1$2/gs; s/(]+>) (.*) (<\/a>)/$1$2$3/gs; 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; 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($#_>$l) { return $_; } else { $_ = substr($_,0,$l+1); s/ ?[^ ]*$/.../g; 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) { 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; my $line = 78; 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 = "Regarding $entries{$entry}{esub} - Status Changed @{[scalar localtime($entries{$entry}{cti})]} - Last Modified @{[scalar localtime($entries{$entry}{mti})]} - $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/$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
$resultset
`; $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`

$resultscount ` . ($resultscount==1?'match':'matches') . " found in $resultstotal " . ($resultstotal==1?$type:$types) . " for search term @{[&plaintext($search)]}:

$results"; } else { return qq`

No match found in any $type` . " 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 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); } 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]) . ';'; } } } }