File Coverage

blib/lib/XAO/Projects.pm
Criterion Covered Total %
statement 45 45 100.0
branch 11 16 68.7
condition 10 21 47.6
subroutine 13 13 100.0
pod 6 6 100.0
total 85 101 84.1


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             XAO::Projects - project context switcher for XAO
4              
5             =head1 SYNOPSIS
6              
7             use XAO::SimpleHash;
8             use XAO::Projects;
9              
10             my $fubar=new XAO::SimpleHash foo => 'bar';
11             XAO::Projects::create_project(fubar => $fubar);
12             XAO::Projects::set_current_project('fubar');
13              
14             ...
15              
16             ##
17             # Probably in different module..
18             #
19             my $pd=XAO::Projects::get_current_project();
20              
21             =head1 DESCRIPTION
22              
23             B
24              
25             This object holds all site-specific configuration values and provides
26             various useful methods that are not related to any particular
27             displayable object (see L).
28              
29             In mod_perl context this object is initialized only once for each apache
30             process and then is re-used every time until that process
31             die. SiteConfig keeps a cache of all site configurations and makes them
32             available on demand. It is perfectly fine that one apache process would
33             serve more then one site, they won't step on each other toes.
34              
35             =head1 UTILITY FUNCTIONS
36              
37             XAO::SiteConfig provides some utility functions that do not require
38             any configuration object context.
39              
40             =over
41              
42             =cut
43              
44             ###############################################################################
45             package XAO::Projects;
46 8     8   491 use strict;
  8         17  
  8         289  
47 8     8   44 use XAO::Utils qw(:args);
  8         41  
  8         792  
48 8     8   69 use XAO::Errors qw(XAO::Projects);
  8         19  
  8         47  
49              
50             ##
51             # Prototypes
52             #
53             sub create_project (%);
54             sub drop_project ($);
55             sub get_current_project ();
56             sub get_current_project_name ();
57             sub get_project ($);
58             sub set_current_project ($);
59              
60             ##
61             # Exporting
62             #
63 8     8   52 use Exporter;
  8         16  
  8         337  
64 8     8   48 use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
  8         15  
  8         851  
65             @ISA=qw(Exporter);
66             %EXPORT_TAGS=(
67             all => [qw(
68             create_project
69             drop_project
70             get_current_project
71             get_current_project_name
72             get_project
73             set_current_project
74             )],
75             );
76             @EXPORT_OK=@{$EXPORT_TAGS{all}};
77              
78             ##
79             # Package version for checks and reference
80             #
81 8     8   59 use vars qw($VERSION);
  8         26  
  8         778  
82             $VERSION=(0+sprintf('%u.%03u',(q$Id: Projects.pm,v 2.1 2005/01/13 22:34:34 am Exp $ =~ /\s(\d+)\.(\d+)\s/))) || die "Bad VERSION";
83              
84             ##
85             # Cache with all active project contexts and variable with current
86             # project name.
87             #
88 8     8   59 use vars qw(%projects_cache $current_project_name);
  8         15  
  8         4084  
89              
90             ###############################################################################
91              
92             =item create_project (%)
93              
94             XXX
95              
96             =cut
97              
98             sub create_project (%) {
99 7 50   7 1 397 shift if $_[0] eq 'XAO::Projects';
100 7         59 my $args=get_args(\@_);
101             my $name=$args->{name} ||
102 7   33     33 throw XAO::E::Projects "create_project - no 'name'";
103             my $obj=$args->{object} ||
104 7   33     24 throw XAO::E::Projects "create_project - no 'object'";
105              
106 7 100       111 $projects_cache{$name} &&
107             throw XAO::E::Projects "create_project - project '$name' already exists";
108              
109 6         33 $projects_cache{$name}=$obj;
110              
111 6 100       31 set_current_project($name) if $args->{set_current};
112              
113 6         25 $obj;
114             }
115              
116             ###############################################################################
117              
118             =item drop_project ($)
119              
120             XXX
121              
122             =cut
123              
124             sub drop_project ($) {
125 26 50   26 1 93 shift if $_[0] eq 'XAO::Projects';
126 26   33     155 my $name=shift ||
127             throw XAO::E::Projects "drop_project - no project name given";
128              
129 26         133 delete $projects_cache{$name};
130 26 100 100     180 $current_project_name=undef if defined($current_project_name) &&
131             $current_project_name eq $name;
132             }
133              
134             ###############################################################################
135              
136             =item get_current_project ()
137              
138             XXX
139              
140             =cut
141              
142             sub get_current_project () {
143 42   66 42 1 210 my $name=$current_project_name ||
144             throw XAO::E::Projects "get_current_project - no current project";
145 41         113 get_project($name);
146             }
147              
148             ###############################################################################
149              
150             =item get_current_project_name ()
151              
152             XXX
153              
154             =cut
155              
156             sub get_current_project_name () {
157 104     104 1 627 $current_project_name;
158             }
159              
160             ###############################################################################
161              
162             =item get_project ($)
163              
164             Looks into pre-initialized configurations list and returns object if
165             found or undef if not.
166              
167             Example:
168              
169             my $cf=XAO::Projects->get_projects('testsite');
170              
171             =cut
172              
173             sub get_project ($) {
174 45 50   45 1 384 shift if $_[0] eq 'XAO::Projects';
175 45   33     101 my $name=shift ||
176             throw XAO::E::Projects "get_project - no project name given";
177 45         164 $projects_cache{$name};
178             }
179              
180             ###############################################################################
181              
182             =item set_current_project ($)
183              
184             XXX
185              
186             =cut
187              
188             sub set_current_project ($) {
189 7 50   7 1 22 shift if $_[0] eq 'XAO::Projects';
190 7   33     18 my $name=shift ||
191             throw XAO::E::Projects "set_current_project - no project name given";
192 7 50       22 exists $projects_cache{$name} ||
193             throw XAO::E::Projects "set_current_project - no such project ($name)";
194 7         16 my $old_name=$current_project_name;
195 7         11 $current_project_name=$name;
196 7         16 $old_name;
197             }
198              
199             ###############################################################################
200             1;
201             __END__