#!/usr/bin/perl -w -I. #!/usr/bin/perl -d:ptkdb sub BEGIN {$ENV{DISPLAY} = ":0.0"; } # # TWiki WikiClone (see $wikiversion in wiki.pm for version) # # Copyright (C) 2000 Sterbini, Andrea a.sterbini@flashnet.it # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. # # This program 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 General Public License for more details, published at # http://www.gnu.ai.mit.edu/copyleft/gpl.html # ###################################################################### # # This cgi script produces a "dot" file describing the links in a Web # The "dot" file can be used by webdot (with the help of graphviz) # to produce a nice clickable map of the web # ###################################################################### # # TODO: show also html links # ###################################################################### use CGI; use wiki; do "wikicfg.pm"; $query = new CGI; #open(STDERR,'>&STDOUT'); # redirect error to browser $| = 1; # no buffering #print "Content-type: text/plain \n\n"; #use vars qw($excludeWeb); &main(); sub main { #FIXME: move to wikicfg.pm or find a way to put it in the URL #uncomment next line if you don't want users/groups in your graph my $excludeWeb = "$wiki::mainWebname"; $excludeWeb = ""; my $thePathInfo = $query->path_info(); my $theRemoteUser = $query->remote_user(); my $theTopic = $query->param( 'topic' ); my $theUrl = $query->url; # my ( $topic, $webName, $scriptUrlPath, $userName ) = &wiki::initialize( $thePathInfo, $theRemoteUser, $theTopic, $theUrl ); # $webName = $query->path_info(); # get the web name by removing the file extension # $webName =~ s/^\/?(.*)\.dot$/$1/oi ; $topic =~ s/^\/?(.*)\.dot$/$1/oi ; if( ! &wiki::webExists( $webName ) ) { $tmpl= &wiki::readTemplate( "noweb" ); $tmpl = &wiki::handleCommonTags( $tmpl, $topic ); print "Content-type: text/html \n\n"; print $tmpl; return; } my $tempVal = ""; my $tmpl = &wiki::readTemplate( "stepmap" ); $tmpl = &wiki::handleCommonTags( $tmpl, $topic ); my( $tmplHead, $tmplTopic, $tmplEndTopics, $tmplExternalHeader, $tmplExternalTopicWeb, $tmplExternalTopic, $tmplExternalEnd, $tmplLink, $tmplEnd ) = split( //oi, $tmpl ); # $tmplHead = &wiki::handleCommonTags( $tmplHead, $topic ); if( ! $tmplEnd ) { print ""; print "

TWiki Installation Error

"; print "Incorrect format of stepmap.tmpl (missing <SPLIT> parts)"; print ""; return; } my $webColor = &getWebColor($webName); my @topicList = (); my @found = (); my %externalTopics = (); my %allTopicsLinks = (); my @topicLinks = (); my $text = ""; my @links = (); my @hrefs = (); # read first page and check out for internal links if (! exists $allTopicLinks{$topic}) { $allTopicLinks{$topic} = []; } &wiki::initialize( $thePathInfo, $theRemoteUser, $topic, $theUrl ); $text = &wiki::readWebTopic("$webName","$topic"); ( $text, $atext, $after) = split( //, $text); # FIXME: should we completely render the page? $text = &wiki::handleCommonTags($text, $topic, $webName); $text = &wiki::getRenderedVersion($text, $webName); @topicList = &getTopicList($text, "$webName/$topic"); # use only current web @topicList = grep { /^\Q$webName\E/ } @topicList; # find last modification date (should I use .changes instead?) my @dates = sort { $b <=> $a } map { (stat "$wiki::dataDir\/$_.txt")[9] } @topicList; # with this line webdot computes the image ONLY if something changes # in this web print "Last-Modified: " . (scalar localtime $dates[0]) . "\n"; print "Content-type: text/plain \n\n"; $tmplHead =~ s//$webName/goi; $tmplHead =~ s//$webColor/goi; print $tmplHead; # get all internal links from the current page my $tmpTxt = "$tmplTopic"; $tmpTxt =~ s//$topic/goi; print $tmpTxt; foreach $topic (@topicList) { $topic = $topic; $webName = $topic; $topic =~ s/^.*\///g; # cut "Web/" $webName =~ s/\/.*$//g; # cut "/Topic" my $tmpTxt = "$tmplTopic"; $tmpTxt =~ s//$topic/goi; print $tmpTxt; # print #"\"$topic\" #"; if (! exists $allTopicLinks{$topic}) { $allTopicLinks{$topic} = []; } $topicLinks = $allTopicLinks{"$topic"}; &wiki::initialize( $thePathInfo, $theRemoteUser, $topic, $theUrl ); $text = &wiki::readWebTopic("$webName","$topic"); ( $text, $atext, $after) = split( //, $text); # FIXME: should we completely render the page? $text = &wiki::handleCommonTags($text, $topic, $webName); $text = &wiki::getRenderedVersion($text, $webName); @links = &getTopicList($text); my @lista = (); foreach $link (@links) { $link =~ s/^\Q$webName\E\///g; # remove own "Web/" ###### $link =~ s/^(\Q$webName\E(\.|\/))?([A-ZÄÖÜ][a-zäöüß]+[A-ZÄÖÜ][a-zäöüßA-ZÄÖÜ0-9]*)[\,\.\?!]?$/$3/o ; ###### $link =~ s/^(.+)(\.|\/)([A-ZÄÖÜ][a-zäöüß]+[A-ZÄÖÜ][a-zäöüßA-ZÄÖÜ0-9]*)[\,\.\?!]?$/$1\/$3/o ; ###### $link =~ s/\./\//go ; $link =~ s/\/\//\//go ; # // -> / @found = grep { /^\Q$link\E$/ } @$topicLinks; if ( $#found ) { push @$topicLinks, ("$link") ; # collect links to other webs if ( $link =~ /^(.+)\/(.+)$/ ) { if ($1 ne $excludeWeb) { if (! exists $externalTopics{"$1"}) { $externalTopics{"$1"} = []; } $lista = $externalTopics{"$1"}; @found = grep { /^\Q$2\E$/ } @$lista; if ($#found) { push @$lista, ("$2"); } } } } } } #TODO: handle some tags print $tmplEndTopics; #print #"//} #"; foreach $web (sort keys %externalTopics) { if ($web ne $excludeWeb) { $webColor = getWebColor($web); my $tmpTxt = "$tmplExternalHeader"; $tmpTxt =~ s//$web/goi; $tmpTxt =~ s//$webColor/goi; print $tmpTxt; # print #" subgraph \"cluster$web\" \{ # graph [ #// shape = box #// color = $webColor #// label = \"$web\" #// fontsize = 14 # color = white # ] # node [ # color = $webColor # URL = \"$wiki::scriptUrlPath/view$wiki::scriptSuffix/\\N\" # ] #"; my @lista = sort @{$externalTopics{$web}}; foreach $link (@lista) { if ($link eq $wiki::mainTopicname) { $tmpTxt = "$tmplExternalTopicWeb"; # print #" \"$web/WebMap\" [label=\"$web\" shape=ellipse] #"; } else { $tmpTxt = "$tmplExternalTopic"; # print #" \"$web/$link\" [label=\"$link\"] #"; } $tmpTxt =~ s//$link/goi; $tmpTxt =~ s//$web/goi; $tmpTxt =~ s//$webColor/goi; print $tmpTxt; } print $tmplExternalEnd; # print #" } #"; } } foreach $topic (sort keys %allTopicLinks) { my @lista = sort @{$allTopicLinks{$topic}}; foreach $link (@lista) { $tmpTxt = "$tmplLink"; $tmpTxt =~ s//$topic/goi; $tmpTxt =~ s//$link/goi; $tmpTxt =~ s//$webName/goi; $tmpTxt =~ s//$webColor/goi; print $tmpTxt; # print #"\"$topic\"->\"$link\" #"; } } print $tmplEnd; # print #"} #"; return; } #================================================= sub getWebColor { my ($webName) = @_; &wiki::initializePrefs("guest",$webName); my $webColor = &wiki::getPreferencesValue("WEBBGCOLOR", $webName) || "gray" ; if ($webColor =~ /\#[0-9A-F]{6}/i ) { $webColor =~ s/#([0-9A-F][0-9A-F])([0-9A-F][0-9A-F])([0-9A-F][0-9A-F])/"".&handleColor($1)." ".&handleColor($2)." ".&handleColor($3).""/ei ; my @hsb = rgb2hsb( split( / /, $webColor)); $webColor = join " ", @hsb; } return $webColor; } sub handleColor { my ($hexColor) = @_; return eval("0x$hexColor"); } #===================================================================== # thanks a lot to ManprretSingh for the colour conversion code! sub maxof { my ($a, $b) = @_; return $a>$b?$a:$b; } sub minof { my ($a, $b) = @_; return $a<$b?$a:$b; } # Converts rgb to hsb. All numbers are within range 0 to 1 sub rgb2hsb { my ($r, $g ,$b) = @_; my ($h, $s, $br); my $max = maxof($r, maxof($g, $b)); my $min = minof($r, minof($g, $b)); $br = $max/255.0; if ($max > 0.0) { $s = ($max - $min) / $max; } else { $s = 0.0; } if ($s > 0.0) { my ($rc, $gc, $bc, $diff); $diff = $max - $min; $rc = ($max - $r) / $diff; $gc = ($max - $g) / $diff; $bc = ($max - $b) / $diff; if ($r == $max) { $h = ($bc - $gc) / 6.0; } elsif ($g == $max) { $h = (2.0 + $rc - $bc) / 6.0; } else { $h = (4.0 + $gc - $rc) / 6.0; } } else { $h = 0.0; } if ($h < 0.0) { $h += 1.0; } return ($h, $s, $br); } sub getTopicList { my ($text, @addtopics) = @_; my (@topicList); @topicList = map { /twiki\/bin\/view\/([A-ZÄÖÜ][a-zäöüßA-ZÄÖÜ0-9]+\/[A-ZÄÖÜ][a-zäöüßA-ZÄÖÜ0-9]*)/, $1} grep { /twiki\/bin\/view\/([A-ZÄÖÜ][a-zäöüßA-ZÄÖÜ0-9]+\/[A-ZÄÖÜ][a-zäöüßA-ZÄÖÜ0-9]*)/ } split ( /[\n\s\t\|]/ , $text); # topicList now contains Main/StefanScherer, Dpf/HugoTest, ... push @topicList, @addtopics; # eliminate duplicate entries: Perl cookbook p.102 my %seen = (); @topicList = grep { ! $seen{$_} ++ } @topicList; @topicList = sort @topicList; return (@topicList); } 1;