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;