File Coverage

blib/lib/Sakai/Nakamura/World.pm
Criterion Covered Total %
statement 108 168 64.2
branch 39 56 69.6
condition 2 3 66.6
subroutine 19 21 90.4
pod 4 10 40.0
total 172 258 66.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             package Sakai::Nakamura::World;
4              
5 1     1   1378 use 5.008008;
  1         3  
  1         39  
6 1     1   6 use strict;
  1         2  
  1         34  
7 1     1   4 use warnings;
  1         1  
  1         27  
8 1     1   5 use Carp;
  1         2  
  1         69  
9 1     1   1192 use Getopt::Long qw(:config bundling);
  1         12376  
  1         6  
10 1     1   1067 use Text::CSV;
  1         13641  
  1         8  
11 1     1   42 use Sakai::Nakamura;
  1         3  
  1         44  
12 1     1   6 use Sakai::Nakamura::Authn;
  1         1  
  1         27  
13 1     1   704 use Sakai::Nakamura::WorldUtil;
  1         2  
  1         54  
14              
15             require Exporter;
16              
17 1     1   5 use base qw(Exporter);
  1         2  
  1         1868  
18              
19             our @EXPORT_OK = ();
20              
21             our $VERSION = '0.13';
22              
23             #{{{sub new
24              
25             sub new {
26 2     2 1 1096 my ( $class, $authn, $verbose, $log ) = @_;
27 2 100       8 if ( !defined $authn ) { croak 'no authn provided!'; }
  1         38  
28 1         2 my $response;
29 1 50       6 $verbose = ( defined $verbose ? $verbose : 0 );
30 1         17 my $world = {
31 1         3 BaseURL => ${$authn}->{'BaseURL'},
32             Authn => $authn,
33             Message => q{},
34             Response => \$response,
35             Verbose => $verbose,
36             Log => $log
37             };
38 1         4 bless $world, $class;
39 1         4 return $world;
40             }
41              
42             #}}}
43              
44             #{{{sub set_results
45             sub set_results {
46 1     1 1 1999 my ( $world, $message, $response ) = @_;
47 1         4 $world->{'Message'} = $message;
48 1         4 $world->{'Response'} = $response;
49 1         3 return 1;
50             }
51              
52             #}}}
53              
54             #{{{sub add
55             sub add {
56 1     1 1 513 my ( $world, $id, $title, $description, $tags, $visibility, $joinability,
57             $world_template )
58             = @_;
59 1         11 my $res = Apache::Sling::Request::request(
60             \$world,
61             Sakai::Nakamura::WorldUtil::add_setup(
62             $world->{'BaseURL'}, $id,
63 1         4 ${ $world->{'Authn'} }->{'Username'}, $title,
64             $description, $tags,
65             $visibility, $joinability,
66             $world_template
67             )
68             );
69 0         0 my $success = Sakai::Nakamura::WorldUtil::add_eval($res);
70 0         0 my $message = "World: \"$id\" ";
71 0 0       0 $message .= ( $success ? 'added!' : 'was not added!' );
72 0         0 $world->set_results( "$message", $res );
73 0         0 return $success;
74             }
75              
76             #}}}
77              
78             #{{{sub add_from_file
79             sub add_from_file {
80 5     5 1 2625 my ( $world, $file, $fork_id, $number_of_forks ) = @_;
81 5 100       14 $fork_id = defined $fork_id ? $fork_id : 0;
82 5 100       13 $number_of_forks = defined $number_of_forks ? $number_of_forks : 1;
83 5         34 my $csv = Text::CSV->new();
84 5         381 my $count = 0;
85 5         9 my $number_of_columns = 0;
86 5         8 my @column_headings;
87 1 100 66 1   11 if ( defined $file && open my ($input), '<', $file ) {
  1         2  
  1         9  
  5         97  
88              
89 4         1604 while (<$input>) {
90 6 100       21 if ( $count++ == 0 ) {
    50          
91              
92             # Parse file column headings first to determine field names:
93 4 50       16 if ( $csv->parse($_) ) {
94 4         990 @column_headings = $csv->fields();
95              
96             # First field must be id:
97 4 100       52 if ( $column_headings[0] !~ /^[Ii][Dd]$/msx ) {
98 1         22 croak
99             'First CSV column must be the world ID, column heading must be "id". Found: "'
100             . $column_headings[0] . "\".\n";
101             }
102 3         14 $number_of_columns = @column_headings;
103             }
104             else {
105 0         0 croak 'CSV broken, failed to parse line: '
106             . $csv->error_input;
107             }
108             }
109             elsif ( $fork_id == ( $count++ % $number_of_forks ) ) {
110 2 50       8 if ( $csv->parse($_) ) {
111 2         399 my @columns = $csv->fields();
112 2         18 my $columns_size = @columns;
113              
114             # Check row has same number of columns as there were column headings:
115 2 100       7 if ( $columns_size != $number_of_columns ) {
116 1         17 croak
117             "Found \"$columns_size\" columns. There should have been \"$number_of_columns\".\nRow contents was: $_";
118             }
119 1         3 my $id = $columns[0];
120 1         3 my $title;
121             my $description;
122 0         0 my $tags;
123 0         0 my $visibility;
124 0         0 my $joinability;
125 0         0 my $world_template;
126              
127 1         6 for ( my $i = 1 ; $i < $number_of_columns ; $i++ ) {
128 7         12 my $heading = $column_headings[$i];
129 7 100       52 if ( $heading =~ /^[Tt][Ii][Tt][Ll][Ee]$/msx ) {
    100          
    100          
    100          
    100          
    100          
130 1         4 $title = $columns[$i];
131             }
132             elsif ( $heading =~
133             /^[Dd][Ee][Ss][Cc][Rr][Ii][Pp][Tt][Ii][Oo][Nn]$/msx
134             )
135             {
136 1         4 $description = $columns[$i];
137             }
138             elsif ( $heading =~ /^[Tt][Aa][Gg][Ss]$/msx ) {
139 1         54 $tags = $columns[$i];
140             }
141             elsif ( $heading =~
142             /^[Vv][Ii][Ss][Ii][Bb][Ii][Ll][Ii][Tt][Yy]$/msx )
143             {
144 1         4 $visibility = $columns[$i];
145             }
146             elsif ( $heading =~
147             /^[Jj][Oo][Ii][Nn][Aa][Bb][Ii][Ll][Ii][Tt][Yy]$/msx
148             )
149             {
150 1         3 $joinability = $columns[$i];
151             }
152             elsif ( $heading =~
153             /^[Ww][Oo][Rr][Ll][Dd][Tt][Ee][Mm][Pp][Ll][Aa][Tt][Ee]$/msx
154             )
155             {
156 1         4 $world_template = $columns[$i];
157             }
158             else {
159 1         19 croak
160             "Unsupported column heading \"$heading\" - please use: \"id\", \"title\", \"description\", \"tags\", \"visibility\", \"joinability\", \"worldtemplate\"";
161             }
162             }
163 0         0 $world->add( $id, $title, $description, $tags, $visibility,
164             $joinability, $world_template );
165 0         0 Apache::Sling::Print::print_result($world);
166             }
167             else {
168 0         0 croak q{CSV broken, failed to parse line: }
169             . $csv->error_input;
170             }
171             }
172             }
173 1 50       6 close $input or croak q{Problem closing input};
174             }
175             else {
176 1         14 croak 'Problem adding from file!';
177             }
178 1         21 return 1;
179             }
180              
181             #}}}
182              
183             #{{{ sub command_line
184             sub command_line {
185 0     0 0 0 my ( $class, @ARGV ) = @_;
186 0         0 my $nakamura = Sakai::Nakamura->new;
187 0         0 my $config = $class->config( $nakamura, @ARGV );
188 0         0 my $authn = new Sakai::Nakamura::Authn( \$nakamura );
189 0         0 return $class->run( $nakamura, $config );
190             }
191              
192             #}}}
193              
194             #{{{sub config
195              
196             sub config {
197 1     1 0 2 my ( $class, $nakamura, @ARGV ) = @_;
198 1         7 my $world_config = $class->config_hash( $nakamura, @ARGV );
199              
200 1 50       8 GetOptions(
201             $world_config, 'auth=s',
202             'help|?', 'log|L=s',
203             'man|M', 'pass|p=s',
204             'threads|t=s', 'url|U=s',
205             'user|u=s', 'verbose|v+',
206             'add|a', 'additions|A=s',
207             'copy|c', 'delete|d',
208             'exists|e', 'filename|n=s',
209             'local|l=s', 'move|m',
210             'property|P=s', 'remote|r=s',
211             'remote-source|S=s', 'replace|R',
212             'view|V', 'view-copyright=s',
213             'view-description=s', 'view-tags=s',
214             'view-title=s', 'view-visibility=s'
215             ) or $class->help();
216              
217 1         1930 return $world_config;
218             }
219              
220             #}}}
221              
222             #{{{sub config_hash
223              
224             sub config_hash {
225 1     1 0 3 my ( $class, $nakamura, @ARGV ) = @_;
226 1         2 my $add;
227             my $additions;
228 0         0 my $id;
229 0         0 my $title;
230 0         0 my $description;
231 0         0 my $tags;
232 0         0 my $visibility;
233 0         0 my $joinability;
234 0         0 my $world_template;
235 1         23 my %world_config = (
236             'auth' => \$nakamura->{'Auth'},
237             'help' => \$nakamura->{'Help'},
238             'log' => \$nakamura->{'Log'},
239             'man' => \$nakamura->{'Man'},
240             'pass' => \$nakamura->{'Pass'},
241             'threads' => \$nakamura->{'Threads'},
242             'url' => \$nakamura->{'URL'},
243             'user' => \$nakamura->{'User'},
244             'verbose' => \$nakamura->{'Verbose'},
245             'add' => \$add,
246             'additions' => \$additions,
247             'title' => \$title,
248             'description' => \$description,
249             'tags' => \$tags,
250             'visibility' => \$visibility,
251             'joinability' => \$joinability,
252             'world_template' => \$world_template
253             );
254              
255 1         5 return \%world_config;
256             }
257              
258             #}}}
259              
260             #{{{ sub help
261             sub help {
262              
263 1     1 0 32 print <<"EOF";
264             Usage: perl $0 [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
265             The following options are accepted:
266              
267             --add or -a (worldid) - add specified world.
268             --additions or -A (file) - file containing list of worlds to be added.
269             --auth (type) - Specify auth type. If ommitted, default is used.
270             --description or -d - description of world
271             --help or -? - view the script synopsis and options.
272             --joinability or -j (joinability) - Joinability of world.
273             --log or -L (log) - Log script output to specified log file.
274             --man or -M - view the full script documentation.
275             --pass or -p (password) - Password of user performing actions.
276             --threads or -t (threads) - Used with -A, defines number of parallel
277             processes to have running through file.
278             --tags or -T (tags) - tags for world
279             --title or -t (title) - title for world
280             --url or -U (URL) - URL for system being tested against.
281             --user or -u (username) - Name of user to perform any actions as.
282             --verbose or -v or -vv or -vvv - Increase verbosity of output.
283             --visibility or -V (visibility) - Visibility of world.
284             --worldTemplate or -w - World template to use.
285              
286             Options may be merged together. -- stops processing of options.
287             Space is not required between options and their arguments.
288             For full details run: perl $0 --man
289             EOF
290              
291 1         2 return 1;
292             }
293              
294             #}}}
295              
296             #{{{ sub man
297             sub man {
298 0     0 0 0 my ($world) = @_;
299              
300 0         0 print <<'EOF';
301             world perl script. Provides a means of managing worlds in nakamura from the command
302             line. The script also acts as a reference implementation for the World perl
303             library.
304              
305             EOF
306              
307 0         0 $world->help();
308              
309 0         0 print <<"EOF";
310             Example Usage
311              
312             * TODO: add examples
313              
314             perl $0 -U http://localhost:8080 -u admin -p admin
315             EOF
316              
317 0         0 return 1;
318             }
319              
320             #}}}
321              
322             #{{{sub run
323             sub run {
324 2     2 0 37 my ( $world, $nakamura, $config ) = @_;
325 2 100       8 if ( !defined $config ) {
326 1         18 croak 'No world config supplied!';
327             }
328 1         13 $nakamura->check_forks;
329 1         3 my $authn =
330             defined $nakamura->{'Authn'}
331 1 50       20 ? ${ $nakamura->{'Authn'} }
332             : new Sakai::Nakamura::Authn( \$nakamura );
333              
334 1         3 my $success = 1;
335              
336 1 50       8 if ( $nakamura->{'Help'} ) { $world->help(); }
  0 50       0  
    50          
337 0         0 elsif ( $nakamura->{'Man'} ) { $world->man(); }
  1         5  
338             elsif ( defined ${ $config->{'additions'} } ) {
339 0         0 my $message =
340 0         0 "Adding worlds from file \"" . ${ $config->{'additions'} } . "\":\n";
341 0         0 Apache::Sling::Print::print_with_lock( "$message", $nakamura->{'Log'} );
342 0         0 my @childs = ();
343 0         0 for my $i ( 0 .. $nakamura->{'Threads'} ) {
344 0         0 my $pid = fork;
345 0 0       0 if ($pid) { push @childs, $pid; } # parent
  0 0       0  
346             elsif ( $pid == 0 ) { # child
347             # Create a new separate user agent per fork in order to
348             # ensure cookie stores are separate, then log the user in:
349 0         0 $authn->{'LWP'} = $authn->user_agent( $nakamura->{'Referer'} );
350 0         0 $authn->login_user();
351 0         0 my $world =
352             new Sakai::Nakamura::World( \$authn, $nakamura->{'Verbose'},
353             $nakamura->{'Log'} );
354 0         0 $world->add_from_file( ${ $config->{'additions'} },
  0         0  
355             $i, $nakamura->{'Threads'} );
356 0         0 exit 0;
357             }
358             else {
359 0         0 croak "Could not fork $i!";
360             }
361             }
362 0         0 foreach (@childs) { waitpid $_, 0; }
  0         0  
363             }
364             else {
365 1         8 $authn->login_user();
366 1 50       2 if ( defined ${ $config->{'add'} } ) {
  1         4  
367 0         0 $world =
368             new Sakai::Nakamura::World( \$authn, $nakamura->{'Verbose'},
369             $nakamura->{'Log'} );
370 0         0 $success = $world->add(
371 0         0 ${ $config->{'add'} },
372 0         0 ${ $config->{'title'} },
373 0         0 ${ $config->{'description'} },
374 0         0 ${ $config->{'tags'} },
375 0         0 ${ $config->{'visibility'} },
376 0         0 ${ $config->{'joinability'} },
377 0         0 ${ $config->{'world_template'} }
378             );
379 0         0 Apache::Sling::Print::print_result($world);
380             }
381             else {
382 1         4 $world->help();
383 1         7 return 1;
384             }
385             }
386 0           return $success;
387             }
388              
389             #}}}
390              
391             1;
392              
393             __END__