#!/usr/bin/perl -w
#gfx-test.pl
#
#
#
#
# TODO use strict;
package Kwark::Gfx;
# libs
BEGIN{
use strict;
use jip;
use Date::Manip;
use CGI qw(:standard :html3);
use CGI::Ajax;
use File::Find;
use Server;
use Lok;
use Data::Dumper;
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
use Text::Textile qw(textile);
}
# globals; cache dirnames in global var
use vars qw($G $L $debug $start @dirnames $usecount $cachehits $cachemisses $gfxhoofd $gfxvoet);
$usecount++;
$cachehits = 0 unless $cachehits;
$cachemisses = 0 unless $cachemisses;
$start = [gettimeofday] unless ($start);
my $begin=[gettimeofday];
my $apacher;
$apacher = shift if $ENV{MOD_PERL};
my $q = new CGI($apacher);
my $Qself = $q->self_url;
my $Qselfs = $q->url;
# hmm lok lok
$debug=$q->param('debug');
$G="/Gfx";
#$G="/x/gfx2.pl";
$L="/www/gfx";
# mimetype
my $mimetype='text/html';
if ( $q->param('tmpl') && $q->param('tmpl') =~ m!foaf!){
$mimetype="text/xml";
}
if ($q->self_url =~ m!\.rdf$!){
$mimetype="text/xml";
}
my $server = Server->instance('gfx');
# @konijn
#print "xxxx\n";
#print "server: $server";
#exit;
# filename
my ($ufile)=$Qself =~ m!$Qselfs/(.*)!i;
$ufile = '' unless $ufile;
my ($filename) = $Qself =~ m!$Qselfs/(.*)!i;
# remove ? param en .html
$ufile =~ s!\?.*!!;
$ufile =~ s!\.html$!!;
$ufile = "/" unless ($ufile);
# template
my $tmpl;
if ($q->param('tmpl')){
$tmpl = $server->gettemplate($q->param('tmpl'));
}elsif($ufile =~ m!\.rdf$!){
$tmpl = $server->gettemplate('image-foaf');
$ufile =~ s!\.rdf$!!;
}elsif($ufile =~ m!\.test$!){
$tmpl = $server->gettemplate('image-test');
$ufile =~ s!\.test$!!;
} else{
$tmpl = $server->gettemplate('image');
}
#TODO FIXME
my $cufile = $ufile;
$cufile =~ s!^gfx!!;
$cufile =~ s!/$!!;
$cufile =~ s!/gfx/!!;
my $filee=$server->a2id("/gfx/$cufile");
$filee = '/gfx/' if ($filee eq '/gfx');
my $cache = new Cache::FileCache({namespace => 'gfx'} );
my $l = $cache->get($filee);
if (not defined $l && ! $q->param('update') ){
my $l_obj=Lok->new($filee);
$l = $l_obj;
# redirect mislukte urls
my $host = $server->{'config'}->{'hostname'};
$host =~ s!/$!!;
my $xurl = $l_obj->{'row'}->{'xurl'} || '/';
# not found
unless ($l_obj->{'row'}->{'serial'}){
header(-status => 404);
warn "geen filee \'$filee\'";
exit 1;
}
if ( $l->{'row'}->{'filename'} && $l->{'row'}->{'dirname'} ){
$l->{'row'}->{'lastannotated'} = $l->{'row'}->{'filedate2'};
#
# 20030611, location
#
use Location;
my $loc=Location->new($l->{'row'});
unless ( $loc->{'lat'} && $loc->{'lon'} ){
$l->{'row'}->{'nolocation'}=1;
}else{
$l->{'row'}->{'haslocation'} = 1;
$l->{'row'}->{'lat'} = $loc->{'lat'};
$l->{'row'}->{'lon'} = $loc->{'lon'};
$l->{'row'}->{'locationname'} = $loc->{'locationname'};
$l->{'row'}->{'fromlocation'} = $loc->{'fromlocation'};
$l->{'row'}->{'fromlocationname'} = $loc->{'fromlocationname'};
#20040821
if ($loc->{'airport'}){
$l->{'row'}->{'airport'} = $loc->{'airport'};
}
if ($loc->{'airportiata'}){
$l->{'row'}->{'airportcountry'} = $loc->{'airportcountry'};
$l->{'row'}->{'airportlatitude'} = $loc->{'airportlatitude'};
$l->{'row'}->{'airportlongitude'} = $loc->{'airportlongitude'};
$l->{'row'}->{'airportname'} = $loc->{'airportname'};
$l->{'row'}->{'airportiata'} = $loc->{'airportiata'};
$l->{'row'}->{'airportdistance'} = $loc->{'airportdistance'};
$l->{'row'}->{'airport'} = $loc->{'airportiata'};
}
# lastannotated TODO, niet locationname maar location
# if (defined($loc->{'lastupdate'}) &&
# $loc->{'lastupdate'} gt $l->{'row'}->{'lastannotated'} ){
# $l->{'row'}->{'lastannotated'} = $loc->{'lastupdate'};
# $l->{'row'}->{'lastannotatedthing'} = 'location';
#}
}
# 20040921 TODO testing nearby locations
if (defined($l->{'row'}->{'haslocation'})
&&
$l->{'row'}->{'haslocation'} eq 1){
my $lat = $l->{'row'}->{'lat'};
my $lon = $l->{'row'}->{'lon'};
my @locationnames = Location::getnearnames( lon => $lon,
lat => $lat,
limit => 20,
);
# print Dumper(@locationnames);
$l->{'nearlocationnames'} = \@locationnames;
# BBBOX @TODO
my ($bllon,$bllat,$trlon,$trlat) = (999,999,-999,-999);
foreach (@locationnames){
$bllat = $_->{'lat'} if ($_->{'lat'} && $_->{'lat'} < $bllat);
$bllon = $_->{'lon'} if ($_->{'lon'} && $_->{'lon'} < $bllon);
$trlat = $_->{'lat'} if ($_->{'lat'} && $_->{'lat'} > $trlat);
$trlon = $_->{'lon'} if ($_->{'lon'} && $_->{'lon'} > $trlon);
}
$l->{'bllat'} = $bllat;
$l->{'bllon'} = $bllon;
$l->{'trlat'} = $trlat;
$l->{'trlon'} = $trlon;
}
#
# /location
#
#
# person 20030822
#
use Person;
my $depicts=new Person( { lok => $l, });
if ($depicts->[0]->{'riplastupdate'}){
#warn Dumper($depicts);
#lastannotated TODO
if ($depicts->[0]->{'riplastupdate'} gt $l->{'row'}->{'lastannotated'}){
$l->{'row'}->{'lastannotated'} = $depicts->[0]->{'riplastupdate'};
$l->{'row'}->{'lastannotatedthing'} = 'person';
}
$l->{'depicts'} = $depicts;
}
# }
#
# /person
#
#
# word 2003-12
#
#TODO anno
use Word;
my ($word2,$wlastupdated) = Word->getwords({imageid => $l->{'serial'},
about => $l->{'id'},
}
);
my @arr;
$l->{'words2'} = \@arr;
if ($word2){
$l->{'words2'} = $word2;
}
my $word = Word->new($filee);
if ($word->{'lastupdate'}
&&
($word->{'lastupdate'} gt $l->{'row'}->{'lastannotated'} )
){
$l->{'row'}->{'lastannotated'} = $word->{'lastupdate'};
$l->{'row'}->{'lastannotatedthing'} = 'word';
}
#print Dumper($word->{'words'} );
if ( $word->{'words'} ){
my @words;
foreach my $w (@{$word->{'words'} }){
my $row={};
$row->{'word'} = $w;
# my ($sw) = $w =~ m!(\w+$)!;
my ($sw) = $w =~ m!1\.6/(.*?)$!;
#$row->{'lcsword'} = lc($sw);
$row->{'sword'} = $sw;
$row->{'shortword'} = lc($sw);
$row->{'shortword'} =~ s/-\d+$//;
if ($row->{'synsetid'} && $row->{'wordid'}){
my $ww = Word->newfromwordid($row->{'wordid'}, $row->{'synsetid'});
}
push @words, $row;
#" word:$w \n";
}
$l->{'words'} = \@words;
}
#
# /word 2003-12
#
#
# .txt 20041104
#
if (0){
my $textfilee = '/www/' . $filee . ".txt";
if ( -r $textfilee ){
warn "textfilee: $textfilee";
open (FILEE,"<$textfilee") || warn "cannot open textfilee $!";
my $extext;
while (){
$extext .= $_;
}
close FILEE;
warn "textfilee inhoud: $extext";
my ($eurl) = $extext =~ m!url\:(.*)!;
$eurl =~ s!\s^!!;
$eurl =~ s!$\s!!;
if ($eurl){
warn "textfilee found [$eurl]";
}
}else{
warn "geen textfilee: $textfilee";
}
}
#
# /.txt
#
#
# next en prev
#
my ($lp,$ln) = ($l->getnextenprev);
if ($ln){
my $lokn=Lok->new($ln);
my @loknext;
$lokn->{'row'}->{'qselfs'}=$Qselfs;
push @loknext,$lokn->{'row'};
$l->{'loknext'} = \@loknext;
$l->{'loknexturl'} = $lokn->{'row'}->{'id'};
# $tmpl->param(
# loknext => \@loknext,
# loknexturl => $lokn->{'row'}->{'id'}
# );
}else{
# anders volgende = dir up
my $lokn=Lok->new( $l->{'row'}->{'dirname'} );
my @loknext;
$lokn->{'row'}->{'qselfs'}=$Qselfs;
$lokn->{'row'}->{'comment'}='End';
push @loknext,$lokn->{'row'};
$l->{'loknext'} = \@loknext;
$l->{'loknexturl'} = $lokn->{'row'}->{'id'};
# $tmpl->param(
# loknext => \@loknext,
# loknexturl => $lokn->{'row'}->{'id'}
# );
}
if ($lp){
my $lokp=Lok->new($lp);
# print Dumper($lp);
my @lokprev;
$lokp->{'row'}->{'qselfs'}=$Qselfs;
push @lokprev,$lokp->{'row'};
$l->{'lokprev'} = \@lokprev;
$lokprevurl = $lokp->{'row'}->{'id'};
$l->{'lokprevurl'} = $lokprevurl ;
# $tmpl->param(
# lokprev => \@lokprev,
# lokprevurl => $lokp->{'row'}->{'id'}
#
# );
}
#
# /end next en prev
#
}elsif ( $l->{'row'}->{'dirname'} ) {
#
# A DIRECTORY
#
# print Dumper($l->getdir);
my $dirname = $l->{'row'}->{'dirname'};
#print Dumper($l);
my $files=$l->getdir;
my @images;
foreach my $i (@{$files}){
my $il=Lok->new($dirname . "/$i");
my $irow=$il->{'row'};
$irow->{'qselfs'} = $Qselfs;
#print $i . Dumper($irow);
push @images,$irow;
}
$l->{'images'} = \@images;
# $tmpl->param(images => \@images);
my $dirreadmef = $server->{'config'}->{'prefix'} . $dirname;
$dirreadmef = "$dirreadmef/README";
my $dirreadme;
$dirreadme = `cat "$dirreadmef"` if -r "$dirreadmef";
#print "dirreadme: file[$dirreadmef] [$dirreadme] ";
#exit;
$l->{'dirreadme'} = $dirreadme;
# $tmpl->param(dirreadme => $dirreadme);
}
if (1){
# comments
my $cid = $l->{'row'}->{'id'};
my $qcid = $server->quote( "%$cid%" );
my $xurl= $l->{'row'}->{'xurl'} || '';
$xurl =~ s!.html$!!;
my $qcxurl= $server->quote( "%$xurl%" );
my $cq = "
SELECT * FROM comments
WHERE about LIKE $qcid OR about LIKE $qcxurl
ORDER BY timestamp desc
LIMIT 30
";
my ($csth,$cerror)=$server->doq($cq);
print $cerror if $cerror;
my @comments;
while (my $row=$csth->fetchrow_hashref){
my $html = textile($row->{'comment'} . " ");
$html =~ s!(http\:\/\/.*?)\s!$1!;
$html =~ s!^\!!;
$html =~ s!\<\/p\>$!!;
$row->{'html'} = $html;
push @comments,$row
}
$csth->finish;
my $commentscount=@comments;
$l->{'comments'} = \@comments;
$l->{'commentscount'} = $commentscount;
#print Dumper($l);
}
# /comments
# hoofd?
#$l->{'hoofd'} = $server->gethoofd('gfx-test');
# voet
#$l->{'voet'} = voet2('plaatjes');
#
# 20040905 votes
#
use Vote;
my $vote = Vote->new( {about => $l->{'id'} ,} );
my @votes = $vote->{'votes'};
$l->{'votetotal'} = $vote->{'votetotal'};
#
# dirnames
# 20041224, try caching
# my @dirnames;
unless ($dirnames[1]){
my $query="
SELECT distinct dirname
FROM images
WHERE dirname LIKE '/gfx/%'
ORDER BY dirname
";
my ($sth,$error)=$server->doq($query);
while (my $row = $sth->fetchrow_hashref){
$row->{'dirname'} =~ s!/gfx!!;
push @dirnames,$row;
}
$sth->finish;
}
#20040611, next,cur,prev dirs
my $dirnumber='0';
my $curdirnumber='0';
foreach my $row(@dirnames){
#while ( my $row = $sth->fetchrow_hashref ){
#print $row->{'dirname'} . " -- " . $l->{'row'}->{'dirname'} ;
#print "
";
# ???????
if ($row->{'dirname'} && $l->{'row'}->{'dirname'}){
if ( $row->{'dirname'} eq $l->{'row'}->{'dirname'}
||
"/gfx". $row->{'dirname'} eq $l->{'row'}->{'dirname'}
){
$row->{'selected'} = 1;
$curdirnumber = $dirnumber;
}
}
$row->{'dirname'} =~ s!/gfx!!;
($row->{'sdirname'}) = $row->{'dirname'} =~ m!.*/(.*?)$!;
# push @dirnames,$row;
$dirnumber++;
}
# print " curdirnumber $curdirnumber ";
my @prevdir;
$prevdir[0] = $dirnames[$curdirnumber - 1];
my @curdir;
$curdir[0] = $dirnames[$curdirnumber];
my @nextdir;
$nextdir[0] = $dirnames[$curdirnumber + 1] if $dirnames[$curdirnumber];
# $l->{'dirnames'} = \@dirnames;
$l->{'prevdir'} = \@prevdir;
$l->{'curdir'} = \@curdir;
$l->{'nextdir'} = \@nextdir;
#
# /dirnames
#
#
# crumb
#
my @crumb;
my $dir = $l->{'row'}->{'dirname'};
my @dirs=split '/' , $dir;
my $cb = $server->{'config'}->{'hostname'};
my $gr = $Qselfs;
foreach my $i(@dirs){
my $c={};
my $d=$i;
my $ddi;
if ($i eq 'gfx'){
$gr = $Qselfs;
$d = 'Plaatjes';
$ddi = $gr;
}else{
$gr .= "/$i";
}
# print "[$i]";
# print $gr;
if ($i && $ddi && ($i eq $ddi) ){
$d = 'Kwark';
$ddi=$server->{'config'}->{'hostname'};
}
if ($i eq ''){
$d = 'Kwark';
$ddi=$server->{'config'}->{'hostname'};
$gr=$ddi;
}
$c->{'url'} = $gr;
$c->{'d'} = $d;
push @crumb,$c;
}
$l->{'crumb'} = \@crumb;
# 200602 topsearches
my @topsearchterms = $l_obj->topsearchterms();
$l->{'topsearchterms'} = \@topsearchterms;
#
# 15 hits
#
my $getlastloginc = {
'imageid' => $l->{'row'}->{'serial'},
'about' => $l->{'row'}->{'id'},
};
my @hitsa = @{Lok::getlastlog($getlastloginc)};
foreach my $hrow( @hitsa ){
# refer
if ( $hrow->{'http_referer'} ){
$hrow->{'http_refererd'} = $server->toencode( $hrow->{'http_referer'} );
$hrow->{'http_refererd'} = $server->spacify( $hrow->{'http_referer'} );
$hrow->{'http_referer'} =~ s!&!&!g;
$hrow->{'http_referer'} =~ s!&!&!g;
$hrow->{'http_refererd'} =~ s!&!&!g;
$hrow->{'http_refererd'} =~ s!&!&!g;
}
#host
if ( $hrow->{'remote_host'} ){
$hrow->{'remote_hostd'} = $server->toencode( $hrow->{'remote_host'} );
$hrow->{'remote_hostd'} = $server->spacify( $hrow->{'remote_host'} );
$hrow->{'remote_host'} =~ s!&!&!g;
$hrow->{'remote_host'} =~ s!&!&!g;
}
}
$l->{'hitsa'} = \@hitsa;
$l->{'totalhits'} = $l_obj->totalhits;
#
# / 15 hits
#
# ajaxy word
my $pjx = CGI::Ajax->new( 'myfunc' => '/x/2006/test-ajax-word.pl',
'search' => '/x/2006/test-ajax-word.pl',
'addword' => '/x/2006/test-ajax-word.pl',
'delword' => '/x/2006/test-ajax-word.pl',
'personsearch' => '/x/2006/test-ajax-word.pl',
'addperson' => '/x/2006/test-ajax-word.pl',
'delperson' => '/x/2006/test-ajax-word.pl',
);
$pjx->cgi( $q );
$l->{'extrajavascript'} = $pjx;
# /ajaxy word
# mangle lastupdate
$l->{'row'}->{'lastannotated'} = UnixDate(ParseDate($l->{'row'}->{'lastannotated'}), "%Y-%m-%d %H:%M %Z");
$l->{'lastannotated'} = $l->{'row'}->{'lastannotated'};
my $cachefilltime = sprintf("%01.3f", tv_interval ( $begin, [gettimeofday]));
$l->{'cachefilltime'} = $cachefilltime;
$cachemisses++;
#
# write cache
#
my $valid=3 * 7 * 24 * 60 * 60;
# we houden gecachede zaken lekker lang vast ... --sjoerd, di mrt 22 11:15:44 CET 2022
$valid = $valid * 1000;
my $cachetimeout = $valid + int(rand($valid)) + 300;
$cache->set( $filee, $l, "$cachetimeout");
#warn "cache filled in $cachefilltime seconds for $filee valid for $cachetimeout";
$goedeurl = $l->{'row'}->{'xurl'};
if( $q->param('update') ){
warn "update redir to $goedeurl";
redirect($goedeurl . "?" . int(rand(10000000000)));
exit;
}
my $remote = $ENV{REMOTE_HOST} ||$ENV{REMOTE_ADDR} || '' ;
warn "generating $remote $filee $mimetype";
} else {
#
# we komen uit de cache hiephiep
#
$l->{'fromcache'} = 1;
$l->{'fromcachespeedup'} = sprintf("%01.1f", $l->{'cachefilltime'} / tv_interval ( $begin, [gettimeofday]) );
$cachehits++;
my $ratio = "$cachehits/$cachemisses";
my $remote = $ENV{REMOTE_HOST} ||$ENV{REMOTE_ADDR} || '' ;
# sjoerd, Sun Mar 1 10:53:52 CET 2009, uitgezet omdat dit geen errorsituatie is maar een indicatie van de cache performance
# warn $l->{'fromcachespeedup'} . "x speedup hitratio $ratio $remote $filee $mimetype";
}
# done caching
#-----------------------------------------------------------
# redir
$goedeurl = $l->{'row'}->{'xurl'};
# redirect rdf trash url
if ($q->param('tmpl') && !$q->param('autonext')
&& $q->param('tmpl') =~ m!foaf!
&& $l->{'row'}->{'rdfurl'}
){
my $goederdfurl = $l->{'row'}->{'rdfurl'};
warn 'rdftrashurl: ' . $Qself . ' goedeurl: ' . $goederdfurl;
print $q->redirect(
-location => $goederdfurl,
-status => 301,
);
exit;
}
my $redirect = 0;
if ($q->param('tmpl')
&& $q->param('tmpl') =~ m!foaf!
&& $q->param('autonext')
){
$redirect = 1;
}
if ($q->param('autonext') && $Qself =~ /foaf/){
$redirect = 1;
}
if ($Qself =~ m/foaf/ && $Qself =~ m!tmpl!){
$redirect =1;
}
if ($redirect){
warn 'trashurl: ' . $Qself . ' goedeurl: ' . $goedeurl;
unless ($goedeurl){
# not found
header(-status => 404);
warn "geen xurl \'$Qself\'";
exit 1;
}
print $q->redirect(
-location => $goedeurl,
-status => 301,
);
exit;
}
# all image props in tmpl
for my $var (keys %{$l->{'row'}} ){
#print $var;
if ($var eq 'lastannotated' && $l->{'row'}->{$var} ){
# TODO
#warn $l->{'row'}->{$var};
$l->{'row'}->{$var} =~ s!^(\d+-\d+-\d+)\s(\d)!$1T$2!;
}
$tmpl->param( $var => $l->{'row'}->{$var} );
}
# alle cgi param
for my $var ( $q->param ){
#print $var;
my $x='cgi_' . $var;
my $val= $q->param($var);
$tmpl->param( $x => $val );
if ($var eq 'autonext'){
$tmpl->param( autonextd => $val . "s" );
$tmpl->param( autonext => $val );
}
}
#voet hoof
# hoofd?
$gfxhoofd = $server->gethoofd('gfx-test') unless $gfxhoofd;
$l->{'hoofd'} = $gfxhoofd;
# voet
$gfxvoet = voet2('plaatjes') unless $gfxvoet;
$l->{'voet'} = $gfxvoet;
my $end=[gettimeofday];
$l->{'elapsed'} = sprintf("%01.3f", tv_interval ( $begin, $end ));
$l->{'running'} = int(sprintf("%01.3f", tv_interval ( $start, $end )));
$tmpl->param($l);
$tmpl->param(
usecount => $usecount,
qselfs => $Qselfs,
qself => $Qself,
filee => $filee,
ufile => $ufile,
);
print $q->header(-type => $mimetype,
-expires => '+96hours' ,
-charset =>'UTF-8');
print $server->compact( $tmpl->output );
my $logres = Lok::newhit($l->{'row'}->{'serial'} , $l->{'about'});
#warn "$filename $Qselfs $filee";
undef $l;
# kla.