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…</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!&!&!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
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.
|
|