File Coverage

blib/lib/Labyrinth/Support.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package Labyrinth::Support;
2              
3 2     2   6379 use warnings;
  2         4  
  2         60  
4 2     2   7 use strict;
  2         3  
  2         52  
5              
6 2     2   7 use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT @EXPORT_OK);
  2         2  
  2         374  
7             $VERSION = '5.30';
8              
9             =head1 NAME
10              
11             Labyrinth::Support - Common Function Library for Labyrinth.
12              
13             =head1 SYNOPSIS
14              
15             use Labyrinth::Support;
16              
17             =head1 DESCRIPTION
18              
19             The functions contain herein are commonly used throughout Labyrinth and
20             plugins.
21              
22             =head1 EXPORT
23              
24             AlignName
25             AlignClass
26             AlignSelect
27              
28             PublishState
29             PublishSelect
30             PublishAction
31              
32             FieldCheck
33             ParamCheck
34             AuthorCheck
35             MasterCheck
36              
37             AccessName
38             AccessID
39             AccessUser
40             AccessGroup
41             AccessSelect
42             AccessAllFolders
43             AccessAllAreas
44              
45             RealmCheck
46             RealmSelect
47             RealmName
48             RealmID
49              
50             ProfileSelect
51             FolderName
52             FolderID
53             FolderSelect
54             AreaSelect
55              
56             =cut
57              
58             # -------------------------------------
59             # Export Details
60              
61             require Exporter;
62             @ISA = qw(Exporter);
63              
64             %EXPORT_TAGS = (
65             'all' => [ qw(
66             AlignName AlignClass AlignSelect
67             PublishState PublishSelect PublishAction
68             FieldCheck ParamCheck AuthorCheck MasterCheck
69             AccessName AccessID AccessUser AccessGroup AccessSelect
70             AccessAllFolders AccessAllAreas
71             RealmCheck RealmSelect RealmName RealmID
72             ProfileSelect FolderName FolderID FolderSelect AreaSelect
73             ) ]
74             );
75              
76             @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
77             @EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
78              
79             # -------------------------------------
80             # Library Modules
81              
82 2     2   12 use Time::Local;
  2         2  
  2         122  
83              
84 2     2   7 use Labyrinth::Audit;
  2         4  
  2         255  
85 2     2   79 use Labyrinth::Globals;
  0            
  0            
86             use Labyrinth::Groups;
87             use Labyrinth::MLUtils;
88             use Labyrinth::Session;
89             use Labyrinth::Writer;
90             use Labyrinth::Variables;
91              
92             # -------------------------------------
93             # The Subs
94              
95             =head1 FUNCTIONS
96              
97             =over 4
98              
99             =item PublishState
100              
101             Returns the name of the current publish state, given the numeric state.
102              
103             =item PublishSelect
104              
105             Provides a dropdown selection box, as a XHTML code snippet, of the currently
106             available publishing states.
107              
108             =item PublishAction
109              
110             Provides a dropdown selection box, as a XHTML code snippet, of the currently
111             accessible publishing states.
112              
113             =cut
114              
115             my %publishstates = (
116             1 => {Action => 'Draft', State => 'Draft' },
117             2 => {Action => 'Submit', State => 'Submitted' },
118             3 => {Action => 'Publish', State => 'Published' },
119             4 => {Action => 'Archive', State => 'Archived' },
120             );
121             my @states = map {{'id'=>$_,'value'=> $publishstates{$_}->{State}}} sort keys %publishstates;
122              
123             sub PublishState {
124             my $state = shift;
125             return '' unless($state);
126             return $publishstates{$state}->{State};
127             }
128              
129              
130             sub PublishSelect {
131             my ($opt,$blank) = @_;
132             my @list = @states;
133             unshift @list, {id=>0,value=>'Select Status'} if(defined $blank && $blank == 1);
134             DropDownRows($opt,'publish','id','value',@list);
135             }
136              
137             sub PublishAction {
138             my $opt = shift || 1;
139             my $ack = shift || -1;
140              
141             my $html = qq{
142             foreach (sort keys %publishstates) {
143             unless($ack == -1) {
144             next if(!$ack && $_ != $opt);
145             next if($_ < $opt || $_ > $opt+1);
146             }
147             $html .= "
148             $html .= ' selected="selected"' if($opt == $_);
149             $html .= ">$publishstates{$_}->{Action}";
150             }
151              
152             $html .= "";
153             return $html;
154             }
155              
156             my %alignments = (
157             0 => { name => 'none', class => 'nail' },
158             1 => { name => 'left', class => 'left' },
159             2 => { name => 'centre', class => 'centre' },
160             3 => { name => 'right', class => 'right' },
161             4 => { name => 'left (no wrap)', class => 'lnowrap' },
162             5 => { name => 'right (no wrap)', class => 'rnowrap' },
163             );
164             my @alignments = map {{'id'=>$_,'value'=> $alignments{$_}->{name}}} sort keys %alignments;
165              
166             =item AlignName
167              
168             Returns the name of the given alignment type, defaults to 'none'.
169              
170             =item AlignClass
171              
172             Returns the class of the given alignment type, defaults to 'nail'.
173              
174             =item AlignSelect
175              
176             Provides a dropdown selection box, as a XHTML code snippet, of the currently
177             available alignment states.
178              
179             =cut
180              
181             sub AlignName {
182             my $opt = shift || 1;
183             return $alignments{$opt}->{name};
184             }
185              
186             sub AlignClass {
187             my $opt = shift || 1;
188             return $alignments{$opt}->{class};
189             }
190              
191             sub AlignSelect {
192             my $opt = shift || 0;
193             my $num = shift || 0;
194             DropDownRows($opt,"ALIGN$num",'id','value',@alignments);
195             }
196              
197             =item AuthorCheck
198              
199             Checks whether the current user is the author of the data requested, or has
200             permissions to allow them to access the data. If not sets the BADACCESS error
201             code, otherwise retrieves the data.
202              
203             =cut
204              
205             sub AuthorCheck {
206             my ($key,$id,$permission) = @_;
207             return 1 unless($cgiparams{$id}); # if the id key doesn't exist, this is likely to be a new entry
208              
209             $permission = ADMIN unless(defined $permission);
210              
211             my @rows = $dbi->GetQuery('hash',$key,$cgiparams{$id});
212             return 0 unless(@rows);
213              
214             $tvars{data}{$_} = $rows[0]->{$_} for(keys %{$rows[0]});
215              
216             return 1 if(Authorised($permission));
217             return 1 if($rows[0]->{userid} && $rows[0]->{userid} == $tvars{'loginid'});
218              
219             $tvars{errcode} = 'BADACCESS';
220             return 0;
221             }
222              
223             =item MasterCheck
224              
225             Ensure only a Master user can access a Master user details.
226              
227             =cut
228              
229             sub MasterCheck {
230             return 1 if( !$cgiparams{userid} || ! Authorised(MASTER,$cgiparams{userid}) );
231             return 1 if( Authorised(MASTER,$cgiparams{userid}) && Authorised(MASTER,$tvars{'loginid'}) );
232             $tvars{errcode} = 'BADACCESS';
233             return 0;
234             }
235              
236             =item FieldCheck(\@allfields,\@mandatory)
237              
238             Stores all the input data listed in @allfields, then checks that all the fields
239             listed in @mandatory are provided. Any errors found during parameter parsing
240             both for missing mandatory fields and via Data::FormValidator are then flagged
241             and the error code set.
242              
243             =item ParamCheck(\%fields)
244              
245             Cleans data inputs, then stores all the input data fields in $tvars{data}. All
246             mandatory fields are validated to ensure each has a value. Any errors found
247             during parameter parsing both for missing mandatory fields and via
248             Data::FormValidator are then flagged and the error code set.
249              
250             The fields hash contains a list of fields, with the keys 'type' and 'html'.
251             'type' indicates whether the field is mandatory (1) or optional (0). 'html'
252             indicates the level of cleaning required:
253              
254             my %fields = (
255             linkid => { type => 0, html => 0 },
256             catid => { type => 0, html => 0 },
257             href => { type => 1, html => 1 },
258             title => { type => 1, html => 3 },
259             body => { type => 0, html => 2 },
260             );
261              
262             # type: 0 = optional, 1 = mandatory
263             # html: 0 = none, 1 = text, 2 = textarea, 3 = no links
264              
265             '0' should only be used if previous parameter validation via
266             Data::FormValidator has already ensured that only legal characters are used.
267              
268             '1' removes all HTML tags.
269              
270             '2' removes disallowed HTML tags and cleans up many tags and whitespace.
271              
272             '3' removes anything that looks like a link or script tag, with the aim of
273             preventing a XSS attack.
274              
275              
276             =cut
277              
278             sub FieldCheck {
279             my ($allfields,$mandatory) = @_;
280              
281             # store base list for re-edit page
282             foreach (@$allfields) {
283             # automatically turn arrays into strings, in case someone is trying
284             # to subvert the data input process. known arrays are correctly stored
285             # appropriately elsewhere.
286             $tvars{data}->{$_} = join("|",CGIArray($_));
287             }
288              
289             # check for mandatory fields
290             my $errors = 0;
291             foreach (@$mandatory) {
292             if(defined $cgiparams{$_} && exists $cgiparams{$_} && $cgiparams{$_}) {
293             # nothing
294             } else {
295             LogDebug("FieldCheck: mandatory missing - [$_]");
296             $tvars{data}->{$_.'_err'} = ErrorSymbol();
297             $errors++;
298             $tvars{errcode} = 'ERROR';
299             }
300             }
301              
302             # check for invalid fields
303             for my $z (keys %cgiparams) {
304             next unless($z =~ /err_(.*)/);
305             my $x = $1;
306             $tvars{data}->{$x . '_err'} = ErrorSymbol();
307             $errors++;
308             $tvars{errcode} = 'ERROR';
309             }
310              
311             return($errors);
312             }
313              
314             sub ParamCheck {
315             my ($fields) = @_;
316             my $errors = 0;
317              
318             for my $key (keys %$fields) {
319              
320             # clean up cgi parameters
321             if($fields->{$key}{html} == 1) { $cgiparams{$key} = CleanHTML($cgiparams{$key}) }
322             elsif($fields->{$key}{html} == 2) { $cgiparams{$key} = CleanTags($cgiparams{$key}) }
323             elsif($fields->{$key}{html} == 3) { $cgiparams{$key} = CleanLink($cgiparams{$key}) }
324              
325             # store field
326            
327             # automatically turn arrays into strings, in case someone is trying
328             # to subvert the data input process. known arrays are correctly stored
329             # appropriately elsewhere.
330             $tvars{data}->{$_} = join("|",CGIArray($_));
331              
332             # skip checks if optional field
333             next unless($fields->{$key}{type});
334              
335             # mandatory fields must contain values
336             next if(defined $cgiparams{$_} && exists $cgiparams{$_} && $cgiparams{$_});
337              
338             # if we get here, record missing field
339             LogDebug("FieldCheck: mandatory missing - [$_]");
340             $tvars{data}->{$_.'_err'} = ErrorSymbol();
341             $errors++;
342             $tvars{errcode} = 'ERROR';
343             }
344              
345             # check for invalid fields
346             for my $z (keys %cgiparams) {
347             next unless($z =~ /err_(.*)/);
348             my $x = $1;
349             $tvars{data}->{$x . '_err'} = ErrorSymbol();
350             $errors++;
351             $tvars{errcode} = 'ERROR';
352             }
353              
354             return($errors);
355             }
356              
357             =item AccessName
358              
359             Returns the access permission name, given the access id.
360              
361             =item AccessID
362              
363             Returns the access id, given the access permission name.
364              
365             =item AccessUser
366              
367             Returns whether the current user has access at the given level of permissions.
368             Default permission level is ADMIN. Returns 1 if permission is granted, 0
369             otherwise.
370              
371             =item AccessGroup
372              
373             Returns whether the current user has access to the given group. Returns 1 if
374             yes, 0 otherwise.
375              
376             =item AccessSelect
377              
378             Provides a dropdown selection box, as a XHTML code snippet, of the currently
379             available access states.
380              
381             =item AccessAllFolders
382              
383             Return list of folders current user has access to.
384              
385             =item AccessAllAreas
386              
387             Return list of areas current user has access to.
388              
389             =cut
390              
391             sub AccessName {
392             my $value = shift;
393             LoadAccess();
394             return $settings{access}{ids}{$value};
395             }
396              
397             sub AccessID {
398             my $value = shift;
399             LoadAccess();
400             return $settings{access}{names}{$value};
401             }
402              
403             sub AccessUser {
404             my $permission = shift;
405             $permission = ADMIN unless(defined $permission);
406              
407             return 1 if(Authorised($permission));
408              
409             $tvars{errcode} = 'BADACCESS';
410             return 0;
411             }
412              
413             sub AccessGroup {
414             my %hash = @_;
415             my $groupid = $hash{ID} || GetGroupID($hash{NAME});
416             return 0 unless($groupid); # this is not bad access, the group may have been deleted
417              
418             return 1 if UserInGroup($groupid);
419              
420             $tvars{errcode} = 'BADACCESS';
421             return 0;
422             }
423              
424             sub AccessSelect {
425             my $opt = shift || 0;
426             my $name = shift || 'accessid';
427             my $max = Authorised(MASTER) ? MASTER : ADMIN;
428             my @rows = $dbi->GetQuery('hash','AllAccess',$max);
429             DropDownRows($opt,$name,'accessid','accessname',@rows);
430             }
431              
432             sub AccessAllFolders {
433             my $userid = shift || $tvars{loginid};
434             my $access = shift || PUBLISHER;
435             my $groups = getusergroups($userid);
436             my @rows = $dbi->GetQuery('array','GetFolderAccess',
437             {groups=>$groups,userid=>$userid,access=>$access});
438             my @folders = map {$_->[0]} @rows;
439             return join(',',@folders);
440             }
441              
442             sub AccessAllAreas {
443             my @rows = $dbi->GetQuery('array','AllAreas');
444             my @areas = map {"'$_->[0]'"} @rows;
445             return join(',',@areas);
446             }
447              
448             =item RealmCheck
449              
450             Checks whether the given realm is known within the system.
451              
452             =item RealmSelect
453              
454             Provides a dropdown selection box, as a XHTML code snippet, of the currently
455             available realms.
456              
457             =item RealmName
458              
459             Returns the name of a realm, given a realm id.
460              
461             =item RealmID
462              
463             Returns the id of a realm, given a realm name.
464              
465             =cut
466              
467             sub RealmCheck {
468             while(@_) {
469             my $realm = shift;
470             return 1 if($realm eq $tvars{realm});
471             }
472              
473             $tvars{errcode} = 'BADACCESS';
474             return 0; # failed
475             }
476              
477             sub RealmSelect {
478             my $opt = shift;
479             my @rows = $dbi->GetQuery('hash','AllRealms');
480             DropDownRows($opt,'realmid','realmid','name',@rows);
481             }
482              
483             sub RealmName {
484             my $id = shift;
485             my @rows = $dbi->GetQuery('hash','GetRealmByID',$id);
486             return $rows[0]->{realm};
487             }
488              
489             sub RealmID {
490             my $name = shift;
491             my @rows = $dbi->GetQuery('hash','GetRealmByName',$name);
492             return $rows[0]->{realmid};
493             }
494              
495             =item ProfileSelect
496              
497             Returns a dropdown list for the current list of profiles.
498              
499             =item FolderID
500              
501             Returns the folder id, given the folder name.
502              
503             =item FolderName
504              
505             Returns the name of a folder, given a folder id.
506              
507             =item FolderSelect
508              
509             Provides a dropdown selection box, as a XHTML code snippet, of the currently
510             available folders.
511              
512             =cut
513              
514             sub ProfileSelect {
515             my $opt = shift || 0;
516             my $name = shift || 'profile';
517             LoadProfiles();
518             my @rows = map { { profile => $_ } } sort grep {$_ ne $settings{profiles}{default} } keys %{$settings{profiles}{profiles}};
519             unshift @rows, { profile => $settings{profiles}{default} } if($settings{profiles}{default});
520             unshift @rows, { profile => 'Select Profile' };
521             DropDownRows($opt,$name,'profile','profile',@rows);
522             }
523              
524             sub FolderID {
525             my $opt = shift || return;
526             my @rows = $dbi->GetQuery('hash','GetFolderByPath',$opt);
527             return @rows ? $rows[0]->{folderid} : undef;
528             }
529              
530             sub FolderName {
531             my $opt = shift || return;
532             my @rows = $dbi->GetQuery('hash','GetFolder',$opt);
533             return @rows ? $rows[0]->{foldername} : undef;
534             }
535              
536             sub FolderSelect {
537             my $opt = shift || 0;
538             my $name = shift || 'folderid';
539             my @rows = $dbi->GetQuery('hash','AllFolders');
540             DropDownRows($opt,$name,'folderid','foldername',@rows);
541             }
542              
543             =item AreaSelect
544              
545             Provides a dropdown selection box, as a XHTML code snippet, of the currently
546             available areas.
547              
548             =cut
549              
550             sub AreaSelect {
551             my $opt = shift;
552             my @rows = $dbi->GetQuery('hash','AllAreas');
553             DropDownRows($opt,'area','areaid','title',@rows);
554             }
555              
556             1;
557              
558             __END__