package Base::HTML; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(start_html end_html print_story print_select); use CGI::Carp qw(fatalsToBrowser warningsToBrowser); use Cwd; use File::Basename; use File::Find; use HTML::Entities qw(encode_entities); use List::Util qw(first); use URI::Encode qw(uri_encode); use lib ".."; use Base::Menu qw(push_file print_menu); use Base::Nifty qw(get_hash article_sort name_sort my_sort line); use Base::Roots qw(root_directory get_data root print_styles email file_text); my $full_path = cwd.'/'.basename($0); my $rootdir = root_directory; my $rootlink = root('link'); my $heading = file_text(basename($0)) ne 'index' ? file_text(basename($0)) : 'Home'; my $current_directory = cwd; $current_directory =~ s!$rootdir(/|)!!; my $title = join(' - ',((root('name'),map(ucfirst,split(/\//,$current_directory))),$heading)); $title =~ s/_/ /g; my $user = root('user'); my %off_site; my %off_site_data = ( csv => get_data('Base','other_sites.csv'), headings => [qw(site link)], ); get_hash(\%off_site,\%off_site_data); #Once the site is fully coded, the directory exclusions will be shorter. my %exclusions = ( directories => [qw(cgi-bin error files games personal), "Fiction/Erotic_fiction/unfinished", "Movies/Movie miscellany", "role_playing/X-Men"], file_types => [qw(pl shtml)], file_names => [qw(ssi form sitemap menu textbox thankyou evansstore)], ); my @files; sub wanted { my $directories = join '|', @{$exclusions{directories}}; my $file_types = join '|', @{$exclusions{file_types}}; my $file_names = join '|', @{$exclusions{file_names}}; my $text = $File::Find::name; $text =~ s!$rootdir/!!; if ( -f && $text =~ m!\.($file_types)$! && $text !~ m!^($directories)! && $text !~ m!\b($file_names)!) { push @files, $text; } return; } find(\&wanted, "$rootdir"); my %site; for my $file (@files) { push_file(\%site, $file); } #print_select prints out a selection box in html using a hash to get the options. sub print_select { my ($action,%options) = @_; line(2,qq{
}); line(3,qq{
}); line(4,qq{Display only…}); for my $select (sort keys %options) { my $options = $options{$select}; line(4,qq{}) } line(4,qq{}); line(4,qq{
Start over
}); line(3,qq{
}); line(2,qq{
}); } #start_html is where the printing of the html output of every module/script begins. This is the template of my site. sub start_html { my ($defined_heading) = @_; print "content-type: text/html \n\n"; line(0,qq{}); line(0,qq{}); line(0,qq{}); line(1,qq{$title}); print_styles(); line(1,qq{}); line(0,qq{}); line(0,qq{}); line(1,qq{
}); line(2,qq{

Site menu

}); print_menu(3,\%site,$rootdir,$rootlink,qq{ onclick="list_onclick(event)"},'no'); line(2,"

".root('user')." off-site

"); line(3,qq{}); line(1,qq{
}); line(1,qq{
}); if ($defined_heading eq 'no') { line(2,qq{

$heading

}); } } #end_html is where the printing of the html output of every module/script ends. This is the last part of the template. sub end_html { line(2,qq(

Contact ).email.qq(!

)); line(1,qq{
}); line(0,qq{}); line(0,qq{}); } #print_story is for pure text pages without any other formatting required. There may be a few stray tags in the __DATA__ , #but not many hopefully. More than 6 or so, and I would write a new script for the page. sub print_story { my ($source) = @_; start_html('no'); while (my $line = <$source>) { chomp $line; if ($line =~ m/^$line

)); } } line(3,qq(

written by $user

)); end_html; } 1; #### package Base::Roots; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(root root_directory get_data data_directory print_styles email file_text); use Cwd; use File::Basename; use List::Util qw(first); my $file_name = basename($0); my $full_path = getcwd; my %hosts = ( 'C:/Documents and Settings/ME/My Documents/fantasy' => { link => q(http://localhost), user => q(ME), name => q(ME's Domain), mail => q(ME@localhost), }, '/ftp/pub/www/fantasy' => { link => q(http://www.xecu.net/fantasy), user => q(Fantasy), name => q(Fantasy's Realm), mail => q(fantasy@xecu.net), }, '/home/lady_aleena/var/www' => { link => q(http://lady_aleena.perlmonk.org), user => q(Lady Aleena), name => q(Lady Aleena's Home), mail => q(lady_aleena@perlmonk.org), }, ); sub root_directory { my @dir = grep { $_ if $full_path =~ /^$_/ } keys %hosts; return pop @dir; } my $rootdir = root_directory(); die qq($rootdir is not on the list.) unless exists $hosts{$rootdir}; for my $host (keys %hosts) { $hosts{$host}{data} = $rootdir.'/files/data'; for my $key qw(audio css images) { $hosts{$host}{$key} = $hosts{$host}{link}.'/files/'.$key; } } #email just returns an e-mail link depending on the server it is on. sub email { return qq($hosts{$rootdir}{user}); } sub root { my ($var) = @_; return $hosts{$rootdir}{$var}; } sub data_directory { my ($dir) = @_; return root('data')."/$dir/"; } my $rootlink = root('link'); my $relative_path = $full_path.'/'.$file_name; $relative_path =~ s!^$rootdir!!; $relative_path =~ s!.p[lm]$!!; #get_data searches the data directories for or takes parameters to get a data file. sub get_data { my ($directory,$filename) = @_; my $data = $directory && $filename ? root('data')."/$directory/$filename" : first {-e $_} map("$rootdir/files/data/$relative_path.$_",qw(csv txt)); return $data; } #get_styles and print_styles searches the css directories for all of the style sheets that go with a file. my @relative_path_split = split("/",$relative_path); my @styles = (root('css').'/main.css'); sub get_styles { my ($style_dir) = @_; while (@relative_path_split) { my $var = shift @relative_path_split; if (-f ("$style_dir$var.css")) { push @styles, "$style_dir$var.css"; } get_styles("$style_dir$var/"); } } get_styles($rootdir.'/files/css'); sub print_styles { for my $style (@styles) { $style =~ s!$rootdir!$rootlink!; print qq{\t\n}; } } #file_text makes the printed file name more attractive and in one case adds a little punctuation, more may be added later. sub file_text { my ($text) = @_; $text =~ s!$rootlink/!!; $text =~ s!\.\w{2,5}?$!!; $text =~ s!&!&!g; $text =~ s!_(Mr|Mrs|Ms|Dr)_!_$1._!g; $text =~ s!_! !g; return $text; } 1; #### package Base::Menu; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(push_file print_menu); use Cwd; use File::Basename; use File::Find; use HTML::Entities qw(encode_entities); use List::Util qw(first); use URI::Encode qw(uri_encode); use lib ".."; use Base::Roots qw(file_text); use Base::Nifty qw(line my_sort); my $full_path = cwd.'/'.basename($0); my $current_directory = cwd; #If I want to color code my file names by type, this is what I use. sub link_color { my ($var) = @_; my $color = "000"; $color = "f00" if ($var =~ m!pl$!); $color = "900" if ($var =~ m!pm$!); $color = "00f" if ($var =~ m!html$!); $color = "009" if ($var =~ m!shtml$!); $color = "003" if ($var =~ m!svg$!); $color = "060" if ($var =~ m!css$!); $color = "0f0" if ($var =~ m!csv$!); $color = "090" if ($var =~ m!txt$!); $color = "990" if ($var =~ m!zip$!); $color = "099" if ($var =~ m!js$!); $color = "c33" if ($var =~ m!pdf$!); $color = "939" if ($var =~ m!wav$!); $color = "909" if ($var =~ m!(gif|ico|jpg|png)$!); $color = "696" if ($var =~ m!xls$!); return qq( style="color:#$color"); } #push_file and print_menu are the backbones of printing my directories and files in an html list. #written by simcop2387 in the #perlcafe on freenode. sub push_file { my $directory = shift; #get the previous directory my $file = shift; #get the file we're going to push onto the structure if ($file =~ m|/|) { #check if there are any more directories in our file name my ($newdir, $newfile) = split(m|/|, $file, 2); # split the top directory off $directory->{$newdir} = {} unless $directory->{$newdir}; #create the hash if it isn't there push_file($directory->{$newdir}, $newfile); #recurse with the file name and the directory. } else { # we have no more / in our file name, so go ahead and just add it push @{$directory->{''}}, $file; #add the file. } } sub print_menu { my ($level,$href,$dir,$link,$java,$colors) = @_; line($level,qq()); for my $key (sort keys %{$href}) { if (length $key) { my $state = $current_directory =~ m/$key/ ? 'open active' : 'closed'; my $key_text; if (first {-e $_} map("$dir/$key/index.$_",qw(pl shtml html))) { my $index_file = first {-e $_} map("$dir/$key/index.$_",qw(pl shtml html)); $index_file =~ s/$dir/$link/; my $key_link_text = file_text($key); $key_text = qq($key_link_text); } else { $key_text = file_text($key); } if (grep($_ !~ /index/,@{$href->{$key}{''}}) > 0 || (keys %{$href->{$key}}) > 1) { line($level+1,qq(
  • $key_text)); ++$level; print_menu($level+1,$href->{$key},"$dir/$key","$link/$key",'',$colors); --$level; line($level+1,qq(
  • )); } else { line($level+1,qq(
  • $key_text
  • )); } } else { my @files = grep($_ !~ "index",@{$href->{$key}}); if ($link =~ m/(Other_poets|Player_characters|Spellbooks)$/) { @files = sort {my_sort($a,$b,'name','-1')} @files; } else { @files = sort {my_sort($a,$b,'file')} @files; } for my $file (@files) { my $print_file = $link.'/'.uri_encode($file); $print_file =~ s/&/%26/g; my $color = $colors eq "yes" ? link_color($file) : ''; my $file_text = file_text($file); my $active = $full_path =~ m/$file/ ? 'active' : 'inactive'; line($level + 1,qq(
  • $file_text
  • )); } } } line($level,qq()); } 1; ##
    ## package Base::Nifty; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(get_hash commify grammatical_list line article_sort name_sort my_sort); #get_hash does just that for me, it gets me a hash from a text file, usually a .csv, which I can then use whereever. #written with rindolf in #perlcafe on freenode; golfed with the help of [GrandFather] of PerlMonks. sub get_hash { my ($hash,$data_hash) = @_; open(my $fh, $data_hash->{csv}) or die("can't open $data_hash $!"); while (my $value = <$fh>) { chomp $value; my @inner_array = split(/\|/,$value); my $n = 0; for my $heading (@{$data_hash->{headings}}) { $$hash{$inner_array[0]}{$heading} = $inner_array[$n]; ++$n; } } } #commify was found in the perldocs to put commas in numbers. sub commify { local $_ = shift; 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; return $_; } #grammatical_list is used when I want to print a list with grammatical correctness. #written with the help of DrForr in #perlcafe on freenode, golfed by in #perlmonks on SlashNET. sub grammatical_list { my $conj = shift(@_) . ' '; return @_ if @_ <= 1; return join( ' '.$conj, @_ ) if @_ == 2; my $punc = grep( /,/, @_ ) ? '; ' : ', '; push @_, $conj.pop; join $punc, @_ } #tab and line are just to add tabs and newlines on the output. sub tab { my ($tab) = @_; return ("\t") x $tab; } sub line { my ($tab,$line) = @_; print tab($tab)."$line\n"; } #written mostly by kent/n in #perl on freenode. sub article_sort { my ($c,$d) = @_; for ($c,$d) { $_ =~ s{\s*\b(A|a|An|an|The|the)(_|\s)}{}xi; } return $c cmp $d; } sub name_sort { my ($c,$d,$sort_numer) = @_; return (split /_/, $c)[$sort_numer] cmp (split /_/, $d)[$sort_numer]; } #golfed by [ikegami] on PerlMonks. sub my_sort { my ($c,$d,$type,$sort_number) = @_; my $initial = $c =~ /^index/ ? 0 : 1 <=> $d =~ /^index/ ? 0 : 1 || $c =~ /^ssi/ ? 0 : 1 <=> $d =~ /^ssi/ ? 0 : 1 || $c =~ /css$/ ? 0 : 1 <=> $d =~ /css$/ ? 0 : 1; return $initial if $initial; if ($type eq 'file') { s{\s*\b(?:an?|the)_}{}xi for $c, $d; return $c cmp $d; } elsif ($type eq 'name') { return (split /_/, $c)[$sort_number] cmp (split /_/, $d)[$sort_number]; } else { die("Bad type $type"); } } 1;