#!/usr/bin/perl $|++; # Turn off print buffering # print "Content-type: text/html\n\n"; # # Page # # # page.cgi -- main Edu_RSS management and administration function # More information: http://www.downes.ca/edurss02.htm # # by Stephen Downes # Version 0.2 - January 2, 2006 # # # Copyright 2006 Stephen Downes, National Research Council Canada # Prerelease - please do not distribute - I'll GPL it when it's ready # use CGI; use CGI::Carp qw(fatalsToBrowser); use XML::LibXML; use File::Copy; use SQL::Abstract; use XML::Atom::Client; use XML::Atom::Entry; use LWP; #use XML::RSS; use Net::OAI::Harvester; use Apache::DBI(); use GD; use Image::GD::Thumbnail; use strict; #require "edurss/harvester.pl"; # # page.cgi # # Copyright 2005 Stephen Downes, National Research Council Canada # Prerelease - please do not distribute - I'll GPL it when it's ready # # Draws on content in simple_RSS database and builds content pages # # Initialize Session --------------------------------------------------------------------------------------- my $query = new CGI; my $vars = $query->Vars; # Get Request variables and cookies unless ($vars->{db}) { if ($vars->{table}) { $vars->{db} = $vars->{table}; }} # makes old form requests compatible while (my ($vx,$vy) = each %$vars) { $vy =~ s/'/&apos/g; } # apostraphe-proofs system if ($ARGV[0]==1) { $vars->{action} = "harvest"; } # Allow cron to trigger harvest my $options = {}; bless $options; our $cache = {}; bless $cache; # cache frequently loaded content our $Site = {}; bless $Site; &get_site($Site,"/home/downess/opt-httpd-prefork-htdocs/cgi-bin/data/midm.conf"); # Get Site Information if ($ENV) { $Site->{script} = "http://" . $ENV{'SERVER_NAME'} . $ENV{'SCRIPT_NAME'}; } else { my $ENV = (); } $Site->{pubstatus} = $vars->{action}; #print "Content-type: text/html\n\n";while (my ($x,$y) = each %$Site) { print "$x = $y
"; } exit; &old_get_site($vars); if ($ENV) { $vars->{script} = "http://" . $ENV{'SERVER_NAME'} . $ENV{'SCRIPT_NAME'}; } # Open Database my $dbh = &db_open("DBI:mysql:$vars->{db_name}:$vars->{db_host}",$vars->{db_user},$vars->{db_pass}) or print "Database connect error: $!"; # Get User Information and verify Login my $person = &get_person($dbh,$query); # Initialize Page our $page = new Page; # Custom Pages if ($vars->{userpage} || $vars->{userrss}) { &custom_page($dbh,$vars); } # Actions --------------------------------------------------------------------------------------- $vars->{action} ||= ""; for ($vars->{action}) { /admin_main/ && do { &admin_main($dbh,$vars,$options,$person); last; }; /browse_menu/ && do { &browse_menu($dbh,$vars,$options,$person); last; }; /send_newsletter/ && do { &send_newsletter($dbh,$vars,$options,$person); last; }; /publish/ && do { &publish($dbh,$vars,$options,$person,$vars->{page}); last; }; /Delete/ && do { &delete_record($dbh,$vars,$options,$person); last; }; /Spam/ && do { &delete_record($dbh,$vars,$options,$person); last; }; /Preview/ && do { &submit_record($dbh,$vars,$options,$person,"Preview",$query); last; }; /Submit/ && do { &submit_record($dbh,$vars,$options,$person,"Submit",$query); last; }; /Update/ && do { &submit_record($dbh,$vars,$options,$person,"Update",$query); last; }; /create/ && do { &create_record($dbh,$vars); last; }; /build_gallery/ && do { require "edurss/gallery.pl"; &build_gallery($dbh,$vars->{gallery},$vars->{template}); last; }; /harvest/ && do { require "/home/downess/opt-httpd-prefork-htdocs/cgi-bin/edurss/harvester.pl"; &harvest($dbh,$vars,$options,$person); last; }; /harvall/ && do { require "/home/downess/opt-httpd-prefork-htdocs/cgi-bin/edurss/harvester.pl"; &harvest_all($dbh,$vars,$options,$person); last; }; /newqueue/ && do { require "edurss/harvester.pl"; &create_queue($dbh,$options,$vars,$person); last; }; /approve/ && do { require "edurss/harvester.pl"; &approve_feed($dbh,$options,$vars,$person); last; }; /retire/ && do { require "edurss/harvester.pl"; &retire_feed($dbh,$options,$vars,$person); last; }; /opmlopts/ && do { require "edurss/harvester.pl"; &opml_options($dbh,$options,$vars,$person); last; }; /harvopml/ && do { require "edurss/harvester.pl"; &upload_opml($dbh,$options,$vars,$person,$query); last; }; /mostcited/ && do { &most_cited($dbh,$options,$vars,$person); last; }; /conversation/ && do { &conversation($dbh,$vars,$options,$person); last; } } my $x = $vars->{format}; # Search --------------------------------------------------------------------------------------- if ($vars->{query}) { &search($dbh,$vars,$options,$person); } # Records --------------------------------------------------------------------------------------- $vars->{db} ||= ""; my $db = $vars->{db} || ""; my $id = $vars->{id} || ""; my $format = $vars->{format} || ""; my $number = $vars->{number} || 10; my $start = $vars->{start} || 0; my $default_sort; if ($vars->{db} =~ /view|journal|topic/) { $default_sort = "title"; } elsif ($vars->{db} =~ /person|author/) { $default_sort = "name"; } else { $default_sort = "crdate DESC"; } my $sort = $vars->{sort} || $default_sort; my $expires = $vars->{expires} || ""; my $heading = $vars->{heading} || ""; my $where = $vars->{where}||$vars->{q} || ""; my $all; if (defined($vars->{all})) { $all="all"; } else { $all=""; } for my $db_type ("page","author","journal","view","post","link","photo","person","event","feed","topic") { if ($vars->{$db_type}) { $db = $db_type; $id = $vars->{$db_type}; $number=1; } } if ($db eq "view") { $format ||= "edit"; } # Default Formats elsif ($db eq "post") { $format ||= "full"; } else { $format ||= "html"; } $page->{content} .= qq||; # Print Page ------------------------------------------------------------------------------------- &format_content($dbh,$vars,$options,$person,$page); print &header($dbh,$vars,$options,$person); print $page->{content}; print &footer($dbh,$vars,$options,$person); exit; #------------------------------------------------------------------------------- # # Data Input Functions # #--------------------------------------------------------------------------------- sub create_record { my ($dbh,$vars) = @_; print &header($dbh,$vars,$options,$person); my $view_title = $vars->{db}."_create"; my $view_text = &get_view($dbh,$view_title); my $vidf = '[*'.$vars->{db}.'_id*]'; $view_text =~ s/\Q$vidf\E/new/g; $view_text =~ s/\[\*(.*?)\*\]//g; # Not strictly necessary &pickup_vars($vars,\$view_text); &ldropdown(\$view_text); &dbdropdown($dbh,\$view_text); print $view_text; print &footer($dbh,$vars,$options,$person); exit; } sub validate_input { my ($vars) = @_; # Validate Content if ($vars->{db} eq "post") { $vars->{post_type} ||= "comment"; if ($vars->{post_type} eq "comment") { &error($dbh,$vars,$person,"Cannot submit a blank comment.") unless ($vars->{post_description}); &in_anti_spam($dbh,$vars); } if ($vars->{post_type} eq "link") { &error($dbh,$vars,$person,"Link must contain 'http'.") unless ($vars->{post_link} =~ /http/i); } } my $ipfield = $vars->{db}."_crip"; $vars->{$ipfield} = $ENV{'REMOTE_ADDR'}; } sub check_permissions { my ($dbh,$vars,$person,$idfield) = @_; unless ($vars->{$idfield} eq "new") { my $creator = &db_record_creator($dbh,$vars->{db},$vars->{$idfield}); unless (($person->{person_status} eq "admin") || ($person->{person_id} eq $creator)) { &error($dbh,$vars,$person,"You (do not have permission to edit this record."); exit; } } } sub submit_record { my ($dbh,$vars,$options,$person,$cmd,$query) = @_; # Create and Update New Content ---------------------------------------------------------------------------- if ($vars->{action} eq "Preview") { $vars->{next} = "preview"; } else { $vars->{next} = "view"; } my $idfield = $vars->{db}."_id"; &validate_input($vars); &check_permissions($dbh,$vars,$person,$idfield); # Manage Date-Time Stuff if ($vars->{$vars->{db}."_start"}) { if ($vars->{$vars->{db}."_start_time"}) { $vars->{$vars->{db}."_start"} .= " ".$vars->{$vars->{db}."_start_time"}.":00"; } else { $vars->{$vars->{db}."_start"} .= " 00:00:00"; } } if ($vars->{$vars->{db}."_end"}) { if ($vars->{$vars->{db}."_end_time"}) { $vars->{$vars->{db}."_end"} .= " ".$vars->{$vars->{db}."_end_time"}.":00"; } else { $vars->{$vars->{db}."_end"} .= " 23:59:59"; } } # File Upload my $ufilename = $query->upload('file'); # Detect uploaded file #my $ufilename = $query->param('file'); if ($ufilename) { if ($ufilename=~m/^.*(\\|\/)(.*)/) { $vars->{file_file} = $2; } else { $vars->{file_file} = $ufilename; } # Determine filename $vars->{file_title} = $vars->{file_file}; $vars->{file_type} = $query->uploadInfo($ufilename)->{'Content-Type'}; # Determine file type my $store_dir = &file_subdirectory($vars->{file_type},$vars->{file_gallery}); # Determine local directory unless (-d $Site->{st_base}.$store_dir) { mkdir($Site->{st_base}.$store_dir) || die "Cannot mkdir $Site->{st_base}.$store_dir: $!"; chmod 0766,$Site->{st_base}.$store_dir; } # make directory if necessary my $store_filename = $store_dir."/".$vars->{file_file}; $store_filename =~ s|//|/|g; # Build full store filename my $save_in = $Site->{st_base}.$store_filename; # Build absolute filename if(-e $save_in) { if ($vars->{force_replace}) { my ($new_store_file,$new_store_title) = &make_new_filename($vars->{file_file},$store_dir); my $stmt = qq|SELECT file_id FROM file WHERE file_file = ?|; my $sth = $dbh->prepare($stmt); $sth->execute($store_filename); my $ref = $sth -> fetchrow_hashref(); &db_update($dbh,"file",{file_file=>$new_store_file,file_title=>$new_store_title}, $ref->{file_id}); rename($save_in,$new_store_file) || &error($dbh,$vars,$person,"Cannot rename existing file. Oy Vey! $!"); } else { &error($dbh,$vars,$person,"File $save_in already exists; choose a new file name. " . "To replace this file, create ". "a new file and select the 'replace existing file' option."); } } &error($dbh,$vars,$person,"Base directory not defined in midm.conf") unless ($Site->{st_base}); open UPLOADFILE, ">$save_in" || die "Can't open: $!"; binmode UPLOADFILE; while ( <$ufilename> ) { print UPLOADFILE $_; } close UPLOADFILE; if (($vars->{$idfield} eq "") || ($vars->{$idfield} eq "new")) { $vars->{file_size} = -s $save_in; $vars->{file_file} = $store_filename; unless($vars->{file_size}) { &error($dbh,$vars,$person,"File upload to $store_filename failed; no record saved. $!"); } } } if ($vars->{post_type} eq "gallery") { $vars->{post_dir} = $vars->{post_title}; $vars->{post_dir} =~ s/[^a-zA-Z0-9 ]//g; $vars->{post_dir} =~ s/ /_/g; } $vars->{$idfield} = &in_save_record($dbh,$person,$options,$vars->{db},$vars); # Save Input Record # Create References (I wish I knew a shorter way of doing this) if ($vars->{db} eq "file") { if ($vars->{$idfield} && $vars->{file_post}) { &db_delete($dbh,"post_file","post_file_file",$vars->{$idfield}); my $post_file = { post_file_file => $vars->{$idfield}, post_file_post => $vars->{file_post} }; &in_save_record($dbh,$person,$options,"post_file",$post_file); } } if ($vars->{db} eq "post") { if ($vars->{post_event}) { &in_save_record($dbh,$person,$options,"event_post",{event_post_post => $vars->{$idfield}, event_post_event => $vars->{post_event}}); } if ($vars->{post_type} eq "link") { # Post - Link # Find Journal ID my $jid; if ($vars->{post_journal}) { # Journal? $jid = &in_find_by_val($dbh,$person,$options,"journal","title",$vars->{post_journal}); # by title... } elsif ($vars->{post_link}) { ($jid) = &in_find_by_sub_match($dbh,$person,$options,"journal","journal_link",$vars->{post_link}) # by link... } # Find Author ID my $aid; if ($vars->{post_author}) { # Author? $aid = &in_find_by_val($dbh,$person,$options,"author","name",$vars->{post_author}); # by name... } # Find Link ID my $lid; if ($vars->{post_link}) { # Author? $lid = &in_find_by_val($dbh,$person,$options,"link","link",$vars->{post_link}); # by link... } # Put Author and Journal ID in Post for lookups &in_save_record($dbh,$person,$options,"post",{post_id => $vars->{$idfield}, post_author_id => $aid, post_journal_id => $jid}); if ($lid) { # Save Link data my $linkdata = { link_id => $lid, link_title => $vars->{post_title}, link_link => $vars->{post_link}, link_crdate => time, link_creator => $person->{person_id}, link_journal => $jid }; &in_save_record($dbh,$person,$options,"link",$linkdata); # Save Reference &db_delete($dbh,"reference","reference_post",$vars->{$idfield}); my $reference = { reference_link => $lid, reference_post => $vars->{$idfield}, reference_type => "primary" }; &in_save_record($dbh,$person,$options,"reference",$reference); if ($aid) { # Save Link_Author &db_delete($dbh,"link_author","link_author_link",$lid); my $link_author = { link_author_link => $lid, link_author_author => $aid }; &in_save_record($dbh,$person,$options,"link_author",$link_author); } } } # Find Topics &db_delete($dbh,"post_topic","post_topic_post",$vars->{$idfield}); my $topic_match = $vars->{post_title} . " " . $vars->{post_description}; my @topics = &in_find_by_sub_match($dbh,$person,$options,"topic","topic_where",$topic_match); # by link... while (<@topics>) { my $idf = $vars->{$idfield}; my $post_topic = { post_topic_post => $idf, post_topic_topic => $_ }; &in_save_record($dbh,$person,$options,"post_topic",$post_topic); } } # If Topic, Reindex Topic if ($vars->{db} eq "topic") { &index_category($dbh,$options,"post",$vars->{$idfield}); } if (($vars->{db} eq "post") && ($vars->{post_type} eq "comment")) { if ($vars->{next} eq "preview") { $vars->{q} = "id=".$vars->{$idfield}; $vars->{format} = "preview"; } else { if ($vars->{post_thread}) { $dbh->do(qq{UPDATE post SET post_replies = post_replies + 1 WHERE post_id = $vars->{post_thread}}); # Increment replies ctr } $vars->{q} = "id=".$vars->{post_thread}; $vars->{format} = "full"; } } elsif ($vars->{db} eq "view") { $vars->{q} = "id=".$vars->{$idfield}; $vars->{format} = "edit"; } else { $vars->{q} = "id=".$vars->{$idfield}; $vars->{format} = "edit"; } if ($cmd eq "Update") { $vars->{format} = "edit"; } } sub make_new_filename { my ($file,$directory) = @_; my $ctr = 1; my $new_file = $file; while ($ctr < 1000) { if ($new_file =~ /\./) { $new_file =~ s/\./-$ctr\./; } else { $new_file .= "-$ctr"; } my $new_filename = $Site->{st_base}.$directory."/".$new_file; $new_filename =~ s|//|/|g; unless (-e $new_filename) { return ($new_filename,$new_file); } $ctr++; } &error($dbh,$vars,$person,"According to the system, you have a thousand versions of this file. Isn't that enough?"); exit; } sub file_subdirectory { my ($filetype,$subsub) = @_; if ($subsub) { $subsub .= "/"; } &error($dbh,$vars,$person,"File upload directory not defined in midm.conf") unless ($Site->{st_file}); if ($filetype =~ /text|msword|pdf/) { return $Site->{st_file}."/".$subsub."docs"; } elsif ($filetype =~ /audio|mpeg/) { return $Site->{st_file}."/".$subsub."audio"; } elsif ($filetype =~ /powerpoint/i) { return $Site->{st_file}."/".$subsub."slides"; } elsif ($filetype =~ /video/i) { return $Site->{st_file}."/".$subsub."video"; } elsif ($filetype =~ /image/i) { &error($dbh,$vars,$person,"Photo upload directory not defined in midm.conf") unless ($Site->{st_photo});return $Site->{st_photo}."/".$subsub; } &error($dbh,$vars,$person,"This type of file - $filetype - is not permitted for upload."); exit; } sub delete_record { my ($dbh,$vars,$options,$person) = @_; &error($dbh,$vars,$person,"Action not permitted") unless ($person->{person_mode} eq "admin"); if ($vars->{action} eq "Spam") { my $bs=(); $bs->{banned_sites_ip} = &db_record_crip($dbh,$vars->{db},$vars->{id}); &in_save_record($dbh,$person,$options,"banned_sites",$bs); # Save Input Record } &db_delete($dbh,$vars->{db},$vars->{db}."_id",$vars->{id}); $page->{format} = "text/html"; $page->{content} = "Record Deleted"; $page->print(); exit; } sub in_save_record { my $dbh = shift || die "Database not initialized in save record"; my $person = shift || die "Person not specified in save record"; my $options = shift || die "Options not specified in save record"; my $table = shift || die "Table not specified in save record"; my $vars = shift || die "No input content in save record"; die "Unsupported data type specified to save record" unless (ref $vars eq 'HASH' || ref $vars eq 'Link' || ref $vars eq 'Feed'); # ID Field my $idfield = $table."_id"; $vars->{$idfield} = $vars->{$idfield} || $vars->{id} || "new"; # Save Input Record if ($vars->{$idfield} eq "new") { # Create $vars->{$vars->{db}."_crdate"} = time; $vars->{$vars->{db}."_creator"} = $person->{person_id}; $vars->{$idfield} = &db_insert($dbh,$table,$vars); $options->{msg} .= "Created new $table ($vars->{$idfield})
"; } else { # Update my $where = { $idfield => $vars->{$idfield}}; $vars->{$idfield} = &db_update($dbh,$table, $vars, $vars->{$idfield}); $options->{msg} .= ucfirst($table)." $vars->{$idfield} successfully updated
"; } return $vars->{$idfield}; } sub in_find_by_val { my ($dbh,$person,$options,$table,$field,$val) = @_; die "Need to specify table, field and value in find by..." unless (($table) && ($field) && ($val)); my $id = db_record_list($dbh,$table,$table."_".$field,"=",$val,"1"); unless ($id) { $id = &in_save_record($dbh,$person,$options,$table,{$table."_".$field => $val}); # Create } return $id; } sub in_find_by_sub_match { # Given data, tries to find the field value via regex in Table # Pretty ugly, don't use unless needed my ($dbh,$person,$options,$table,$field,$match) = @_; return unless (($field) && ($match)); my $tid = $table."_id"; my @return; my $sth = $dbh->prepare("SELECT $tid,$field FROM $table"); $sth->execute(); while (my $ref = $sth -> fetchrow_hashref()) { next unless ($ref->{$field}); if ($match =~ $ref->{$field}) { push @return,$ref->{$tid}; } } return @return; } sub in_anti_spam { # Checks input for spam content and kills on contact my $dbh = shift; my $vars = shift; # No Links if ($vars->{post_description} =~ //i) { die "Comment rejected."; } # Filter by Content if (($vars->{post_description} =~ /(You are invited|pharmacy|poker|holdem|casino|roulette|phentermine|diet| pills| loans)/i) || ($vars->{post_title} =~ /(You are invited|pharmacy|poker|holdem|casino|roulette|phentermine|diet| pills| loans)/i)) { open SPAMLOG,">>spamlog.txt"; print SPAMLOG "Spamming attempt: $vars->{post_description}\n"; close SPAMLOG; &error($dbh,$vars,$person,"Your submission has been classified as spam and has been rejected."); } # Filter by IP my @ipl = split /\./,$ENV{'REMOTE_ADDR'}; pop @ipl; my $ip = join '.',@ipl; my $sth = $dbh->prepare("SELECT * FROM banned_sites WHERE banned_sites_ip REGEXP ?"); $sth->execute($ip); my $ref = $sth -> fetchrow_hashref(); &error($dbh,$vars,$person,"Your submission has been classified as spam and has been rejected.") if ($ref); } #------------------------------------------------------------------------------- # # Page Printing Functions # #--------------------------------------------------------------------------------- sub template { # Get Template my ($dbh,$title,$options,$person,$pagetitle) = @_; my $stmt = qq|SELECT * FROM template WHERE template_title = ?|; my $sth = $dbh -> prepare($stmt); $sth -> execute($title); $options->{execute}++; my $ref = $sth -> fetchrow_hashref(); my $templ = $ref->{template_description}; # Format Template $page->{title} ||= ""; $pagetitle ||= $page->{title}; $templ =~ s//$pagetitle/g; &autodates(\$templ); &login_options(\$templ); &clean_up(\$templ); return $templ; } sub header { my ($dbh,$vars,$options,$person,$format,$title) = @_; $vars->{format} ||= ""; $format ||= $vars->{format}; if ($format eq "rss") { return "Content-type:text/xml\n\n".&template($dbh,"RSS02_top",$options,$person,$title); } # Rss / XML elsif ($format eq "js") { return "Content-type:text/javascript\n\nfunction jview() {\n"; } # Javascript else { return "Content-type:text/html\n\n".&template($dbh,"top",$options,$person,$title); } # HTML } sub footer { my ($dbh,$vars,$options,$person,$format) = @_; $format ||= $vars->{format}; if ($format eq "rss") { return &template($dbh,"RSS02_bottom");; } # RSS elsif ($format eq "js") { return qq|\n}\njview();\n|; } # Javascript elsif ($format eq "htmprint") { return qq||.&template($dbh,"left",$options,$person).qq||; } # Printed HTML else { # HTML my $ret = qq||; if (($person->{person_mode} eq "admin")) { $ret .= &admin_nav($dbh); } else { $ret .= &template($dbh,"left",$options,$person); } $ret .= qq||; return $ret; } } sub messages { if ($options->{msg}) { return qq|
$options->{msg}
|; } } sub format_content { my ($dbh,$vars,$options,$person,$page) = @_; &make_boxes($dbh,\$page->{content}); &make_keywords($dbh,\$page->{content},$person); } sub make_boxes { my ($dbh,$input) = @_; my @boxlist; while ($$input =~ //sig) { my $autotext = $1; die "Cannot use the same box twice, to avoid recursion." unless (&index_of($autotext,\@boxlist) == -1); push @boxlist,$autotext; my $sql = "SELECT box_content FROM box WHERE box_title = ? LIMIT 1"; my $sth = $dbh -> prepare($sql); $sth -> execute($autotext); my $box_record = $sth -> fetchrow_hashref(); $box_record->{box_content} ||= "Content for box $autotext not found"; $$input =~ s//$box_record->{box_content}/; } } sub make_keywords { #print "Content-type: text/html\n\n"; my ($dbh,$text_ptr,$person) = @_; my $escape_hatch=0; while ($$text_ptr =~ //ig) { my $autocontent = $1; my $replace = ""; $escape_hatch++; die "Endless keyword loop" if ($escape_hatch > 1000); # No endless loops, d'uh my $script = {}; &parse_keystring($script,$autocontent); return unless ($script->{db}); my $where = &make_where($script); unless ($script->{all} eq "yes") { unless ($where) { $$text_ptr =~ s/\Q\E//; next;} } unless ($script->{format} =~ /options|list/) { $script->{number} ||= 50; } my $limit; if ($script->{number}) { $limit = " LIMIT $script->{number}"; } my $order; if ($script->{sort}) { $order = " ORDER BY $script->{db}_$script->{sort}"; } # Get the count my $sqlc = "SELECT COUNT(*) AS items FROM $script->{db} $where"; my $sthc = $dbh -> prepare($sqlc); $sthc -> execute(); my $refc = $sthc -> fetchrow_hashref(); my $count = $refc->{items}; my $sql = "SELECT * FROM $script->{db} $where$order$limit"; #print "$sql
\n"; my $sth = $dbh -> prepare($sql); $sth -> execute(); my $results_count=0; while (my $record = $sth -> fetchrow_hashref()) { $results_count++; if ($script->{number} eq "1") { $page->{title} = $record->{$db."_title"}; } $replace .= &format_record($dbh,$vars,$options,$person,$script->{db},$script->{format},$record); } if ($replace) { $replace = &make_heading($script).$replace; } if (($count > $script->{number}) && ($script->{number} > 1)) { $script->{start} = $script->{number}++; undef $script->{number}; if ($script->{format} eq "brief") { $script->{format} = "list"; } unless ($script->{format} =~ /options|list|rss|xml|js|opml/) { $replace .= &more_results_button($script,"0",$where); } } &make_boxes($dbh,\$replace); if ($replace) { my $tmp; if ($script->{wrap}) { $tmp = $replace; $replace=$script->{wrap}; $replace =~ s/CONTENT/$tmp/g; } } else { $replace = $script->{none}; } $$text_ptr =~ s/\Q\E/$replace/; } } # Parses keyword string and fills script command hash sub parse_keystring { my ($script,$keystring) = @_; foreach (split /;/,$keystring) { my ($cx,$cy) = split /=/,$_; if ($cx eq "all") { $cy = "yes"; } $script->{$cx} = $cy; } $script->{all} ||= "off"; } sub make_where { my ($script) = @_; my @where_list; unless ($script->{id}) { undef $script->{id}; } if ($script->{lookup}) { my $ret = "(".&make_lookup($script).")"; push @where_list,$ret;} my $expires; if ($script->{expires}) { my $extime = time - ($script->{expires}*3600); $expires = $script->{db}."_crdate > ".$extime; push @where_list,$expires; } while (my($cx,$cy) = each %$script) { next if ($cx =~ /number|expires|heading|format|db|dbs|sort|start|next|all|none|wrap/); my $flds; my $tval; my @fid_list; if ($cx =~ '~') { # contains ($flds,$tval) = split "~",$cx; my @matchlist = split ",",$flds; foreach my $ml (@matchlist) { push @fid_list,$script->{db}."_".$ml." REGEXP '".$tval."'"; } } elsif ($cx =~ 'GT') { # greater than ($flds,$tval) = split "GT",$cx; my @matchlist = split ",",$flds; foreach my $ml (@matchlist) { push @fid_list, $script->{db}."_".$ml." > '".$tval."'"; } } elsif (defined($cy)) { # equals push @where_list, $script->{db}."_".$cx." = '".$cy."'"; } my $fwhere = join " OR ",@fid_list; if ($fwhere) { push @where_list,"(".$fwhere.")"; } } my $where = join " AND ",@where_list; if ($where) { $where = " WHERE $where"; } return $where; } sub make_lookup { my ($script) = @_; my $str=""; my ($look,$as) = split / as /,$script->{lookup}; my ($lf,$ll) = split / in /,$look; my $lv = $script->{$lf}; my $asitem = $as || $script->{db}; my $ret = $ll."_".$asitem; die "Lookup command badly formed: $ll && $lf && $lv && $script->{db}" unless ($ll && $lf && $lv && $script->{db}); my $stmt = "SELECT $ret FROM $ll WHERE ".$ll."_".$lf." = ?"; #print "Content-type: text/html\n\n$stmt -- $lv
"; my $sth = $dbh->prepare($stmt); $sth->execute($lv); while (my $ref = $sth -> fetchrow_hashref()) { if ($str) { $str .= " OR "; } $str .= $script->{db}."_id = '".$ref->{$ret}."'"; } undef $script->{lookup}; undef $script->{$lf}; if ($str) { return $str; } } sub make_heading { my ($script) = @_; return unless ($script->{heading}); my $heading = ""; if ($script->{format} =~ /txt/) { $heading = "\n\n$script->{heading}\n\n"; } else { $heading = "

$script->{heading}

\n"; } return $heading; } sub make_next_link { my ($dbh,$vars,$options,$person,$script) = @_; my @optlist; my $optstring; while (my($ox,$oy) = each %$script) { push @optlist,"$ox=$oy"; } $optstring = join ";",@optlist; return "http://www.downes.ca/cgi-bin/page.cgi?".$optstring; } sub new_format_record { my ($dbh,$vars,$options,$person,$table,$filldata,$format) = @_; return unless ($filldata); $format ||= "html"; if ($filldata->{$table."_type"}) { $format = $filldata->{$table."_type"}."_".$format; } $format = $table."_".$format; my $view_text = &get_view($dbh,$format); #if ($filldata->{$table."_type"}) { $format = $format || $filldata->{$table."_type"}."_html"; } #else { $format = $format || "html"; } #my $view_title = $table."_".$format; #my $view_text = &get_view($dbh,$view_title); # Get a list of eligible data elements my @data_elements = (); while ($view_text =~ /\[\*(.*?)\*\]/) { my $de = $1; push @data_elements,$de; $view_text =~ s/\[\*(.*?)\*\]/BEGDE $de ENDDE/si; } # Fill from each data hash in order foreach my $data_element (@data_elements) { if ($format eq "edit") { &mask_formatting(\$filldata->{$data_element}); } $view_text =~ s/BEGDE $data_element ENDDE/$filldata->{$data_element}/mig; } &pickup_vars($vars,\$view_text); &ldropdown(\$view_text); &dbdropdown($dbh,\$view_text); &autodates(\$view_text); &popupdate(\$view_text); &hourdate(\$view_text); &daterange(\$view_text); &autoformat(\$view_text); &login_options(\$view_text); &autocats($dbh,\$view_text,$table); &admin_links($vars,$person,$table,$filldata,\$view_text); &clean_up(\$view_text,$format); return $view_text; } sub format_record { my ($dbh,$vars,$options,$person,$table,$format,$filldata) = @_; # Load the record template (aka 'view') from DB if ($filldata->{$table."_type"}) { $format = $format || $filldata->{$table."_type"}."_html"; } else { $format = $format || "html"; } my $dsrc; my @filllist;while (@_) { $dsrc = shift;push @filllist,$dsrc; } my $view_title = $table."_".$format; my $view_text = &get_view($dbh,$view_title); # Get a list of eligible data elements my @data_elements = (); while ($view_text =~ /\[\*(.*?)\*\]/) { my $de = $1; push @data_elements,$de; $view_text =~ s/\[\*(.*?)\*\]/BEGDE $de ENDDE/si; } # Special for feeds if ($table eq "feed") { if ($filldata->{feed_status} eq "A") { $filldata->{feed_command} = qq|[Retire]|; } elsif ($filldata->{feed_status} eq "R") { $filldata->{feed_command} = qq|[Approve]|; } else { $filldata->{feed_command} = qq|[Approve]|; } } # Fill from each data hash in order foreach my $data_element (@data_elements) { if ($format eq "edit") { &mask_formatting(\$filldata->{$data_element}); } $view_text =~ s/BEGDE $data_element ENDDE/$filldata->{$data_element}/mig; } &pickup_vars($vars,\$view_text); &ldropdown(\$view_text); &dbdropdown($dbh,\$view_text); &autocats($dbh,\$view_text,$table); &autodates(\$view_text); &popupdate(\$view_text); &hourdate(\$view_text); &daterange(\$view_text); &autoformat(\$view_text); &login_options(\$view_text); &admin_links($vars,$person,$table,$filldata,\$view_text); &clean_up(\$view_text,$format); return $view_text; } #------------------------------------------------------------------------------- # # Search # #--------------------------------------------------------------------------------- sub search { my ($dbh,$vars,$options,$person) = @_; $page->{title} = "Search ".ucfirst($vars->{db})."s: ".$vars->{q}; my $prefix = $vars->{db}."_"; $vars->{format} ||= "html"; print &header($dbh,$vars,$options,$person); # Compile SQL 'Where' Statement my $where = &db_where($dbh,$vars,$prefix); $vars->{sort} ||= $prefix."crdate DESC";$vars->{start} ||= 0;$vars->{number} ||= 50; # Print HTML page header info my $count; my $start; my $end; my $number; if (($vars->{format} eq "html")||($vars->{format} eq "list")) { # Count Results my $count_sql = &db_sql($vars->{db},"count",$where); my $csth = $dbh->prepare($count_sql) or die "could not prepare statement!\n"; $csth->execute(); my $cresult = $csth -> fetchrow_hashref(); $count = $cresult->{count}; $start = $vars->{start} + 1; $number = $vars->{number}; $end = $vars->{start} + $number; if ($end > $count) { $end = $count; } print "

Search Results

"; if ($vars->{rssfeed}) { unless ($vars->{format} =~ /rss/) { print qq|

RSS Feed for this Page

|; } } if ($count) { print "

Printing $start to $end out of $count records found.

"; } else { print "

No records found. I feel your pain.

"; } } # Get Results my $tsql = &db_sql($vars->{db},"search",$where); unless ($vars->{sort} =~ /_/) { $vars->{sort} = $prefix.$vars->{sort}; } $tsql .= " ORDER BY $vars->{sort} LIMIT $vars->{start},$vars->{number}"; if ($vars->{show_sql}) { print qq{
}.$tsql.qq{
}; } my $tsth = $dbh->prepare($tsql) or die "couldn't prepare statement!\n"; $tsth->execute(); while (my $tresult = $tsth -> fetchrow_hashref()) { my $res = &new_format_record($dbh,$vars,$options,$person,$vars->{db},$tresult,$vars->{format}); &make_keywords($dbh,\$res,$person); print $res; } # Print 'More Results' Buttom if (($vars->{format} eq "html")||($vars->{format} eq "list")) { if ($count > $end) { print &more_results_button($vars,$number,$vars->{where}); } } print &footer($dbh,$vars,$options,$person); exit; } sub more_results_button { my ($vars,$number,$where) = @_; my $whline; if ($where) { $where =~ s/\s*WHERE\s*//; $whline = qq{}; } my $button_title = $vars->{where} || $where; $button_title =~ s/"/'/g; $button_title =~ s/post_type = '(.*?)'/$1/i; $button_title ||= $vars->{db}; $button_title.="s"; my $next = $vars->{start} + $number; $number ||= 50; my @types = split /\0/,$vars->{post_type}; my $typesl; while (<@types>) { $typesl .= qq{\n}; } my @topics = split /\0/,$vars->{topic}; my $topicsl; while (<@topics>) { $topicsl .= qq{\n}; } return qq|

$whline $typesl $topicsl

|; } #------------------------------------------------------------------------------- # # Custom Page # #--------------------------------------------------------------------------------- sub custom_page { my ($dbh,$vars) = @_; my $cf;my $p; if ($vars->{userpage}) { $cf = "htm"; $p = $vars->{userpage};} elsif ($vars->{userrss}) { $cf = "rss"; $p = $vars->{userrss}; } my $pagetitle = $p."'s Custom Feed"; my $stmt = "SELECT custom_content FROM custom WHERE custom_format = '$cf' AND custom_person = '$p'"; my $sth = $dbh->prepare($stmt); $sth->execute(); my $output = $sth -> fetchrow_hashref(); unless ($output->{custom_content}) { # Ack, content doesn't exist # Does this user exist? my $astmt = "SELECT person_id,person_title FROM person WHERE person_title = ? LIMIT 1"; my $asth = $dbh->prepare($astmt); $asth->execute($p); my $aout = $asth -> fetchrow_hashref(); unless ($aout->{person_id}) { &error($dbh,$vars,$person,"$p is not a registered person here."); } # Does the user have any subscriptions? # Does this user exist? my $stmtb = "SELECT subscription_id FROM subscription WHERE subscription_person = ? LIMIT 1"; my $sthb = $dbh->prepare($stmtb); $sthb->execute($aout->{person_id}); my $bout = $sthb -> fetchrow_hashref(); unless ($bout->{subscription_id}) { &error($dbh,$vars,$person,"$p has not defined a custom page."); } # OK, we will build it on the fly, just this once # Create Today's CSS my $boxes = {}; my $btitles={}; my $txt_boxes = {}; my $rss_boxes ={}; # Arrays to store box contents, titles, id of text alternates &make_box_contents($dbh,$vars,$options,$person,$boxes,$btitles,$txt_boxes,$rss_boxes); my ($custom_html,$custom_rss,$custom_txt,$subject_line) = &make_custom_content($dbh,$aout->{person_id},$boxes,$rss_boxes,$txt_boxes,$btitles); &save_custom_content($dbh,$vars,$options,$person,$aout->{person_title},$custom_html,$custom_rss,$pagetitle); # Save Custom Contents # Now we'll try retrieving it, a bit redundant, but... my $cf;my $p; if ($vars->{userpage}) { $cf = "htm"; $p = $vars->{userpage};} elsif ($vars->{userrss}) { $cf = "rss"; $p = $vars->{userrss}; } my $cstmt = "SELECT custom_content FROM custom WHERE custom_format = '$cf' AND custom_person = '$p'"; my $csth = $dbh->prepare($cstmt); $csth->execute(); $output = $csth -> fetchrow_hashref(); } unless ($output->{custom_content}) { &error($dbh,$vars,$person,"Couldn't find any custom content for $p."); } print $output->{custom_content}; exit; } sub make_thumbnail { my ($srcImage,$size,$photo_file) = @_; my $gt; my ($thumb,$x,$y) = Image::GD::Thumbnail::create($srcImage,$size); $photo_file =~ s/\./_$size\./; my $save_file = $Site->{st_base}.$photo_file; open OUT, ">$save_file" or die "Could not save $save_file $!"; binmode OUT; print OUT $thumb->jpeg or die "Could not print $save_file $!"; close OUT; if ($x > $y ) { $gt = $Site->{st_url}.$photo_file; } return ($photo_file,$gt); } #-------------------------------------------------------- # # Page Formatting Functions # #-------------------------------------------------------- sub admin_links { my ($vars,$person,$table,$filldata,$text_ptr) = @_; my $edit_link; my $delete_link; my $spam_link; if ($person->{person_mode} eq "admin") { unless ($Site->{pubstatus} eq "publish") { $edit_link = qq|[Edit]|; $delete_link = qq|[Delete]|; $spam_link = qq|[Spam]|; }} $$text_ptr =~ s//$edit_link/g; $$text_ptr =~ s//$delete_link/g; $$text_ptr =~ s//$spam_link/g; } sub ldropdown { # Inserts dropdown selection from list my ($text_ptr) = @_; my $ctr=0; while ($$text_ptr =~ /(.*?)/) { my $autotext = $1; my $l = $autotext; $ctr++; die "Endless loop in ldropdown()" if ($ctr > 100); my @list = split /,/,$l; # accepts comma delimited list my $vname = shift @list; # first item is name of the variable my $current = shift @list; # second item is the current value my $replace = qq|\n"; $$text_ptr =~ s/\Q$autotext\E/$replace/sig; } } sub dbdropdown { # Inserts dropdown selection from list my ($dbh,$text_ptr) = @_; my $ctr=0; while ($$text_ptr =~ /(.*?)/) { my $autotext = $1; my $l = $autotext; $ctr++; die "Endless loop in dbdropdown()" if ($ctr > 100); my @list = split /,/,$l; # accepts comma delimited list my $vname = shift @list; # first item is name of the variable my $current = shift @list; # second item is the current value my $fdb = shift @list; # third item is the db table where choices are found my $fval = shift @list; # fourth item is the db value to select, match my $fdis = shift @list; # fifth item is the db value to display my $fcon = shift @list; # optional sixth item is the table to search on (eg 'type') my $fconv = shift @list; # optional seventh item is the value to search for (eg 'gallery') my $where; if ($fcon && $fconv) { $where = " WHERE $fcon = '$fconv'"; } else { $where = ""; } my $replace = qq|\n"; $$text_ptr =~ s/\Q$autotext\E/$replace/sig; } } sub pickup_vars { # Inserts CGI variables into text my ($vars,$text_ptr) = @_; return if ($vars->{view} eq "127"); # Ugly ugly ugly my $count=0; while ($$text_ptr =~ /(.*?)/) { my $autotext = $1; my $replace = $vars->{$autotext}; $$text_ptr =~ s/$autotext/$replace/sig; $count++; die "endless loop" if ($count>100); } return; } sub login_options { my ($text_ptr) = @_; my $current_url = $Site->{script}; my $refer; if ($ENV{'QUERY_STRING'}) { $refer = $current_url."?".$ENV{'QUERY_STRING'}; } else { $refer = $current_url; } $refer =~ s/\Q&\E/AND/g; my $login_url = $Site->{st_login}; my $register_url = $Site->{st_login} . "action=Register"; my $logout_url = $Site->{st_login} . "action=Logout"; my $admin_url = $current_url."?action=admin_menu&refer=$refer"; my $browse_url = $current_url."?action=browse_menu&refer=$refer"; my $pid = $person->{person_title} || $person->{person_name}; my $output = ""; if (($person->{person_id} eq "") || ($person->{person_id} eq "2")) { $output .= qq|You are not logged in. [Login][Register]|; } else { $output .= qq|Logged in as $pid |; if ($person->{person_status} eq "admin") { if ($person->{person_mode} eq "admin") { $output .= qq{[Browse]}; } else { $output .= qq{[Admin]}; } } $output .= qq{[Logout]}; } while ($$text_ptr =~ //sg) { $$text_ptr =~ s//$output/sig; } return; } sub autocats { # Insert tag list my ($dbh,$text_ptr,$table) = @_; while ($$text_ptr =~ /(.*?)/) { my $id = $1; my @ret; my $lookup = $table."_topic"; my $lookupel = $lookup.".".$lookup . "_" . $table; my $lookuptp = $lookup.".".$lookup . "_topic"; my $tid = $table.".".$table."_id"; my $stmt = qq|select distinct topic.topic_id, topic.topic_title from topic |. qq|left join $lookup on $lookuptp = topic.topic_id where $lookupel = '$id'|; my $sth = $dbh->prepare($stmt); $sth->execute(); while (my $ref = $sth -> fetchrow_hashref()) { my $str = qq|$ref->{topic_title}|; push @ret,$str; } my $insert = join ", ",@ret; my $replace = "[Tags: $insert]"; $$text_ptr =~ s/$id/$replace/sig; } } sub autodates { # Insert nice dates my ($text_ptr) = @_; for my $date_type ("NICE_DATE","822_DATE","MON_DATE") { my $date_type_end = "END_".$date_type; while ($$text_ptr =~ /<$date_type>(.*?)<$date_type_end>/sg) { my $autotext = $1; my $otime; my $replace; if ($autotext eq "NOW") { $otime = time; } else { $otime = $autotext; } if ($date_type =~ /822/) { $replace = &rfc822_date($otime); } elsif ($date_type =~ /MON/) { $replace = &nice_date($otime,"month"); } else { $replace = &nice_date($otime); } $$text_ptr =~ s/<$date_type>\Q$autotext\E<$date_type_end>/$replace/sig; } } } sub popupdate { my ($text_ptr) = @_; while ($$text_ptr =~ /(.*?)/sg) { my $autotext = $1; my ($date,$hour) = split / /,$autotext; $$text_ptr =~ s/\Q$autotext\E/$date/sig; } } sub hourdate { my ($text_ptr) = @_; while ($$text_ptr =~ /(.*?)/sg) { my $autotext = $1; my ($date,$hour) = split / /,$autotext; my ($h,$m,$s) = split /:/,$hour; $hour = "$h:$m"; $$text_ptr =~ s/\Q$autotext\E/$hour/sig; } } sub daterange { my ($text_ptr) = @_; while ($$text_ptr =~ /(.*?)/sg) { my $autotext = $1; my ($start,$end) = split /,/,$autotext; my ($startdate,$starthour) = split / /,$start; my ($enddate,$endhour) = split / /,$end; my ($startyear,$startmonth,$startday) = split /-/,$startdate; my ($endyear,$endmonth,$endday) = split /-/,$enddate; my @months = ('January','February','March','April','May', 'June','July','August','September','October','November','December'); my $mn = $startmonth-1; $startmonth = $months[$mn]; $mn = $endmonth-1; $endmonth = $months[$mn]; my $replace; if ($startyear eq $endyear) { if ($startmonth eq $endmonth) { if ($startday eq $endday) { $replace = "$startmonth $startday, $startyear"; } else { $replace = "$startmonth $startday-$endday, $startyear"; } } else { $replace = "$startmonth $startday - $endmonth $endday, $startyear"; } } else { $replace = "$startmonth $startday, $startyear - $endmonth $endday, $endyear"; } $$text_ptr =~ s/\Q$autotext\E/$replace/sig; } } sub autoformat { # Nice formatting for unformatted text my ($text_ptr) = @_; while ($$text_ptr =~ /(.*?)/sg) { my $autotext = $1; my $replace = $autotext; $replace =~ s/\n/
/mig; $replace =~ s/

//mig; $replace =~ s/<\/p>//mig; $$text_ptr =~ s/\Q$autotext\E/$replace/sg; } return; } sub clean_up { # Misc. clean-up for print my ($text_ptr,$format) = @_; $format ||= ""; $$text_ptr =~ s/BEGDE(.*?)ENDDE//mig; # Kill unfilled data elements $$text_ptr =~ s/(.*?)<\/a>/$1/mig; # Kill blank URLs $$text_ptr =~ s///mig; # Kill blank img $$text_ptr =~ s/1 Replies/1 Reply/mig; # Depluralize replies $$text_ptr =~ s/0 Reply/0 Replies/mig; $$text_ptr =~ s/"/"/mig; # Replace quotes $$text_ptr =~ s/&#(.*?);/&#$1;/mig; # Fix broken special chars $$text_ptr =~ s/“/"/mig; $$text_ptr =~ s/”/"/mig; $$text_ptr =~ s/'/'/mig; return; } sub mask_formatting { # Masks formatting commands to prevent processing, used in edit window my ($text_ptr) = @_; for my $formatting ("keyword","NICE_DATE","822_DATE","MON_DATE","LOGIN_OPTIONS","PAGE_TITLE","TOPIC", "LDROP","DBDROP","EDIT","DELETE","SPAM","HOURDATE","POPUPDATE","DATERANGE") { my $formatting_end = "END_".$formatting; $$text_ptr =~ s/<$formatting>/<$formatting>/mig; $$text_ptr =~ s/<$formatting_end>/<$formatting_end>/mig; } $$text_ptr =~ s//<keyword$1>/mig; $$text_ptr =~ s//<textarea$1>/mig; $$text_ptr =~ s/<\/textarea>/<\/textarea>/mig; $$text_ptr =~ s//<box$1>/mig; return; } #-------------------------------------------------------- # # Record Formatting Functions # #-------------------------------------------------------- sub get_view { my ($dbh,$view_title) = @_; my $viewcache = "view_".$view_title; return $cache->{$viewcache} if (defined $cache->{$viewcache}); # Never get the same view twice my $stmt = qq|SELECT view_text FROM view WHERE view_title=? LIMIT 1|; my $sth = $dbh->prepare($stmt); $sth->execute($view_title); my $view_record = $sth -> fetchrow_hashref(); $cache->{$viewcache} = $view_record->{view_text}; return $cache->{$viewcache} || "

Cannot find view: $view_title

"; } #-------------------------------------------------------- # # Misc. Pages # #-------------------------------------------------------- sub most_cited { my ($dbh,$vars,$options,$person) = @_; print &header($dbh,$vars,$options,$person); print "

Most Cited Links

"; # Get Cites my $cites=(); my $stmt = qq|SELECT cite_cited FROM cite|; my $sth = $dbh->prepare($stmt); $sth->execute(); while (my $ref = $sth -> fetchrow_hashref()) { if ($cites->{$ref->{cite_cited}}) { $cites->{$ref->{cite_cited}}++; } else { $cites->{$ref->{cite_cited}} = 1; } } # Get Current Link Cites my $lcites=(); my $lstmt = qq|SELECT link_id,link_cites FROM link|; my $lsth = $dbh->prepare($lstmt); $lsth->execute(); while (my $lref = $lsth -> fetchrow_hashref()) { $lcites->{$lref->{link_id}} = $lref->{link_cites}; } my @sorted = sort { $cites->{$b} cmp $cites->{$a} } keys %$cites; #my @sorted = keys %$cites; my $text = ""; my $count = 0; foreach my $l (@sorted) { my $stmt = "SELECT * FROM link WHERE link_id = '$l' LIMIT 1"; my $sth = $dbh->prepare($stmt); $sth->execute(); my $li = $sth -> fetchrow_hashref(); unless ($count > 10) { $text .= &format_record($dbh,$vars,$options,$person,"link","html",$li); } # only print 10 $count++; #last if ($count > 100); #print "Link: $l Cites: ",$cites->{$l}," Recorded Cites: ",$lcites->{$l},"
"; unless ($cites->{$l} eq $lcites->{$l}) { &db_update($dbh,"link",{link_cites=> $cites->{$l}},$l); print "Updating $l
"; } } print $text; print &footer($dbh,$vars,$options,$person); exit; } sub conversation { my ($dbh,$vars,$options,$person) = @_; print &header($dbh,$vars,$options,$person); print "

Conversation

"; print "conversation"; my $baselink = $vars->{link}; print "Base: $baselink
"; my $linklist = []; &get_cited($dbh,$vars,$options,$person,$baselink,$linklist); # Up if (&index_of($baselink,$linklist) == -1) { my $stmt = "SELECT * FROM link WHERE link_id = ? LIMIT 1"; my $sth = $dbh->prepare($stmt); $sth->execute($baselink); my $li = $sth -> fetchrow_hashref(); print &format_record($dbh,$vars,$options,$person,"link","html",$li); push @$linklist,$baselink; } &get_citers($dbh,$vars,$options,$person,$baselink,$linklist); # Down print &footer($dbh,$vars,$options,$person); exit; } sub get_citers { my ($dbh,$vars,$options,$person,$link,$linklist) = @_; my $stmt = "SELECT * FROM cite WHERE cite_cited = '$link' ORDER BY cite_id"; my $sth = $dbh->prepare($stmt); $sth->execute(); while (my $ref = $sth -> fetchrow_hashref()) { print $link," cited by ",$ref->{cite_citer},"
"; &get_citers($dbh,$vars,$options,$person,$ref->{cite_citer},$linklist); if (&index_of($ref->{cite_citer},$linklist) == -1) { my $stmt = "SELECT * FROM link WHERE link_id = ? LIMIT 1"; my $sth = $dbh->prepare($stmt); $sth->execute($ref->{cite_citer}); my $li = $sth -> fetchrow_hashref(); if ($li->{link_status} eq "primary") { print &format_record($dbh,$vars,$options,$person,"link","html",$li); } push @$linklist,$ref->{cite_citer}; } } } sub get_cited { my ($dbh,$vars,$options,$person,$link,$linklist) = @_; my $stmt = "SELECT * FROM cite WHERE cite_citer = '$link' ORDER BY cite_id"; my $sth = $dbh->prepare($stmt); $sth->execute(); while (my $ref = $sth -> fetchrow_hashref()) { print $ref->{cite_cited}," cited by ",$link,"
"; if (&index_of($ref->{cite_cited},$linklist) == -1) { my $stmt = "SELECT * FROM link WHERE link_id = ? LIMIT 1"; my $sth = $dbh->prepare($stmt); $sth->execute($ref->{cite_cited}); my $li = $sth -> fetchrow_hashref(); if ($li->{link_status} eq "primary") { print &format_record($dbh,$vars,$options,$person,"link","html",$li); } push @$linklist,$ref->{cite_cited}; } &get_cited($dbh,$vars,$options,$person,$ref->{cite_cited},$linklist); } } #-------------------------------------------------------- # # Newsletter Functions # #-------------------------------------------------------- sub send_newsletter { my ($dbh,$vars,$options,$person) = @_; die "Permission Denied" unless $person->{person_status} eq "admin"; print "Content-type: text/html\n\n"; print "

Send Newsletter

"; my $today = &day_today; # Create Today's CSS my ($theme,$hi_col,$hi_back,$theme_text,$theme_link) = &generate_css($dbh,$vars); my $date = &nice_date(time); print "

$today $date
Today's theme is theme number $theme

"; # Update and Store Newsletter Contents print "

Preparing Contents:
"; my $boxes = {}; my $btitles={}; my $txt_boxes = {}; my $rss_boxes ={}; # Arrays to store box contents, titles, id of text alternates &make_box_contents($dbh,$vars,$options,$person,$boxes,$btitles,$txt_boxes,$rss_boxes); # Wipe out custom content (means it will be unavailable for a few minutes, but much faster to do this all at once) my $dsql = "DELETE FROM custom"; my $dsth = $dbh->prepare($dsql); $dsth->execute(); # For Each person... my $stmt = qq|SELECT * FROM person|; my $sth = $dbh -> prepare($stmt); $sth -> execute(); my $send_count=0; while (my $subscriber = $sth -> fetchrow_hashref()) { if ($vars->{preview} eq "on") { next unless ($subscriber->{person_status} eq "admin"); } print "Subscriber: $subscriber->{person_email} ($subscriber->{person_id})
"; # Make Custom Content my ($custom_html,$custom_rss,$custom_txt,$subject_line) = &make_custom_content($dbh,$subscriber->{person_id},$boxes,$rss_boxes,$txt_boxes,$btitles); my $newsletter = ""; # Initialize Email Text if ($subscriber->{person_eformat} eq "txt") { # Add Text Header and Footer if ($custom_txt) { $newsletter = &template($dbh,"email_txt",$options,$person) . $custom_txt . &template($dbh,"email_txt_bottom",$options,$person); } } else { # Or HTML header and footer if ($custom_html) { $newsletter = &template($dbh,"email_html",$options,$person) . $custom_html . &template($dbh,"email_html_bottom",$options,$person); } } &save_custom_content($dbh,$vars,$options,$person,$subscriber->{person_title},$custom_html,$custom_rss); # Save Custom Contents my $subid; next unless ($subscriber->{person_email}); # No email? No newsletter. next unless ($newsletter); # Don't send blank newsletters, heh # Insert Dates my $byline = "E-learning links and commentary by Stephen Downes
$date"; if ($subscriber->{person_eformat} eq "txt") { $byline =~ s|
|\n|g; } $newsletter =~ s/NICEDATE/$byline/g; # Insert Unsubscribe URL my $unsuburl = "http://www.downes.ca/new_login.cgi?action=Unsubscribe&subscription_id=".$subid."&person_id=".$subscriber->{person_id}; $newsletter =~ s//$unsuburl/; # Insert Theme Values $newsletter =~ s/theme_high_col/$hi_col/mig; $newsletter =~ s/theme_high_back/$hi_back/mig; $newsletter =~ s/theme_number/$theme/mig; $newsletter =~ s/theme_text/$theme_text/mig; $newsletter =~ s/theme_link/$theme_link/mig; $newsletter =~ s|

(.*?)

|
$1
|i; my $th = "http://www.downes.ca/themes/theme".$theme."_banner.jpg"; $newsletter =~ s|theme_banner_img|$th|g; # Preview if ($vars->{preview} eq "on") { print $newsletter; } # Send Newsletter my $replyto = q{Stephen Downes }; $send_count++; &send_email($subscriber->{person_email},$replyto,$subject_line,$newsletter,$subscriber->{person_eformat}); } print "

Sent $send_count newsletters.

"; $vars->{mode} = "brief"; &auto_publish($dbh,$vars,$options,$person); exit; } sub make_box_contents { # Requires that you input four previously declared hash addresses, into which box contents will be stored my ($dbh,$vars,$options,$person,$boxes,$btitles,$txt_boxes,$rss_boxes) = @_; my $today = &day_today; my $stmt = qq|SELECT * FROM box|; my $sth = $dbh -> prepare($stmt); $sth -> execute(); while (my $ref = $sth -> fetchrow_hashref()) { if ($ref->{box_day}) { next unless ($ref->{box_day} eq $today); } $boxes->{$ref->{box_id}} = $ref->{box_content}; $btitles->{$ref->{box_id}} = $ref->{box_title}; $txt_boxes->{$ref->{box_id}} = $ref->{box_txt_version}; $rss_boxes->{$ref->{box_id}} = $ref->{box_rss_version}; } while (my($bx,$by) = each %$boxes) { my $bc = {}; $bc->{content} = $by; $bc->{banner} = "off"; &format_content($dbh,$vars,$options,$person,$bc); $boxes->{$bx} = $bc->{content}; } } sub make_custom_content { my ($dbh,$person_id,$boxes,$rss_boxes,$txt_boxes,$btitles) = @_; my $custom_html = ""; # New Contents my $custom_rss = ""; my $custom_txt = ""; my $subject_line = ""; # Get Subscriptions my $stmt = qq|SELECT * FROM subscription WHERE subscription_person=? ORDER BY subscription_crdate|; my $stha = $dbh -> prepare($stmt); $stha -> execute($person_id); while (my $nitem = $stha -> fetchrow_hashref()) { # For each box subscribed to by person my $box = $nitem->{subscription_box}; # identify box $custom_html .= $boxes->{$box}; # and add to custom HTML my $rssbox = $rss_boxes->{$box}; # identify RSS box $custom_rss .= $boxes->{$rssbox}; # and add to custom RSS my $txtbox = $txt_boxes->{$box}; # identify txt box $custom_txt .= $boxes->{$txtbox}; # and add to custom txt unless ($subject_line) { # if title not yet defined $subject_line = $btitles->{$box}; # title is title of first box $subject_line .= " ~ ".&nice_date(time); # and today's date } } return ($custom_html,$custom_rss,$custom_txt,$subject_line); } sub save_custom_content { my ($dbh,$vars,$options,$person,$person_title,$custom_html,$custom_rss,$title) = @_; $custom_html = &header($dbh,$vars,$options,$person,"htm",$title). $custom_html. &footer($dbh,$vars,$options,$person,"htmprint"); &autodates(\$custom_html); &clean_up(\$custom_html,"htm"); &db_insert($dbh,"custom",{custom_person => $person_title,custom_format => "htm",custom_content => $custom_html}); $custom_rss = &header($dbh,$vars,$options,$person,"rss",$title). $custom_rss. &footer($dbh,$vars,$options,$person,"rss"); &autodates(\$custom_rss); &clean_up(\$custom_rss,"rss"); &db_insert($dbh,"custom",{custom_person => $person_title,custom_format => "rss",custom_content => $custom_rss}); } sub publish { # Publishes designated page my ($dbh,$vars,$options,$person,$page_id) = @_; my $page_number = $page_id; my $msg; print "Content-type: text/html\n\n"; print "

Publishing

"; # Get page content my $stmt = qq|SELECT * FROM page WHERE page_id = '$page_number' LIMIT 1|; my $sth = $dbh -> prepare($stmt); $sth -> execute(); my $ref = $sth -> fetchrow_hashref(); die "Unable to find page number $page_number to be published." unless ($ref); $ref->{content} = $ref->{page_content}; &format_content($dbh,$vars,$options,$person,$ref); my $archive; if ($ref->{page_archive} eq "yes") { $archive = 1; } else { $archive = 0; } if ($ref->{page_format} eq "htm") { $ref->{page_format} = "htmprint"; } my $template_top = $ref->{page_header} || "top"; my $template_bottom = $ref->{page_footer} || "left"; print "Templates:
Top: $template_top
Bottom: $template_bottom

"; my $page_content = &template($dbh,$template_top,$options,$person,$ref->{page_title}). $ref->{content}. &template($dbh,$template_bottom,$options,$person,$ref->{page_title}); $page_content =~ s/Content-type:(.*?)\n\n//i; my $time = time; $page_content =~ s//$time/g; &make_boxes($dbh,\$page_content); &make_keywords($dbh,\$page_content,$person); &pickup_vars($vars,\$page_content); &ldropdown(\$page_content); &dbdropdown($dbh,\$page_content); # &autocats($dbh,\$page_content,$table); &autodates(\$page_content); &popupdate(\$page_content); &hourdate(\$page_content); &daterange(\$page_content); &autoformat(\$page_content); &login_options(\$page_content); &clean_up(\$page_content,$ref->{page_format}); # Print Content unless ($page_content) { die "No content generated for page"; return; } my $print_file = "/opt/httpd/prefork/htdocs/".$ref->{page_file}; die "No output file found for print" unless ($print_file); open POUT,">$print_file" || die "Error opening output file for print: $!"; print POUT $page_content || die "Error printing $print_file : $!"; close POUT; $msg = qq|Printed $ref->{page_title} to $print_file
|; # Print Archive if ($archive) { my ($save_to,$save_url) = &archive_filename($ref->{page_file}); die "failed to create archive filename" unless ($save_to); open POUT,">$save_to" || die "Error opening print file $save_to : $!"; print POUT $page_content; close POUT; $msg .= "Archived $ref->{page_title} to $save_url
"; } if ($vars->{mode} eq "report") { print "Content-type: text/html\n\n"; } if (($vars->{mode} eq "report") || ($vars->{mode} eq "brief")) { print $msg; } return; } sub auto_publish { # Automaticaly publishes pages during send_email my ($dbh,$vars,$options,$person) = @_; $vars->{format} ||= "html"; my $stmt = qq|SELECT page_id FROM page WHERE page_autopub = 'yes'|; my $sth = $dbh -> prepare($stmt); $sth -> execute(); while (my $ref = $sth -> fetchrow_hashref()) { &publish($dbh,$vars,$options,$person,$ref->{page_id}); } } sub archive_filename { # Creates an archive filename based on date and page filename (page_file) # Obtain filename from inout my $archivefile = shift @_; my $Base_Dir = "/opt/apache-1/htdocs/"; my $Base_URL = "http://www.downes.ca/"; # Replace any slashes with underscores $archivefile =~ s/\//_/g; # Get current time and fix digits my ($sec,$min,$hour,$mday,$mon,$year, $wday,$yday,$isdst) = localtime(time); $mday = "0$mday" if ($mday < 10); $mon++; $mon = "0$mon" if ($mon < 10); $year = $year - 2000 if ($year > 1999); $year = $year - 100 if ($year > 99); $year = "0$year" if ($year < 10); # Compile filename and url my $af = $Base_Dir . "archive/$year/$mon" . "_" . $mday . "_" . $archivefile; my $au = $Base_URL . "archive/$year/$mon" . "_" . $mday . "_" . $archivefile; # Compile URL # And return them return ($af,$au); } sub generate_css { my ($dbh,$vars) = @_; my $theme; my $main_name; my $banner_name; if ($vars->{theme}) { $theme = $vars->{theme}; } else { # generate new theme randomly # Count Number of Themes my $stmt = "SELECT COUNT(*) AS items FROM theme"; my $sth = $dbh -> prepare($stmt); $sth -> execute(); my $ref = $sth -> fetchrow_hashref(); my $count = $ref->{items}; # Generate Random CSS Index Number srand( time() ^ ($$ + ($$ << 15)) ); $theme = int(rand $count) + 1; $main_name = "http://www.downes.ca/themes/main_". $theme . ".jpg"; $banner_name = "http://www.downes.ca/themes/banner_". $theme . ".jpg"; } my $css = &template($dbh,"CSS",$options,$person); my $stmt = qq{ SELECT * FROM theme WHERE theme_id = ?}; my $sth = $dbh -> prepare($stmt); $sth -> execute($theme); my $ref = $sth -> fetchrow_hashref(); unless ($ref->{theme_high_col}) { $ref->{theme_high_col} = "#000000"; } unless ($ref->{theme_high_back}) { $ref->{theme_high_back} = "#cccccc"; } while (my($rx,$ry) = each %$ref) { $css =~ s/$rx/$ry/mig; } my $cssfile = "/opt/apache-1/htdocs/edurss02.css"; open CSSOUT,">$cssfile"; print CSSOUT $css; close CSSOUT; return $theme,$ref->{theme_high_col},$ref->{theme_high_back},$ref->{theme_text},$ref->{theme_link}; } # Common Functions # sub associate_resource { my ($dbh,$vars,$lookup,$atable,$afield,$avalue,$btable,$bfield,$bvalue,$data) = @_; my $lookupa = $lookup."_".$atable; my $lookupb=$lookup."_".$btable; # Find Refrence, if it exists my $ref_id_field = $btable."_id"; my $stmt = "SELECT $ref_id_field FROM $btable WHERE $bfield=?"; my $sth = $dbh -> prepare($stmt); $sth -> execute($bvalue); my $result = $sth -> fetchrow_hashref(); if ($result) { # Is It Already Associated? my $stmt = "SELECT * FROM $lookup WHERE $lookupa=? AND $lookupb=?"; my $sth = $dbh -> prepare($stmt); $sth -> execute($avalue,$result->{$ref_id_field}); my $lookup_result = $sth -> fetchrow_hashref(); #And if Not, Associate It unless ($lookup_result) { $dbh->do(qq{INSERT INTO $lookup SET $lookupa=?,$lookupb=?},undef,$avalue,$result->{$ref_id_field}); my $ref_id = $dbh->{'mysql_insertid'}; if ($data->{link_title}) { &make_primary($dbh,$ref_id); } } return $result->{$ref_id_field}; } else { my @insertfields;my @insertvals;my $insertfield;my $insertval; while (my($dx,$dy) = each %$data) { push @insertfields,"$dx=?"; push @insertvals,$dy; } $insertfield = join ",",@insertfields; $insertval = join ",",@insertvals; $dbh->do(qq{INSERT INTO $btable SET $insertfield},undef,@insertvals); my $insert_id = $dbh->{'mysql_insertid'}; die "Error creating $btable" unless $insert_id; $dbh->do(qq{INSERT INTO $lookup SET $lookupa=?,$lookupb=?},undef,$avalue,$insert_id); my $ref_id = $dbh->{'mysql_insertid'}; if ($data->{link_title}) { &make_primary($dbh,$ref_id); } return $insert_id; } } sub make_primary { my ($dbh,$reference) = @_; my $stmt = "UPDATE reference SET reference_type='primary' WHERE reference_id=".$reference; my $sth = $dbh->prepare($stmt); $sth->execute(); return; } #-------------------------------------------------------- # # Date-Time Functions # #-------------------------------------------------------- sub nice_date { # Get date from input my ($current,$h) = @_; my $date; # Just return it if it's not a date number if (($current+0) == 0) { return $current; } my @days = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); my @months = ('January','February','March','April','May', 'June','July','August','September','October', 'November','December'); # Extract values for date my ($sec,$min,$hour,$mday,$mon, $year,$wday,$yday,$isdst) = localtime($current); $year = $year - 100; if ($year < 0) { $year = 2000+$year; } elsif ($year == 0) { $year = "2000"; } else { $year = 2000+$year; } $date = "$months[$mon] $mday, $year"; if ($h) { if ($h eq "month") { $date = "$months[$mon], $year"; return $date; } my $midi; if ($hour > 11) { $midi = "p.m."; } else { $midi = "a.m."; } if ($hour > 12) { $hour = $hour - 12; } if ($hour == 0) { $hour = 12; $midi = "a.m."; } if ($min < 10) { $min = "0" . $min; } $date .= " $hour:$min $midi"; } return "$date"; } sub rfc822_date { # Get date from input my ($current,$h) = @_; my $date; # Just return it if it's not a date number if (($current+0) == 0) { return $current; } my @days = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); my @months = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); # Extract values for date my ($sec,$min,$hour,$mday,$mon, $year,$wday,$yday,$isdst) = localtime($current); # Y2K $year = $year - 100; if ($year < 0) { $year = 2000+$year; } elsif ($year == 0) { $year = "2000"; } else { $year = 2000+$year; } if ($hour < 10) { $hour = "0" . $hour; } if ($min < 10) { $min = "0" . $min; } if ($sec < 10) { $sec = "0" . $sec; } return "$days[$wday], $mon $months[$mon] $year $hour:$min:$sec -0400"; } sub day_today { # What day is it Today? Return the name of the day my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); my @days = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'); return $days[$wday]; } #-------------------------------------------------------- # # line_lengths($text) # # For text-style output, converts the file to # line lengths of 60 characters # #-------------------------------------------------------- sub line_lengths { # Get text string from input my $pagetext = shift @_; # Initialize variables my $line; my $word; my $linelength; my $newline; my $newpage; $pagetext =~ s/\r//; my @linelist = split /\n/,$pagetext; foreach $line (@linelist) { $linelength=0; my $first = "yes"; my @wordlist = split / /,$line; $newline = "\n "; foreach $word (@wordlist) { my $wordlength = length($word) + 1; if ($first eq "yes") { $first = "no"; $linelength = $wordlength;} else { if (($linelength + $wordlength) > 60) { $word = "\n " . $word; $linelength = $wordlength; } else { $word = " " . $word; $linelength += $wordlength; } } $newline .= $word; } $newpage .= $newline; } $newpage =~ s/\n\s*\n\s*\n\s*\n/\n\n\n/g; return $newpage; } sub get_person { # Get Person Info from Cookies my ($dbh,$query) = @_; my $person_title = $query->cookie('person_title'); my $person_id = $query->cookie('person_id'); unless (($person_title) && ($person_id)) { $person_title = "Anymouse"; $person_id = 2; } # Get Person Data my $stmt = qq|SELECT * FROM person WHERE person_title = ? AND person_id = ?|; my $sth = $dbh -> prepare($stmt); $sth -> execute($person_title,$person_id); $options->{execute}++; my $person = $sth -> fetchrow_hashref(); $person->{posts} = {}; return $person if ($person_title eq "Anymouse"); # Get Person Posts-to-read Info $person->{posts} = {}; $stmt = qq|SELECT * FROM posttoread WHERE pr_person = ?|; $sth = $dbh -> prepare($stmt); $sth -> execute($person->{person_id}); $options->{execute}++; while (my $ref = $sth -> fetchrow_hashref()) { my $thr = $ref->{pr_thread}; unless ($person->{posts}->{$thr}) { $person->{posts}->{$thr} = []; } push @{$person->{posts}->{$thr}},$ref->{pr_post}; } return $person; } # ------------------------------------------------------------------------------------- # # get_site # # Gets site configuration variables # # ------------------------------------------------------------------------------------- sub get_site { my ($Site,$conf) = @_; # Get site information open SITE, "$conf" || die "Cannot open site config: $!";; my $comment = '#'; while () { chomp; next unless ($_); next if ($_ =~ /^$comment/); my @vararr = split ' ',$_; my $key = shift @vararr; next unless ($key);next if ($key =~ '#'); my $val = join ' ',@vararr; my $junk; ($val,$junk) = split $comment,$val; $Site->{$key} = $val; } close SITE; #print "Content-type: text/html\n\n";while (my ($x,$y) = each %$Site) { print "$x = $y
"; } exit; } sub old_get_site { my $site = shift; # Find location of config file (hopefully in a secure directory) my $loc; my $locfile = "/home/downess/opt-httpd-prefork-htdocs/cgi-bin/clist/downes-config.loc"; my $comment = '#'; open LOC,"$locfile" || die "Cannot locate site config: $!"; while () { chomp; $loc = $_; last; } close LOC; # Get site information open SITE, "$loc" || die "Cannot open site config: $!";; while () { chomp; next unless ($_); next if ($_ =~ /^$comment/); my @vararr = split ' ',$_; my $key = shift @vararr; next unless ($key);next if ($key =~ '#'); my $val = join ' ',@vararr; my $junk; ($val,$junk) = split $comment,$val; $site->{$key} = $val; } } sub error { my ($dbh,$vars,$person,$msg) = @_; print &header($dbh,$vars); print qq|

Error

$msg

|; print &footer($dbh,$vars,$person); exit; } sub fill_items { # Adds third party metadata to link data arrays my ($dbh,$feed,$tpm) = @_; # TPM = Third Party Metadata # DEBUG if ($options->{debug} eq "1") { print "

fill_items DBH $dbh FEED $feed TPM $tpm
";} # END DEBUG my @linklist; foreach my $f (@{$feed->{link}}) { push @linklist,$f->{link_link}; } foreach my $t (@$tpm) { my $tpm_link = $t."_link";my $tpm_item = $t."_item"; my @getlist = @linklist; my $tpms = &db_select($dbh,$t,{$tpm_item => \@getlist}); foreach my $f (@{$feed->{link}}) { foreach my $r (@$tpms) { if ($r->{$tpm_item} eq $f->{link_link}) { push @{$f->{$t}},$r; } } } } } sub index_of { # Get item and array from input my ($item,$array) = @_; # Initialize counter my $index_count = 0; # For each item in the array foreach my $i (@$array) { # Return the counter value if it matches item if ($item eq $i) { return $index_count; } # Increment the counter $index_count++; } # Return -1 if no match is returned return "-1"; } #---------------------------------------------------------------------------- # # Category (Topic) Functions # #---------------------------------------------------------------------------- sub categorize { # Categorizes a given input element (eg., post) my ($dbh,$options,$table,$id,$data) = @_; my @return; my $cat_list = $table."_topic"; my $cat_list_table = $cat_list."_".$table; my $cat_list_topic = $cat_list."_topic"; $dbh->do(qq{DELETE FROM $cat_list WHERE $cat_list_table=?},undef,$id); # Remove previous topics unless ($options->{topics}) { # Get topics from DB, if necessary $options->{topics} = (); my $stmt = qq|select topic_id,topic_where from topic|; my $sth = $dbh->prepare($stmt); $sth->execute(); while (my $ref = $sth -> fetchrow_hashref()) { $options->{topics}->{$ref->{topic_id}} = $ref->{topic_where}; } } while (my($tx,$ty) = each %{$options->{topics}}) { # Create new topics if ($data =~ /$ty/) { $dbh->do(qq{INSERT INTO $cat_list SET $cat_list_table=?,$cat_list_topic=?},undef,$id,$tx); push @return,$tx; } } return @return; } sub index_category { # Rebuilds the category list for a given category for a given input element (eg., post) my ($dbh,$options,$table,$topic) = @_; my @return; my $topics = (); my $cat_list = $table."_topic"; my $cat_list_table = $cat_list."_".$table; my $cat_list_topic = $cat_list."_topic"; print "Content-type: text/html\n\n"; print "IC...

"; # Get Topic Info return unless ($topic); my $stmt; if ($topic eq "all") { $stmt = qq|select topic_id,topic_where from topic|; } else { $stmt = qq|select topic_id,topic_where from topic WHERE topic_id='$topic'|; } my $sth = $dbh->prepare($stmt); $sth->execute(); while (my $ref = $sth -> fetchrow_hashref()) { $topics->{$ref->{topic_id}} = $ref->{topic_where}; $dbh->do(qq{DELETE FROM $cat_list WHERE $cat_list_topic=?},undef,$ref->{topic_id}); # Remove previous topics } # Cycle through input element table my $tid = $table."_id"; my $tit = $table."_title"; my $desc = $table."_description"; my $pstmt = qq|SELECT $tid,$tit,$desc FROM $table|; my $psth = $dbh->prepare($pstmt); $psth->execute(); while (my $pref = $psth -> fetchrow_hashref()) { # Check input element against topics... my $data = $pref->{$tit}." ".$pref->{$desc}; while (my($tx,$ty) = each %$topics) { if ($data =~ /$ty/i) { # Insert topic if match $dbh->do(qq{INSERT INTO $cat_list SET $cat_list_table=?,$cat_list_topic=?},undef,$pref->{$tid},$tx); } } } return 1; } #---------------------------------------------------------------------------- # # Database Functions # #---------------------------------------------------------------------------- sub db_where { my ($dbh,$in,$prefix) = @_; my $where = ""; my @A; while (my($ix,$iy) = each %$in) { next unless (($ix eq "q") || ($ix =~ /post|topic/) || ($ix eq "where")); next unless ($iy); my $eq=0; if (($ix =~ /_id/) || ($ix =~ /topic_/)) { $eq="1";} if ($ix eq "q") { # Search String, assumed to be from title and description $iy =~ s/ AND /,/g; my @q = split /,/,$iy; my @QW; while (<@q>) { $_ =~ s/'/'/g; my $q; if ($_ =~ /\|/) { $q = "(".$prefix."description REGEXP '$_' OR ".$prefix."title REGEXP '$_')"; } else { my $str = '%'.$_.'%'; $q = "(".$prefix."description LIKE '$str' OR ".$prefix."title LIKE '$str')"; } push @QW,$q; } my $p = join " AND ",@QW; $p = "(".$p.")"; push @A,$p; } elsif ($ix eq $prefix."type") { my @types = split /\0/,$iy; next if ($in->{number_of_types} eq (@types+0)); my @QW; while (<@types>) { my $q = $prefix.qq{type = '$_'}; push @QW,$q; } my $p = join " OR ",@QW; $p = "(".$p.")"; push @A,$p; } elsif ($ix eq "topic") { # SQL chokes on this if the SQL is simply added to the main search next unless ($iy); my @iy = split /\0/,$iy; $iy = join ",",@iy; my $ary_ref = $dbh->selectcol_arrayref("SELECT ".$prefix."topic_post FROM ".$prefix."topic WHERE ".$prefix."topic_topic IN ($iy)"); my $str;if ($ary_ref) { $str = join ",",@$ary_ref; } else { print "None found

"; } if ($str) {my $p = qq{(post_id IN ($str))};push @A,$p;} } elsif ($ix eq "where") { push @A,$iy; } else { $iy =~ s/'/'/g; my $str = '%'.$iy.'%'; my $p; if ($eq eq "1") { $p = qq{($ix = '$iy')}; } else { $p = qq{($ix LIKE '$str')}; } push @A,$p; } } $where = join " AND ",@A; if ($where) { return "WHERE $where"; } else { return ""; } } sub db_sql { my ($db,$format,$where) = @_; my $sql; #if ($db eq "post") { if ($format eq "search") { $sql = qq{SELECT * FROM $db $where}; } if ($format eq "count") { $sql = qq{SELECT count(*) AS count FROM $db $where}; } #} return $sql; } sub db_open { my ($dsn,$user,$password) = @_; my $dbh = DBI->connect($dsn, $user, $password) or die "Database connect error: $! \n"; if ($dbh) { $dbh->trace(2,"dberror.txt"); } return $dbh; } sub db_tables { my ($dbh) = @_; my @tables; my $sql = "show tables"; my $sth = $dbh->prepare($sql); $sth->execute(); while (my $hash_ref = $sth->fetchrow_hashref) { while (my($hx,$hy) = each %$hash_ref) { push @tables,$hy; } } return @tables; } sub db_columns { my ($dbh,$table) = @_; my @columns = (); my $showstmt = "SHOW COLUMNS FROM $table"; my $sth = $dbh -> prepare($showstmt); $sth -> execute(); while (my $showref = $sth -> fetchrow_hashref()) { push @columns,$showref->{Field}; } die "Can't find any columns for $table" unless (@columns); return @columns; } sub db_count { my ($dbh,$table,$where) = @_;my $stmt; my $ctid = $table."_id"; if ($where) { $stmt = "SELECT COUNT($ctid) AS items FROM $table $where"; } else { $stmt = "SELECT COUNT($ctid) AS items FROM $table"; } my $sth = $dbh -> prepare($stmt); $sth -> execute(); my $ref = $sth -> fetchrow_hashref(); return $ref->{items}; } sub db_record_list { my ($dbh,$table,$field,$cmp,$value,$limit) = @_; return unless ($value); # Never compare blank values $value =~ s/'/\\'/g; my $stmt = "SELECT ".$table."_id FROM $table WHERE "; if ($cmp eq "=") { $stmt .= "$field = '$value'"; } elsif ($cmp eq "like") { $stmt .= "$field LIKE '%$value%'"; } elsif ($cmp eq "regex") { $stmt .= "$field REGEXP '".$value."'"; } else { die "Invalid compare function $cmp in record list"; } if ($limit) { $stmt .= " LIMIT $limit"; } my $ary_ref = $dbh->selectcol_arrayref($stmt); if ($limit eq "1") { return $ary_ref->[0]; } else { return $ary_ref; } } sub db_record_creator { my ($dbh,$table,$value) = @_; return unless ($value); # Never compare blank values my $stmt = "SELECT ".$table."_creator FROM $table WHERE ".$table."_id='$value'"; my $ary_ref = $dbh->selectcol_arrayref($stmt); return $ary_ref->[0]; } sub db_record_crip { my ($dbh,$table,$value) = @_; return unless ($value); # Never compare blank values my $stmt = "SELECT ".$table."_crip FROM $table WHERE ".$table."_id='$value'"; my $ary_ref = $dbh->selectcol_arrayref($stmt); return $ary_ref->[0]; } sub db_insert { # Inserts record into table from hash my $dbh = shift || die "Database handler not initiated"; my $table = shift || die "Table not specified on insert"; my $input = shift || die "No data provided on insert"; die "Unsupported data type specified to insert" unless (ref $input eq 'HASH' || ref $input eq 'Link' || ref $input eq 'Feed'); my $data= &db_prepare_input($dbh,$table,$input); my $sql = "INSERT INTO $table "; my(@sqlf, @sqlv, @sqlq) = (); for my $k (sort keys %$data) { push @sqlf, $k; push @sqlq, '?'; push @sqlv, $data->{$k}; } $sql .= '(' . join(', ', @sqlf) .') VALUES ('. join(', ', @sqlq) .')'; #print "Content-type: text/html\n\n $sql -- ",@sqlv,"

"; my $sth = $dbh->prepare($sql); $sth->execute(@sqlv); return $dbh->{'mysql_insertid'}; # Adapted from SQL::Abstract by Nathan Wiger } sub db_update { # Updates record $where (must be ID) in table from hash my $dbh = shift || die "Database handler not initiated"; my $table = shift || die "Table not specified on update"; my $input = shift || die "No data provided on update"; my $where = shift || die "Record ID not specified on update"; die "Unsupported data type specified to update" unless (ref $input eq 'HASH' || ref $input eq 'Link' || ref $input eq 'Feed'); my $data = &db_prepare_input($dbh,$table,$input); my $sql = "UPDATE $table SET "; my(@sqlf, @sqlv) = (); for my $k (sort keys %$data) { push @sqlf, "$k = ?"; push @sqlv, $data->{$k}; } $sql .= join ', ', @sqlf; $sql .= " WHERE ".$table."_id = '".$where."'"; my $sth = $dbh->prepare($sql); $sth->execute(@sqlv); return $where; # Adapted from SQL::Abstract by Nathan Wiger } sub db_prepare_input { # Filters input hash to contain only columns in given table my ($dbh,$table,$input) = @_; my $data = (); my @columns = &db_columns($dbh,$table); # Get a list of columns safeguard data input foreach my $ikeys (keys %$input) { # Clean input for save next unless ($input->{$ikeys}); # - no blank fields next if ($ikeys =~ /_id$/i); # - do not change ID next unless (&index_of($ikeys,\@columns) >= 0); # - input column must exist $data->{$ikeys} = $input->{$ikeys}; # Transfer to input hash $data->{$ikeys} = &demoronise($data->{$ikeys}); # Fix non-standard character input } return $data; } sub demoronise { # From John Walker, Demoroniser - http://www.fourmilab.ch/webtools/demoroniser/ my ($s) = @_; my ($i, $c); # Eliminate idiot MS-DOS carriage returns from line terminator $s =~ s/\r/\n/g; $s =~ s/\n\n/\n/g; # Map strategically incompatible non-ISO characters in the # range 0x82 -- 0x9F into plausible substitutes where # possible. $s =~ s/\x82/,/g; $s =~ s-\x83-f-g; $s =~ s/\x84/,,/g; $s =~ s/\x85/.../g; $s =~ s/\x88/^/g; $s =~ s-\x89- °/°°-g; $s =~ s/\x8B/~-g; $s =~ s-\x99-TM-g; $s =~ s/\x9B/>/g; $s =~ s/\x9C/oe/g; # Now check for any remaining untranslated characters. $s =~ s/[\x00-\x08\x10-\x1F\x80-\x9F]/x/mig; # Supply missing semicolon at end of numeric entity if # Billy's bozos left it out. $s =~ s/(&#[0-2]\d\d)\s/$1; /g; # Fix dimbulb obscure numeric rendering of < > & $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; # Translate Unicode numeric punctuation characters # into ISO equivalents $s =~ s/‐/-/g; # 0x2010 Hyphen $s =~ s/‑/-/g; # 0x2011 Non-breaking hyphen $s =~ s/–/--/g; # 0x2013 En dash $s =~ s/—/--/g; # 0x2014 Em dash $s =~ s/―/--/g; # 0x2015 Horizontal bar/quotation dash $s =~ s/‖/||/g; # 0x2016 Double vertical line $s =~ s-‗-_-g; # 0x2017 Double low line $s =~ s/‘/'/g; # 0x2018 Left single quotation mark $s =~ s/’/'/g; # 0x2019 Right single quotation mark $s =~ s/‚/,/g; # 0x201A Single low-9 quotation mark $s =~ s/‛/'/g; # 0x201B Single high-reversed-9 quotation mark $s =~ s/“/"/g; # 0x201C Left double quotation mark $s =~ s/”/"/g; # 0x201D Right double quotation mark $s =~ s/„/,,/g; # 0x201E Double low-9 quotation mark $s =~ s/‟/"/g; # 0x201F Double high-reversed-9 quotation mark $s =~ s/•/·/g; # 0x2022 Bullet $s =~ s/‣/·/g; # 0x2023 Triangular bullet $s =~ s/․/·/g; # 0x2024 One dot leader $s =~ s/‥/../g; # 0x2026 Two dot leader $s =~ s/…/.../g; # 0x2026 Horizontal ellipsis $s =~ s/‧/·/g; # 0x2027 Hyphenation point return $s; } sub db_locate { my ($dbh,$table,$vals) = @_; die "db_locate(): Cannot locate with no values" unless ($vals); my $stmt = "SELECT ".$table."_id from $table WHERE "; my $wherestr = ""; my @whvals; while (my($vx,$vy) = each %$vals) { if ($wherestr) { $wherestr .= " AND "; } $wherestr .= "$vx = ?"; push @whvals,$vy; } $stmt .= $wherestr . " LIMIT 1"; my $sth = $dbh->prepare($stmt); $sth->execute(@whvals); my $hash_ref = $sth->fetchrow_hashref; return $hash_ref->{$table."_id"}; } sub db_delete { my $dbh = shift || die "Database handler not initiated"; my $table = shift || die "Table not specified on delete"; my $field = shift || die "Field not specified on delete"; my $id = shift || die "No data provided on delete"; die "Invalid input record $id on delete" unless (($id+0) > 0); # Prevents accidental mass deletes my $sql = "DELETE FROM $table WHERE $field = '".$id."'"; my $sth = $dbh->prepare($sql); $sth->execute(); } #------------------------------------------------------------------------------- # # Admin Functions # #--------------------------------------------------------------------------------- sub browse_menu { # Takes Admin out of Admin Menu my ($dbh,$vars,$options,$person) = @_; die "Permission Denied" unless $person->{person_status} eq "admin"; my $stmt = "UPDATE person SET person_mode='browse' WHERE person_id=".$person->{person_id}; my $sth = $dbh->prepare($stmt); $sth->execute(); $vars->{refer} =~ s/AND/&/g; print "Location: $vars->{refer}\n\n"; exit; } sub admin_menu { my ($dbh,$vars,$options,$person) = @_; die "Permission Denied" unless $person->{person_status} eq "admin"; my $stmt = "UPDATE person SET person_mode='admin' WHERE person_id=".$person->{person_id}; my $sth = $dbh->prepare($stmt); $sth->execute(); $vars->{refer} =~ s/AND/&/g; print "Location: $vars->{refer}\n\n"; exit; } sub admin_main{ my ($dbh,$vars,$options,$person) = @_; die "Permission Denied" unless $person->{person_status} eq "admin"; $page->{title} = "Administration Options"; print &header($dbh,$vars,$options,$person); print &messages($options); print qq|

$page->{title}

Mailing List

Feeds

Harvester

|; print &footer($dbh,$vars,$options,$person); exit; } sub admin_nav { # List / Delete Table Items my $dbh = shift; my @tables = &db_tables($dbh); my $output = ""; $output .= "
"; $output .= qq{
[ADMIN]

}; foreach my $table (@tables) { next if ($table =~ /queue|custom|_|reference|subscription/); my $tname = ucfirst($table); my $title = "List ".$tname."s"; $output .= qq{ [Create] [List] $tname
\n }; } $output .= "
\n\n"; return $output; } sub send_email { my $Mailprog = "/usr/sbin/sendmail"; my ($to,$from,$subj,$page,$ext) = @_; open (MAIL,"|$Mailprog -t") or print "Can't find email program $Mailprog"; my $htmlstr = "MIME-Version: 1.0\nContent-Type: text/html; charset=ISO-8859-1"; if ($ext eq "htm") { print MAIL "To: $to\nFrom: $from\nSubject: $subj\n$htmlstr\n\n$page" or print "Email format error: $!"; } else { $page =~ s/(.*?)<\/a>/$2 $1/mig; $page =~ s/\r//mig; # Remove form textarea artifacts $page = &line_lengths($page); $page =~ s/\n /\n/mig; $page =~ s/ \n/\n/mig; $page =~ s/\n/ \n/mig; print MAIL "To: $to\nFrom: $from\nSubject: $subj\n\n$page" or print "Email format error: $!"; } close MAIL; } #-------------- Record ----------------------------------------------------# package Record; use strict; sub new { my ($class,$dbh,$options,$table,$key,$field) = @_; my $record = { }; $field ||= "id"; my $fieldname = $table."_".$field; if ($options->{$table}->{$fieldname}->{$key}) { return $options->{$table}->{$fieldname}->{$key}; } # Return Cache if ($table) { die "Database not open in get_record: $table - $field - $key" unless $dbh; die "Key missing in record lookup: $table - $field - $key" unless ($key); my $stmt = qq|SELECT * FROM $table WHERE $fieldname = ?|; my $sth = $dbh -> prepare($stmt); $sth -> execute($key); $options->{execute}++;if ($options->{debug} eq "1") { print "SQL EXECUTE
"; } my $ref = $sth -> fetchrow_hashref(); unless ($ref) { $record->{error} = "No results found from $stmt

"} while (my($rx,$ry) = each %$ref) { $record->{$rx} = $ry; } } bless $record,$class; $options->{$table}->{$fieldname}->{$key} = $record; # Cache return $record; } package Page; use strict; sub new { my ($self) = @_; my $page = { }; bless $page,$self; return $page; } sub print { my ($self) = @_; print "Content-type: ".$self->{format}."\n\n"; print $self->{content}; } 1; package Search; use strict; sub new { my ($self) = @_; my $search = { }; bless $search,$self; return $search; } 1; #-------------- Feed ----------------------------------------------------# package Feed; use strict; sub new { my $class = shift; my $feed = { }; my @link = (); $feed->{link} = \@link; bless $feed,$class; return $feed; } 1; #-------------- Link ----------------------------------------------------# package Link; use strict; sub new { my $class = shift; my $link = { }; my @commentary = (); my @referral = (); my @learning = (); my @media = (); my @taxon = (); $link->{commentary} = \@commentary; $link->{referral} = \@referral; $link->{media} = \@media; $link->{learning} = \@learning; $link->{taxon} = \@taxon; bless $link, $class; return $link; } 1;