File Coverage

blib/lib/Labyrinth/Globals.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Labyrinth::Globals;
2              
3 8     8   37 use warnings;
  8         10  
  8         283  
4 8     8   31 use strict;
  8         11  
  8         273  
5              
6 8     8   94 use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT @EXPORT_OK);
  8         10  
  8         1000  
7             $VERSION = '5.30';
8              
9             =head1 NAME
10              
11             Labyrinth::Globals - Configuration and Parameter Handler for Labyrinth
12              
13             =head1 SYNOPSIS
14              
15             use Labyrinth::Globals qw(:all);
16              
17             # database object creation
18             DBConnect();
19              
20             # Interface (CGI) parameter handling
21             ParseParams();
22              
23             =head1 DESCRIPTION
24              
25             The Globals package contains a number of variables and functions that are
26             used across the system. The variables contain input and output values,
27             and the functions are generic.
28              
29             =head1 EXPORT
30              
31             All by default.
32              
33             use Labyrinth::Globals qw(:all); # all methods
34              
35             =cut
36              
37             # -------------------------------------
38             # Export Details
39              
40             require Exporter;
41             @ISA = qw(Exporter);
42              
43             %EXPORT_TAGS = (
44             'all' => [ qw(
45             LoadAll LoadSettings LoadRules ParseParams
46             DBConnect dbh
47             ScriptPath ScriptFile
48             ) ]
49             );
50              
51             @EXPORT_OK = ( @{$EXPORT_TAGS{'all'}} );
52             @EXPORT = ( @{$EXPORT_TAGS{'all'}} );
53              
54             # -------------------------------------
55             # Library Modules
56              
57 8     8   7177 use Config::IniFiles;
  0            
  0            
58             use Data::Dumper;
59             use Data::FormValidator;
60             use Data::FormValidator::Constraints::Upload;
61             use Data::FormValidator::Constraints::Words;
62             use Data::FormValidator::Filters::Demoroniser qw(demoroniser);
63             use File::Basename;
64             use File::Path;
65             use File::Spec::Functions;
66             use IO::File;
67              
68             use Labyrinth::Audit;
69             use Labyrinth::Constraints;
70             use Labyrinth::Constraints::Emails;
71             use Labyrinth::DBUtils;
72             use Labyrinth::DIUtils;
73             use Labyrinth::Filters qw(float2 float3 float5);
74             use Labyrinth::Media;
75             use Labyrinth::Variables;
76             use Labyrinth::Writer;
77              
78             # -------------------------------------
79             # Variables
80              
81             my %rules; # internal rules hash
82              
83             # -------------------------------------
84             # The Subs
85              
86             =head1 FUNCTIONS
87              
88             =head2 Loaders
89              
90             =over 4
91              
92             =item LoadAll([$dir])
93              
94             LoadAll() automatically loads and instatiates many global variables. The
95             method assumes default values are required. Can be called with a base install
96             directory path, which is then used by LoadSettings().
97              
98             This method should be called at the beginning of any script.
99              
100             =item LoadSettings($dir)
101              
102             LoadSettings() loads a settings file (config/settings.ini) and stores them
103             in an internal hash. Typical settings are database settings (eq driver,
104             database, user, password) and general settings (eg administrator email).
105              
106             LoadSettings() can be passed the name of the base install directory, or it will
107             attempt to figure it out via the current working directory.
108              
109             =item LoadRules()
110              
111             LoadRules() loads a rules file (default is parserules.ini or the name of the
112             'parsefile' in the settings configuration file) and store the rules in an
113             internal hash. This hash is then used to verify the contains of any interface
114             (CGI) parameters passed to the script.
115              
116             Note that as LoadRules() can be called many times with different rules
117             files, only the last value of a given rule is stored. This is useful if
118             you wish to have a standard rules file and wish to load further or
119             different rules dependant upon the script being used.
120              
121             =back
122              
123             =cut
124              
125             sub LoadAll {
126             my $settings = shift;
127              
128             LoadSettings($settings);
129             ParseParams();
130             DBConnect();
131             }
132              
133             sub LoadSettings {
134             my $settings = shift;
135             $settings ||= '';
136              
137             # default file names
138             my $LOGFILE = 'audit.log';
139             my $PHRASEBOOK = 'phrasebook.ini';
140             my $PARSEFILE = 'parserules.ini';
141              
142             #print STDERR "# ENV $_ => $ENV{$_}\n" for('HTTP_HOST', 'REMOTE_ADDR', 'SERVER_PROTOCOL', 'SERVER_PORT');
143             # Server/HTTP values
144             my $host = $ENV{'HTTP_HOST'} || '';
145             my $ipaddr = $ENV{'REMOTE_ADDR'} || '';
146             my ($protocol) = $ENV{'SERVER_PROTOCOL'}
147             ? ($ENV{'SERVER_PROTOCOL'} =~ m!^(\w+)\b!)
148             : $ENV{'SERVER_PORT'} && $ENV{'SERVER_PORT'} eq '443'
149             ? ('https')
150             : ('http');
151             $protocol = lc($protocol);
152              
153             my $path = $ENV{'REQUEST_URI'} ? 'REQUEST_URI' : 'PATH_INFO';
154             my ($req,$script) = ($ENV{$path} && $ENV{$path} =~ m|^(.*)/([^?]+)|) ? ($1,$2) : ('','');
155             my $cgiroot = ($req =~ /^$protocol:/) ? $req : $protocol . '://' . ($ENV{'HTTP_HOST'} ? $ENV{'HTTP_HOST'} : '') . $req;
156             my $docroot = ($req && $cgiroot =~ m!^((.*)/.*?)! ? $1 : $cgiroot);
157             $cgiroot =~ s!/$!!;
158             $docroot =~ s!/$!!;
159              
160             # set defaults
161             my ($cgipath,$webpath) = ($cgiroot,$docroot);
162              
163             # load the configuration data
164             unless($settings && -r $settings) {
165             LogError("Cannot read settings file [$settings]");
166             SetError('ERROR',"Cannot read settings file");
167             return;
168             }
169              
170             my $cfg = Config::IniFiles->new( -file => $settings );
171             unless(defined $cfg) {
172             LogError("Unable to load settings file [$settings]: @Config::IniFiles::errors");
173             SetError('ERROR',"Unable to load settings file");
174             return;
175             }
176              
177             # load the configuration data
178             for my $sect ($cfg->Sections()) {
179             for my $name ($cfg->Parameters($sect)) {
180             my @value = $cfg->val($sect,$name);
181             next unless(@value);
182             if(@value > 1) {
183             $settings{$name} = \@value;
184             $tvars{$name} = \@value if($sect =~ /^(PROJECT|HTTP|CMS)$/);
185             } elsif(@value == 1) {
186             $settings{$name} = $value[0];
187             $tvars{$name} = $value[0] if($sect =~ /^(PROJECT|HTTP|CMS)$/);
188             }
189             }
190             }
191             $cfg = undef;
192              
193             SetLogFile( FILE => $settings{'logfile'},
194             USER => 'labyrinth',
195             LEVEL => ($settings{'loglevel'} || 0),
196             CLEAR => (defined $settings{'logclear'} ? $settings{'logclear'} : 1),
197             CALLER => (defined $settings{'logcaller'} ? $settings{'logcaller'} : 1)
198             );
199              
200             # evaluate standard path settings
201             $settings{'protocol'} = $protocol;
202             $settings{'host'} = $host;
203             $settings{'ipaddr'} = $ipaddr;
204             $settings{'docroot'} = $docroot;
205             $settings{'cgiroot'} = $cgiroot;
206             $settings{'script'} = $script;
207             $settings{'logdir'} = "$settings{'webdir'}/cache" unless($settings{'logdir'});
208             $settings{'config'} = "$settings{'cgidir'}/config" unless($settings{'config'});
209             $settings{'templates'} = "$settings{'cgidir'}/templates" unless($settings{'templates'});
210             $settings{'webpath'} = $webpath unless(exists $settings{'webpath'});
211             $settings{'cgipath'} = $cgipath unless(exists $settings{'cgipath'});
212              
213             $tvars{$_} = $settings{$_} for(qw(host docroot cgiroot webpath cgipath script ipaddr));
214              
215             $settings{'logfile'} = "$settings{'logdir'}/$LOGFILE" unless($settings{'logfile'});
216             $settings{'phrasebook'} = "$settings{'config'}/$PHRASEBOOK" unless($settings{'phrasebook'});
217             $settings{'parsefile'} = "$settings{'config'}/$PARSEFILE" unless($settings{'parsefile'});
218              
219             # generate the absolute path, in the event of errors
220             foreach my $key (qw(logfile phrasebook parsefile)) {
221             next unless $settings{$key};
222             next if $settings{$key} =~ m|^/|;
223             $settings{$key} = File::Spec->rel2abs( $settings{$key} ) ;
224             }
225              
226             # path & title mappings
227             for my $map (qw(path title)) {
228             next unless($settings{$map . 'maps'});
229             if( ref($settings{$map . 'maps'}) eq 'ARRAY') {
230             for(@{ $settings{$map . 'maps'} }) {
231             my ($name,$value) = split(/=/,$_,2);
232             $settings{$map . 'map'}{$name} = $value;
233             }
234             } elsif($settings{$map . 'maps'}) {
235             my ($name,$value) = split(/=/,$settings{$map . 'maps'},2);
236             $settings{$map . 'map'}{$name} = $value;
237             }
238             }
239              
240             #LogDebug("settings=".Dumper(\%settings));
241              
242             # set image processing driver, if specified
243             Labyrinth::DIUtils::Tool($settings{diutils}) if($settings{diutils});
244              
245             $settings{settingsloaded} = 1;
246             }
247              
248             sub LoadRules {
249             return if($settings{rulesloaded});
250              
251             # ensure we can access the rules file
252             my $rules = shift || $settings{'parsefile'} || '';
253             if(!$rules || !-f $rules || !-r $rules) {
254             LogError("Cannot read rules file [$rules]");
255             SetError('ERROR',"Cannot read rules file");
256             return;
257             }
258              
259             my $fh = IO::File->new($rules, 'r');
260             unless(defined $fh) {
261             LogError("Cannot open rules file [$rules]: $!");
262             SetError('ERROR',"Cannot open rules file");
263             return;
264             }
265              
266             %rules = (
267             validator_packages => [qw( Data::FormValidator::Constraints::Upload
268             Data::FormValidator::Constraints::Words
269             Labyrinth::Constraints::Emails
270             Labyrinth::Constraints
271             Labyrinth::Filters
272             )],
273             filters => ['trim', demoroniser()],
274             msgs => {prefix=> 'err_'}, # set a custom error prefix
275             # untaint_all_constraints => 1,
276             missing_optional_valid => 1,
277             constraint_methods => {
278             realname => \&realname,
279             basicwords => \&basicwords,
280             simplewords => \&simplewords,
281             paragraph => \¶graph,
282             emails => \&emails,
283             url => \&url,
284             ddmmyy => \&ddmmyy
285             },
286             );
287              
288             my ($required_regex,$optional_regex);
289              
290             while(<$fh>) {
291             s/\s+$//;
292              
293             my ($name,$required,$default,$filters,$constraint,$regex) = split(',',$_,6);
294             next unless($name);
295              
296             $name =~ s/\s+$// if(defined $name);
297             $required =~ s/\s+$// if(defined $required);
298             $default =~ s/\s+$// if(defined $default);
299             $filters =~ s/\s+$// if(defined $filters);
300             $constraint =~ s/\s+$// if(defined $constraint);
301              
302             # $rules{$name}->{required} = $required;
303             # $rules{$name}->{default} = $default;
304             # $rules{$name}->{constraint} = $constraint;
305             # $rules{$name}->{regex} = "@regex";
306              
307             if($name =~ /^:(.*)/) {
308             $name = qr/$1/;
309             if($required) { $required_regex .= "$name|" }
310             else { $optional_regex .= "$name|" }
311             if($constraint) { $rules{constraint_regexp_map}->{$name} = _constraint($constraint) }
312             elsif($regex) { $rules{constraint_regexp_map}->{$name} = qr/^$regex$/ }
313             else { die "no constraint or regex for entry: $name" }
314             if($filters) { $rules{field_filter_regexp_map}->{$name} = [split(":",$filters)] }
315             } else {
316             if($required) { push @{$rules{required}}, $name }
317             else { push @{$rules{optional}}, $name }
318             if($constraint) { $rules{constraints}->{$name} = _constraint($constraint) }
319             elsif($regex) { $rules{constraints}->{$name} = qr/^$regex$/ }
320             else { die "no constraint or regex for entry: $name" }
321             if($default) { $rules{defaults}->{$name} = $default }
322             if($filters) { $rules{field_filters}->{$name} = [split(":",$filters)] }
323             }
324             }
325             $fh->close;
326              
327             #LogDebug("Constraints: rules=" . Dumper(\%rules));
328              
329             if($required_regex) {
330             $required_regex =~ s/|$//;
331             $rules{required_regexp} = qr/^$required_regex$/;
332             }
333              
334             if($optional_regex) {
335             $optional_regex =~ s/|$//;
336             $rules{optional_regexp} = qr/^$optional_regex$/;
337             }
338              
339             $rules{debug} = 0;
340              
341             $settings{rulesloaded} = 1;
342             }
343              
344             sub _constraint {
345             my $constraint = shift;
346             if($constraint eq 'imagefile') {
347             my %hash = (
348             constraint_method => 'file_format',
349             params => [mime_types => [qw!image/jpe image/jpg image/jpeg image/gif image/png!]],
350             );
351             return \%hash;
352             } else {
353             my %hash = (
354             constraint_method => $constraint,
355             );
356             return \%hash;
357             }
358              
359             return $constraint;
360             }
361              
362             =head2 Script Name
363              
364             =over 4
365              
366             =item ScriptPath()
367              
368             =item ScriptFile()
369              
370             =back
371              
372             =cut
373              
374             sub ScriptPath {
375             return $settings{cgipath} if($settings{cgipath} =~ m!^http!); # we're assuming only http/https
376             return $settings{cgiroot};
377             }
378              
379             sub ScriptFile {
380             my %hash = @_;
381             my $path = ScriptPath() || '';
382             my $file = $hash{file} || $settings{script};
383             my $query = $hash{query} ? '?' . $hash{query} : '';
384              
385             return "$path/$file$query";
386             }
387              
388             =head2 Database Handling
389              
390             =over 4
391              
392             =item DBConnect()
393              
394             The method to initiate the Database access object. The method passes the
395             values held within the internal settings (set LoadSettings()), to the DB
396             access object constructor. It returns and stores internally the object
397             reference, which can be accessed across the system via the $dbi scalar.
398              
399             =item dbh
400              
401             Returns the reference to the DB access object, as created by the DBConnect()
402             method, or calls DBConnect() if not previously invoked.
403              
404             =back
405              
406             =cut
407              
408             sub DBConnect {
409             return $dbi if $dbi; # object already exists
410              
411             # use settings or defaults
412             my $logfile = $settings{logfile};
413             my $phrasebook = $settings{phrasebook};
414             my $dictionary = $settings{dictionary};
415              
416             $dbi = Labyrinth::DBUtils->new({
417             driver => $settings{driver},
418             database => $settings{database},
419             dbfile => $settings{dbfile},
420             dbhost => $settings{dbhost},
421             dbport => $settings{dbport},
422             dbuser => $settings{dbuser},
423             dbpass => $settings{dbpass},
424             autocommit => $settings{autocommit},
425             logfile => $logfile,
426             phrasebook => $phrasebook,
427             dictionary => $dictionary,
428             });
429             LogDebug("DBConnect DONE");
430              
431             $dbi;
432             }
433              
434             # used by the DB access object
435             sub _errors {
436             my $err = shift;
437             my $sql = shift;
438             my $message = '';
439              
440             $message = "$err
" if($err);
441             $message .= "
SQL=$sql
" if($sql);
442             $message .= "ARGS=[".join(",",@_)."]" if(@_);
443              
444             $tvars{failures} = [ { code => 'DB', message => $message } ];
445             PublishCode('MESSAGE');
446             exit;
447             }
448              
449             sub dbh {
450             $dbi || DBConnect;
451             }
452              
453             =head2 Interface Parameter Handling
454              
455             =over 4
456              
457             =item ParseParams($rules)
458              
459             ParseParams() reads and validates the interface (CGI) parameters that are sent
460             via a HTTP request, before storing them in the %cgiparams hash. Each parameter
461             must have a rule for it to be accepted.
462              
463             The rules file (default is parserules.ini) is automatically loaded and stored.
464              
465             All valid input parameter values (scalars only) are also automatically stored
466             in the template variable hash, %tvars. This is to enable templates to be
467             reparsed in the event of an error, and retain the user's valid entries.
468              
469             =back
470              
471             =cut
472              
473             sub ParseParams {
474             LoadRules($_[0]) unless($settings{rulesloaded});
475              
476             my $results;
477              
478             # LogDebug("rules=".Dumper(\%rules));
479              
480             if(!defined $ENV{'SERVER_SOFTWARE'}) { # commandline testing
481             my $file = "$settings{'config'}/cgiparams.nfo";
482             if(-r $file) {
483             my $fh = IO::File->new($file, 'r') or return;
484             my (%params,$params);
485             { local $/ = undef; $params = <$fh>; }
486             $fh->close;
487             foreach my $param (split(/[\r\n]+/,$params)) {
488             my ($name,$value) = $param =~ /(\w+)=(.*)/;
489             next unless($name);
490              
491             if($value =~ /\[([^\]]+)\]/) {
492             @{$params{$name}} = split(",",$1);
493             } else {
494             $params{$name} = $value;
495             }
496             }
497              
498             LogDebug("params=".Dumper(\%params));
499             $results = Data::FormValidator->check(\%params, \%rules);
500             $settings{testing} = 1;
501             }
502              
503             } else {
504             my %fdat = $cgi->Vars;
505             LogDebug("fdat=".Dumper(\%fdat));
506              
507             # Due to a problem with DFV, we handle images separately
508             for my $param ( grep { /^IMAGEUPLOAD/ } keys %fdat ) {
509             if( $cgi->param($param) ) {
510             CGIFile($param);
511             $settings{cgiimages}{$param} = 1;
512             }
513             $cgi->delete($param)
514             }
515              
516             # my %fields = map {$_ => 1} @{$rules{required}}, @{$rules{optional}};
517             # for (keys %fdat) {
518             # LogDebug("NO RULE: $_")
519             # unless( $fields{$_} ||
520             # ($rules{required_regexp} && $_ =~ $rules{required_regexp}) ||
521             # ($rules{optional_regexp} && $_ =~ $rules{optional_regexp})
522             # );
523             # }
524              
525             $results = Data::FormValidator->check($cgi, \%rules);
526             }
527              
528             if($results) {
529             # LogDebug("results=".Dumper($results));
530             my $values = $results->valid;
531             %cgiparams = %$values;
532             $values = $results->msgs;
533             foreach my $key (keys %$values) {
534             $tvars{$key} = $values->{$key} if($key =~ /^err_/);
535             }
536              
537             # LogDebug("GOT RULE: env=" . Dumper(\%ENV));
538             # LogDebug("GOT RULE: rules=" . Dumper(\%rules));
539             } else {
540             LogDebug("NO Data::FormValidator RESULTS!");
541             my( $valids, $missings, $invalids, $unknowns ) = Data::FormValidator->validate($cgi, \%rules);
542             LogDebug("NO RULE: valids=" . Dumper($valids));
543             LogDebug("NO RULE: invalids=" . Dumper($invalids));
544             # LogDebug("NO RULE: missings=" . Dumper($missings));
545             # LogDebug("NO RULE: unknowns=" . Dumper($unknowns));
546             # LogDebug("NO RULE: env=" . Dumper(\%ENV));
547             # LogDebug("NO RULE: rules=" . Dumper(\%rules));
548             %cgiparams = %$valids;
549             $cgiparams{'err_'.$_} = 'Invalid' for(@$invalids);
550             }
551              
552             $cgiparams{$_} = 1 for(keys %{$settings{cgiimages}});
553              
554             LogDebug("cgiparams=".Dumper(\%cgiparams));
555             LogInfo("ParseParams DONE");
556             }
557              
558              
559             1;
560              
561             __END__