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__ |