File Coverage

blib/lib/Labyrinth.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package Labyrinth;
2              
3 6     6   93029 use warnings;
  6         11  
  6         188  
4 6     6   24 use strict;
  6         6  
  6         261  
5              
6             our $VERSION = '5.30';
7              
8             =head1 NAME
9              
10             Labyrinth - An extensible website in a box.
11              
12             =head1 SYNOPSIS
13              
14             use Labyrinth;
15             my $labyrinth = Labyrinth->new();
16             $labyrinth->run();
17              
18             =head1 DESCRIPTION
19              
20             Documentation overview for Labyrinth.
21              
22             Labyrinth began life in 2002, with a small set of plugins to enable various
23             features of web site management. The core set of plugins are now available as
24             the Labyrinth-Plugin-Core package, with this package providing the core
25             functionality that drives the Labyrinth framework system.
26              
27             See the individual files for more details on how to use them.
28              
29             =cut
30              
31             # -------------------------------------
32             # Library Modules
33              
34 6     6   2733 use Module::Pluggable search_path => ['Labyrinth::Plugin'];
  6         43076  
  6         41  
35              
36             # Required Core
37 6     6   2672 use Labyrinth::Audit;
  6         11  
  6         798  
38 6     6   2542 use Labyrinth::DTUtils;
  0            
  0            
39             use Labyrinth::Globals qw(:all);
40             use Labyrinth::Mailer;
41             use Labyrinth::Plugins;
42             use Labyrinth::Request;
43             use Labyrinth::Session;
44             use Labyrinth::Support;
45             use Labyrinth::Writer;
46             use Labyrinth::Variables;
47              
48             # -------------------------------------
49             # Variables
50              
51             my %plugins;
52              
53             # -------------------------------------
54             # The Program
55              
56             =head1 FUNCTIONS
57              
58             =head2 Constructor
59              
60             =over 4
61              
62             =item new()
63              
64             Instantiates the Labyrinth object.
65              
66             =back
67              
68             =cut
69              
70             sub new {
71             my $self = shift;
72              
73             # create an attributes hash
74             my $atts = {};
75              
76             # create the object
77             bless $atts, $self;
78             return $atts;
79             }
80              
81             =head2 Methods
82              
83             =over 4
84              
85             =item run()
86              
87             Provides the dispatch loop, instantiating any configuration required, then
88             processes each command in turn, before finally publishing the result.
89              
90             =cut
91              
92             sub run {
93             my ($self,$file,%hash) = @_;
94             my ($user,$realm,$command,$request);
95              
96             my $LAYOUT = 'public/layout.html';
97             my $default_realm = 'public';
98             $default_realm = $hash{realm} if(%hash && $hash{realm});
99              
100             $tvars{errcode} = '';
101              
102             eval {
103             Labyrinth::Variables::init(); # initial standard variable values
104              
105             UnPublish(); # Start a fresh slate
106             LoadSettings($file); # Load All Global Settings
107              
108             die $tvars{errmess} if($tvars{errcode} && $tvars{errcode} eq 'ERROR');
109              
110             MailSet(mailsend => $settings{mailsend}, logdir => $settings{logdir});
111              
112             DBConnect();
113             ParseParams();
114              
115             ## defaults in the event of errors
116             $tvars{layout} = $LAYOUT;
117             $tvars{content} = '';
118              
119             ## session validation & the request
120             $user = ValidSession();
121             $realm = $user ? $user->realm : $default_realm;
122             $command = $cgiparams{act};
123             $request = Labyrinth::Request->new($realm,$command);
124             $tvars{realm} = $realm;
125              
126             $self->load;
127             };
128              
129             die "Cannot start Labyrinth: $@\n" if($@);
130              
131             ## 1. each request is only the start.
132             ## 2. upon success or failure it is possible other commands will follow.
133             ## 3. the content for each command can be different.
134             ## 4. if errcode is set, we check if a failure command is required first.
135             ## 5. if no more commands we publish.
136              
137             do {
138             $tvars{errcode} = undef;
139              
140             while(my $action = $request->next_action) {
141             LogDebug("run: action=$action");
142             $self->action($action);
143              
144             if($tvars{errcode} && $tvars{errcode} eq 'NEXT') {
145             $tvars{errcode} = undef;
146             $command = $tvars{command};
147             while($request->next_action) {} # ignore remaining actions
148             $request->reset_request($command) if($command);
149             #if($tvars{redirect}) {
150             # Publish();
151             # return;
152             #}
153             }
154              
155             $realm ||= '';
156             $tvars{realm} ||= '';
157              
158             if($realm ne $tvars{realm} ) { # just in case of a login/logout
159             $realm = $tvars{realm};
160             $request->reset_realm($tvars{realm});
161             }
162              
163             last if $tvars{errcode};
164             }
165              
166             LogDebug("run: 1.errcode=".($tvars{errcode} || 'undef'));
167              
168             if(!defined $tvars{errcode}) { $command = $request->onsuccess }
169             elsif($tvars{errcode} eq 'NEXT') { $command = $tvars{command} }
170             elsif($tvars{errcode} eq 'ERROR') { $command = $request->onerror }
171             elsif($tvars{errcode} eq 'FAIL') { $command = $request->onfailure }
172             elsif($tvars{errcode}) { $command = 'error-' . lc($tvars{errcode}) }
173             else { $command = $request->onsuccess }
174              
175             LogDebug("run: command=".($command || 'undef'));
176              
177             if($command) { $request->reset_request($command) }
178             else { $command = undef }
179              
180             #if($tvars{redirect}) {
181             # Publish();
182             # return;
183             #}
184             } while($command);
185              
186             # just in case some joker has tried to access the realm directly
187             $request->reset_realm($tvars{realm});
188              
189             foreach my $field (qw(layout content)) {
190             my $value = $request->$field();
191             $tvars{$field} = $value if($value);
192             }
193             LogDebug("run: layout=$tvars{layout}");
194             LogDebug("run: content=$tvars{content}");
195             LogDebug("run: loggedin=$tvars{loggedin}");
196              
197             return Publish();
198             }
199              
200             =item load()
201              
202             Loads plugins found within the plugin directory.
203              
204             =item action($action)
205              
206             Calls the appropriate plugin method.
207              
208             =back
209              
210             =cut
211              
212             sub load {
213             my $self = shift;
214             load_plugins($self->plugins());
215             }
216              
217             sub action {
218             my ($self,$action) = @_;
219             my ($class,$method) = ($action =~ /(.*)::(.*)/);
220             $class = ($class =~ /^Labyrinth/ ? $class : 'Labyrinth::Plugin::' . $class);
221              
222             if(my $plugin = get_plugin($class)) {
223             eval { $plugin->$method(); };
224              
225             # this may fail at the moment, as not all requests have an onerror entry.
226             # as such a default (badcommand?) may need to be set.
227              
228             if($@) {
229             $tvars{errcode} = 'ERROR';
230             LogError("action: class=$class, method=$method, FAULT: $@");
231             }
232             } else {
233             $tvars{errcode} = 'MESSAGE';
234             LogError("action: class=$class, method=$method, FAULT: class not loaded");
235             }
236             }
237              
238             1;
239              
240             __END__