#!/usr/bin/perl #use K_CGI; #use Mysql; use strict; # Version 4, begyndt udarbejdet 5. feb. 1998 # Brugerfladeændringer for at højne forståelsen # OS navne også nede i skemaet. # Tak til alle der har bidraget, og opfordring til at bidrage. # #Version 3, udarbejdet 16. nov 1997, tilrettet 4. dec. 1997 #Hastigheds optimering. # Første version brugte en ukristelig mængde SELECT's og ingen JOIN's. # Det var min første MySQL client og den skulle være klar hurtigt, så # jeg tog ingen chancer. # Denne version skulle også gerne få et meget pænere lay-out, folk er # kommet med en del hentydninger, og første version er virkelig grim. # #Version 2, udarbejdet 24. oct 1997 #Tilføjer mindstebredde vha. gif-padding, # og retter en bug - sub-areas kom i indtastningsrækkefølge # så areas blev skilt ad når der indføjedes nye sub-areas. # Løst ved at sortere på navn. ########################################################################## # # configuration start # my $HiRes = 0; # set to 0 and comment out the next line if HiRes isn't available #use Time::HiRes qw( usleep ualarm gettimeofday tv_interval ); my $debug = 0; my $qu; my $tid1; $tid1 = time; #if($HiRes) { $tid1 = [gettimeofday]; } my $host = ""; my $base = 'WS_Linux'; my @tables = ('os','navne'); my %colors = ( "table_bg" => "#ffffff", "table_header" => "#00c0c0", "page_bg" => "#FFFFFF", "page_text" => "#000000" ); my %name = %{&where()}; # # configuration end # ################################################################ # printed here and not at a later point for the benefit of the error-messages # print "Content-type: text/html\n\n"; print "\n"; print "\n \n ", $name{'project'}, " - ", $name{'page'}, "\n \n"; print " \n"; print " \n"; print "\n"; print "\n\n"; #print "\n\n"; print "\n"; print "\n \n\n"; print "
\"2penguins\"\n"; print "
\"The
\n"; print " Feauturing: A comparison between Operating Systems.

\n"; print " We are currently collecting information on AIX and several others, they will be included as soon as we have enough information.
"; print " "; print "
\n\n"; print "\n



\n\n"; print "\n\n \n
\n"; print " \n"; print " \n \n \n"; print " \n \n \n"; print "
$name{'page'}
Make a new Comparison
there\'s 13 OS\'s to choose from
\n"; print "
\n"; print "\n



\n\n"; # (7+7)*42 is max.length for the whole input # ^\w+$ is a regexp that only alloves alphanumaric characters and _ # # The K_CGI.pm gives us an error if the input data is longer than this, # or if the fields has caracters not meet by the reg-exp # # No spaces and no "strange" characters are allowed by the regexp, # so altering the sql-statements through carefully crafted input-strings # is not possible. # eval { my $r = Apache->request; my %ENV = $r->cgi_env; my @post_data = $r->content; #my %user_data = K_CGI::mod_perl_cleanup_with_checks((7+7)*42, '^\w+$', @post_data); my %user_data = $r->args; if(scalar keys %user_data < 1) { &error("Input Error!"); } # Figures out which information-areas and which os's # the user told it to include my (@os, @area); foreach(keys %user_data) { my $foo; #ain't exported so it's not an offense ;-) if(($foo) = ($_ =~ m/os_(.+)/)) { push @os, $foo; } if(($foo) = ($_ =~ m/area_(.+)/)) { push @area, $foo; } } unless((scalar @os > 0) && (scalar @area > 0)) { &error("Input Error!"); } # DB_connect_error's are numbers not explanations, so that we don't give more # than necessary information away. I know what they mean, and anyone with the sources # can find out in a couple of minutes. # my ($tid, $dbh, $q4, $sth, $sth1, @rows); $tid = time; #if($HiRes) { $tid = [gettimeofday] if($debug > 0); } unless($dbh = Mysql->connect($host)) { &error("DB_connect_error 0 : $!"); } unless($dbh->selectdb($base)) { &error("DB_connect_error 1 : $!"); } # a little statistics my $qs = "INSERT INTO stats (referer) VALUES (\'$ENV{'HTTP_REFERER'}\')"; unless($sth = $dbh->query($qs)) { &error("DB_insert_error 2 : $!"); } # leftmost column $q4 = "DESCRIBE $tables[0]"; unless($sth = $dbh->query($q4)) { &error("DB_connect_error 2 : $!"); } $qu++; my (@r, @a); while(@a = $sth->fetchrow) { my($h,$sh) = ($a[0] =~ m/(.+)_(.+)/); foreach(@area) { if($_ eq $h) { push @r, $a[0]; #break; next; } } } foreach(sort @r) { push @rows, $_; } undef @r; unshift @rows, 'name_os'; # for debugging if($debug > 1) { foreach(sort keys %user_data) { print "
[$_]\t[$user_data{$_}]
\n"; } } print "\n"; # Arranges the selected information-areas for the selected OS's. # The cryptic names are replaced with more verbose ones from # another table. # &main_3(\@rows, \@os, $dbh); $tid = time - $tid; #if($HiRes) { $tid = tv_interval ( $tid, [gettimeofday]); } print "
\n"; print "\n


\n\n"; my $q9 = "SELECT label FROM navne WHERE ident like \'meta_updated\'"; unless($sth1 = $dbh->query($q9)) { &error("DB_connect_error 4 : $!"); } $qu++; my $updated = $sth1->fetchrow; print "
\n"; print "\n"; print " \n \n \n"; print " \n"; print "\n \n\n"; #print "\n \n \n \n"; print "

\n"; print " \n\n"; print "
Make a new Comparison
there\'s 13 OS\'s to choose from

\n"; print "

\n"; print " The information in this chart are mostly from the OS and applications manufactors web-pages.\n"; print " The blank fields are areas where we haven\' yet found adequate verified information.
"; print "

\n

\n"; #print "

\n"; print " We appriciate updates, corrections and general information for this chart, "; print " especially if it is backed by URL\'s to \"official\" sites where it can be verified.
"; print " A big thank-you goes to all of you who have send us information.
Your help have"; print " made this chart much better than we could have made it ourself
\n"; print "

\n

\n"; #print "

\n"; print " Comments, corrections etc. can be e-mailed to "; print " Kristian Elof Sørensen"; print " at elof\@image.dk or entered below.\n"; print "

\n

\n"; #print "

\n"; print " Last updated on $updated
\n\n

<\/p>"; print "<\/td><\/tr>\n

\n"; #print "\n





\n\n"; print "\n \n\n"; &name_os('', \%ud, \%ms); } print "\n"; print " \n"; foreach(@{$ud{$_}}) { print " \n"; } print "\n"; } sub name_os { my %ud = %{$_[1]}; my %ms = %{$_[2]}; if($_[0] eq 'header') { print "\n \n"; } #else { print "\n"; } else { print ""; } foreach(@{$ud{'name_os'}}) { if($_[0] eq 'header') { print " \n"; } #else { print "\n"; } else { print "\n"; } } print "\n"; } } sub where { my %name; if($ENV{'SERVER_NAME'} eq "www.localdomain") { #www.localdomain use %name = ( "project" => "The Linux Resource Exchange", "page" => "Operating Systems comparison chart", "background" => "http://www.localdomain/~linuxrx/pics/bkgnd1.gif", "2penguins" => "http://www.localdomain/~linuxrx/pics/2penguins.gif", "linuxrx" => "http://www.localdomain/LinuxHQ/linuxrx.gif", "main-page" => "http://www.linuxrx.com/index.html", "select-page" => "http://www.localdomain/LinuxHQ/OS_comparison.html", "150_1" => "http://www.localdomain/LinuxHQ/150_1.gif", "100_1" => "http://www.localdomain/LinuxHQ/100_1.gif" ); } elsif($ENV{'SERVER_NAME'} eq "hugin.localdomain") { # hugin.localdomain use %name = ( "project" => "The Linux Resource Exchange", "page" => "Operating Systems comparison chart", "background" => "http://hugin.localdomain/linuxhq/pics/bkgnd1.gif", "2penguins" => "http://hugin.localdomain/linuxhq/pics/2penguins.gif", "linuxrx" => "http://hugin.localdomain/linuxhq/pics/linuxrx.gif", "main-page" => "http://www.linuxrx.com/index.html", "select-page" => "http://hugin.localdomain/Tests/mod_perl/OS_comparison.html", "150_1" => "http://hugin.localdomain/linuxhq/pics/150_1.gif", "100_1" => "http://hugin.localdomain/linuxhq/pics/100_1.gif" ); } else { %name = ( "project" => "The Linux Resource Exchange", "page" => "Operating Systems comparison chart", "background" => "http://www.linuxrx.com/pics/bkgnd1.gif", "2penguins" => "http://www.linuxrx.com/pics/2penguins.gif", "linuxrx" => "http://www.linuxrx.com/pics/linuxrx.gif", "main-page" => "http://www.linuxrx.com/index.html", "select-page" => "http://www.linuxrx.com/WS_Linux/OS_comparison.html", "150_1" => "http://www.linuxrx.com/WS_Linux/150_1.gif", "100_1" => "http://www.linuxrx.com/WS_Linux/100_1.gif" ); } return \%name; }
\n"; #print "\n





\n\n"; $tid1 = time - $tid1; #if($HiRes) { $tid1 = tv_interval ( $tid1, [gettimeofday]); } print "

Inderst $tid\n
Det hele $tid1\n

\n" if($debug > 0); print "

Querys $qu\n

\n" if($debug > 0); print "\n


" . Bazar->spyt_ud({"ID" => 'd10eeab13ed8bea664df8e9d1a8bc5e3'}) . "<\/p>\n"; print "<\/td><\/tr><\/table>"; print "<\/td><\/tr><\/table>"; print "\n\n\n\n"; }; &error($@) if($@); return 1; sub error { # error messages are printed in fire-engine red # print "\n"; print "

\n

\n"; print "\n
\n

\n

ERROR!

\n

\n"; print "\n

\n @_\n

\n"; unless($_[0] =~ m/^DB_connect_error/) { # A friendly error-message if it can be a user-error print "\n

\n Maybe you did not select at least one OS and one area of interest?\n

\n"; print "

Try again<\/A> <\/p><\/center>\n"; } print "\n

\n\n"; print "\n\n\n"; exit 1; } sub main_3 { my @rows = @{$_[0]}; my @os = @{$_[1]}; my $dbh = $_[2]; my $sth; my %linje; my %ud; my $o; my @linje; my $area; my $q = ""; my %ms; # This routine is building the body of the chart, and thus # doing most of the job. # # This version (Version 3) does only use 4 SQL queries # regardless of the dataset. The former version (Version 1) used # more queries and the number increased with the dataset. The # IPC overhead was tremendously even when using a Unix domain # socket. This version finishes in approx. 1/3 of the time of # version 1 not counting startup-time. That's measured on my # test server, not on www.cramer-ts.com. $q = "SELECT "; foreach(@rows) { $q .= "$_,"; } chop $q; $q .= " FROM $tables[0] WHERE "; foreach(@os) { $q .= "name_os = \'$_\' OR "; } chop $q; chop $q; chop $q; unless($sth = $dbh->query($q)) { &error("DB_connect_error 3 : $!"); } $qu++; while(%linje = $sth->fetchhash) { foreach(keys %linje) { my @l; @l = @{$ud{$_}} if(exists $ud{$_}); push @l, $linje{$_}; $ud{$_} = [@l]; } } unless($sth = $dbh->query("SELECT ident,label FROM $tables[1]")) { &error("DB_connect_error 4 : $!"); } $qu++; while(@linje = $sth->fetchrow) { $ms{$linje[0]} = $linje[1]; } &name_os('header', \%ud, \%ms); $area = ''; foreach(sort keys %ud) { next if($_ eq 'name_os'); my ($a) = ($_ =~ m/^(.+)_/); unless($area eq $a) { $area = $a; print "

$ms{$area}
$ms{$_}$_

$ms{'navn_' . lc $_}		$ms{'navn_' . lc $_}$ms{'navn_' . lc $_}