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{
}); } #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{Contact ).email.qq(!
)); line(1,qq{$line
)); } } line(3,qq( )); 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;