Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

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.

Base::HTML

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:// +www.w3.org/TR/html4/strict.dtd">}); 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;

Base::Roots

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(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(<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;

Base::Menu

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;

Base::Nifty

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

Title:
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!
  • 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?
    Username:
    Password:

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

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (5)
    As of 2015-07-30 02:38 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (269 votes), past polls