Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

It is now almost 18 months later, and I am happy with the results of those months. My goal of getting my site off of server side includes is so very much closer to completion. That isn't to say that I don't have a long way to go, but thanks to the help of my fellow monks, I have made a lot of progress.

My blank slate is now filled with code that I use for almost everything I write. I will always be tweaking and looking for small ways to make things better, so I am including the four modules which make up the back bone of my site.

I have a lot of people that hopefully know how thankful I am for all of their help.


When I want a web page printed for my site, this comes first.

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 fil +e_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 shorte +r. my %exclusions = ( directories => [qw(cgi-bin error files games personal), "Fiction/Ero +tic_fiction/unfinished", "Movies/Movie miscellany", "role_playing/X-M +en"], 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 t +he options. sub print_select { my ($action,%options) = @_; line(2,qq{<form action="$action" method="get">}); line(3,qq{<fieldset>}); line(4,qq{<legend>Display only&#8230;</legend>}); for my $select (sort keys %options) { my $options = $options{$select}; line(4,qq{<select name="$select">}); for my $option (@$options) { if ($option) { line(5,qq{<option value="$option">}.ucfirst $option.qq{</optio +n>}); } else { my $label = $select; $label =~ s/_/ /; $label =~ s/\b(\w)/\u$1/g; line(5,qq{<option value="">$label</option>}); } } line(4,qq{</select>}) } line(4,qq{<input type="submit" value="Search" class="sr">}); line(4,qq{<div><a href="$action">Start over</a></div>}); line(3,qq{</fieldset>}); line(2,qq{</form>}); } #start_html is where the printing of the html output of every module/s +cript begins. This is the template of my site. sub start_html { my ($defined_heading) = @_; print "content-type: text/html \n\n"; line(0,qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://">}); line(0,qq{<html>}); line(0,qq{<head>}); line(1,qq{<title>$title</title>}); print_styles(); line(1,qq{<script type="text/javascript" src="$rootlink/files/javasc +ript/list.js"></script>}); line(0,qq{</head>}); line(0,qq{<body>}); line(1,qq{<div class="left">}); line(2,qq{<h1>Site menu</h1>}); print_menu(3,\%site,$rootdir,$rootlink,qq{ onclick="list_onclick(eve +nt)"},'no'); line(2,"<h2>".root('user')." off-site</h2>"); line(3,qq{<ul>}); for my $key (sort {lc $a cmp lc $b} keys %off_site) { line(4,qq{<li><a href="http://}.$off_site{$key}{link}.qq{">}.$off_ +site{$key}{site}.qq{</a></li>}); } line(3,qq{</ul>}); line(1,qq{</div>}); line(1,qq{<div class="right">}); if ($defined_heading eq 'no') { line(2,qq{<h1>$heading</h1>}); } } #end_html is where the printing of the html output of every module/scr +ipt ends. This is the last part of the template. sub end_html { line(2,qq(<p class="address">Contact ).email.qq(!</p>)); line(1,qq{</div>}); line(0,qq{</body>}); line(0,qq{</html>}); } #print_story is for pure text pages without any other formatting requi +red. 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 sc +ript for the page. sub print_story { my ($source) = @_; start_html('no'); while (my $line = <$source>) { chomp $line; if ($line =~ m/^</) { line(3,$line); } else { line(3,qq(<p>$line</p>)); } } line(3,qq(<p class="author"><small>written by $user</small></p>)); end_html; } 1;


This module gets all kinds of root information for my site or manipulates root information to get and print other things that are based on root.

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(, user => q(Fantasy), name => q(Fantasy's Realm), mail => q(, }, '/home/lady_aleena/var/www' => { link => q(, user => q(Lady Aleena), name => q(Lady Aleena's Home), mail => q(, }, ); 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(<a href="mailto:$hosts{$rootdir}{mail}">$hosts{$rootdir}{u +ser}</a>); } 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/$file +name" : 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 t +he 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<link rel="stylesheet" type="text/css" href="$style">\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!&!&amp;!g; $text =~ s!_(Mr|Mrs|Ms|Dr)_!_$1._!g; $text =~ s!_! !g; return $text; } 1;


When my site is fully finished, I may fold this back into Base::HTML. Currently I am using it in two places, so a separate module was needed.

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 structu +re if ($file =~ m|/|) { #check if there are any more directories in our + file name my ($newdir, $newfile) = split(m|/|, $file, 2); # split the top di +rectory off $directory->{$newdir} = {} unless $directory->{$newdir}; #create t +he 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 ad +d it push @{$directory->{''}}, $file; #add the file. } } sub print_menu { my ($level,$href,$dir,$link,$java,$colors) = @_; line($level,qq(<ul$java>)); for my $key (sort keys %{$href}) { if (length $key) { my $state = $current_directory =~ m/$key/ ? 'open active' : 'clo +sed'; 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(<a href="$index_file">$key_link_text</a>); } else { $key_text = file_text($key); } if (grep($_ !~ /index/,@{$href->{$key}{''}}) > 0 || (keys %{$hre +f->{$key}}) > 1) { line($level+1,qq(<li class="key $state">$key_text)); ++$level; print_menu($level+1,$href->{$key},"$dir/$key","$link/$key",'', +$colors); --$level; line($level+1,qq(</li>)); } else { line($level+1,qq(<li class="key $state">$key_text</li>)); } } 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(<li class="$active"><a href="$print_file" t +itle="$file_text"$color>$file_text</a></li>)); } } } line($level,qq(</ul>)); } 1;


This is just a collection of subroutines that were too small to be on their own which I use in a lot of places all over my site.

package Base::Nifty; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(get_hash commify grammatical_list line article_sor +t name_sort my_sort); #get_hash does just that for me, it gets me a hash from a text file, u +sually a .csv, which I can then use whereever. #written with rindolf in #perlcafe on freenode; golfed with the help o +f [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;

So, there it is, all of the Base modules for my site. I wouldn't have this if it weren't for the people here. Thank you all!

Have a cookie and a very nice day!
Lady Aleena

In reply to Seeing Perl in a new light: Epilog by Lady_Aleena
in thread Seeing Perl in a new light by Lady_Aleena

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others drinking their drinks and smoking their pipes about the Monastery: (6)
    As of 2021-05-09 20:54 GMT
    Find Nodes?
      Voting Booth?
      Perl 7 will be out ...

      Results (102 votes). Check out past polls.