]> git.p6c8.net - selfforum.git/blob - selfforum-cgi/shared/Arc/Archive.pm
made the code more readable (splittet sub cut_tail into several subs, added comments)
[selfforum.git] / selfforum-cgi / shared / Arc / Archive.pm
1 package Arc::Archive;
2
3 ################################################################################
4 # #
5 # File: shared/Arc/Archive.pm #
6 # #
7 # Authors: Andre Malo <nd@o3media.de>, 2001-06-16 #
8 # #
9 # Description: Severance of Threads and archiving #
10 # #
11 ################################################################################
12
13 use strict;
14 use vars qw(
15 @EXPORT
16 $VERSION
17 );
18
19 use Arc::Test;
20 use Lock;
21 use Posting::_lib qw(
22 get_all_threads
23 create_forum_xml_string
24 parse_xml_file
25 parse_single_thread
26 get_message_node
27 get_body_node
28 save_file
29 KEEP_DELETED
30 );
31 use Posting::Cache;
32 use Time::German 'localtime';
33
34 use XML::DOM;
35
36 ################################################################################
37 #
38 # Version check
39 #
40 $VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
41
42 ################################################################################
43 #
44 # Export
45 #
46 use base qw(Exporter);
47 @EXPORT = qw(cut_tail);
48
49 ### delete_no_archived () ######################################################
50 #
51 # remove no archived branches vom thread
52 #
53 # Params: $xml - XML::DOM::Document node
54 # $msg - arrayref - messages
55 # $percent - voting limit (percent)
56 #
57 # Return: ~none~
58 #
59 sub delete_no_archived ($) {
60 my $par = shift;
61
62 my ($xml, $sum, $tid, $msg, $percent) = map {$par->{$_}}
63 qw( xml sum tid msg percent);
64
65 # $oldlevel: contains the level of last checked msg
66 # @path : contains the current branch
67 # %archive : contains the mids, that will be archived
68 # %hidden : contains the invisible mids
69 #
70 my ($oldlevel, @path, %archive, %hidden) = (0, 0);
71
72 # check all messages of thread
73 #
74 for my $z (0..$#{$msg}) {
75
76 if ($msg -> [$z] -> {level} > $oldlevel) {
77 # this msg is a child of the last one
78 #
79 push @path => $z;
80 $oldlevel = $msg -> [$z] -> {level};
81 }
82
83 elsif ($msg -> [$z] -> {level} < $oldlevel) {
84 # this starts a new subbranch (-1+ level(s))
85 #
86
87 # remove last msg (incl. kids), that is on same level
88 #
89 splice @path, $msg -> [$z] -> {level};
90 push @path => $z;
91 $oldlevel = $msg -> [$z] -> {level};
92 }
93
94 else {
95 # the msg is a sister of the last one
96 #
97 $path[-1] = $z;
98 }
99
100 # 'archive' is an admin flag
101 # if set, the message (incl. branch) MUST be archived
102 #
103 if (defined $msg->[$z]->{archive} and $msg->[$z]->{archive}) {
104 $archive{$msg->[$_]->{mid}} = 1 for (@path);
105 }
106
107 # notice invisble messages
108 # while they are in @path and archive flag is not set,
109 # they and their kids WON'T be archived
110 #
111 $hidden{$z} = 1 if ($msg->[$z]->{deleted});
112
113 # if 'archive' is NOT set and message not deleted,
114 #
115 unless ($msg->[$z]->{archive} or $msg->[$z]->{deleted}) {
116 my $key = $sum->{$tid}->{$msg->[$z]->{mid}};
117
118 # ...and they've voted enough, it will be archived
119 #
120 if ($percent == 0 or ($key->{views} and ($key->{votings} * 100 / $key->{views}) >= $percent)) {
121 my $hidden_in_path;
122
123 # check on hidden messages in @path
124 #
125 for (@path) {
126 if ($hidden{$_}) {
127 $hidden_in_path = 1;
128 last;
129 }
130 }
131
132 # set archive-flag for messages in @path,
133 # unless a parent message is hidden
134 #
135 unless ($hidden_in_path) {
136 $archive{$msg->[$_]->{mid}} = 1 for (@path);
137 }
138 }
139 }
140 }
141
142 # now remove messages without 'archive'-flag
143 # from thread xml
144 #
145 for (reverse grep {!$archive{$_->{mid}}} @$msg) {
146 my $h = get_message_node($xml, "t$tid", 'm'.$_->{mid});
147
148 # remove message entry
149 #
150 $h -> getParentNode -> removeChild ($h);
151
152 # remove message text
153 #
154 $h = get_body_node($xml, 'm'.$_->{mid});
155 $h -> getParentNode -> removeChild ($h);
156 }
157 }
158
159 ### create_arcdir () ###########################################################
160 #
161 # check, if specific directories for year and month exist, create
162 # it, if necessary
163 #
164 # Params: $path - archive root
165 # $time - Thread time (GMT)
166 #
167 # Return: List: $path - /path/to/ to archived thread file
168 # $error - error or undef
169 #
170 sub create_arcdir ($$) {
171 my ($path, $time) = @_;
172
173 my ($month, $year) = (localtime ($time))[4,5];
174
175 # use the 'real' values for directory names
176 #
177 $month++; $year+=1900;
178
179 my $yeardir = $path . $year;
180 my $monthdir = $yeardir . '/' . $month;
181 my $monthpath = $monthdir . '/';
182
183 mkdir $yeardir, 0777 unless (-d $yeardir);
184 return ('', "could not create directory '$yeardir'") unless (-d $yeardir);
185
186 mkdir $monthdir, 0777 unless (-d $monthdir);
187 return ('', "could not create directory '$monthdir'") unless (-d $monthdir);
188
189 # return path, successfully created
190 #
191 $monthpath;
192 }
193
194 ### process_threads () #########################################################
195 #
196 # process obsolete threads
197 # (transmit views/votings from cache, do archive, if necessary)
198 #
199 # Params: $par - hash reference
200 # (opt, cache, failed, obsolete, messagePath,
201 # archivePath, adminDefault)
202 #
203 # Return: ~none~
204 #
205 sub process_threads ($) {
206 my $par = shift;
207
208 my ($opt, $failed, $obsolete, $cache) = map {$par->{$_}} qw
209 ( opt failed obsolete cache);
210
211 if ($opt->{exArchiving}) {
212
213 # yes, we do archive
214 #
215 my $sum = $cache -> summary;
216 if ($sum) {
217
218 # iterate over all obsolete threads, that are not failed yet
219 #
220 for my $tid (grep {not exists ($failed->{$_})} @$obsolete) {
221 my $xml = parse_xml_file ($par->{messagePath}."t$tid.xml");
222
223 unless ($xml) {
224 # xml parse error
225 #
226 $failed->{$tid} = 'could not parse thread file.';
227 }
228 else {
229 # ok, parse thread
230 #
231 my $tnode = $xml -> getElementsByTagName ('Thread') -> item(0);
232 my $msg = parse_single_thread ($tnode, KEEP_DELETED);
233
234 if ($opt->{archiving} eq 'UserVotings') {
235
236 # filter out the bad stuff
237 #
238 delete_no_archived ({
239 xml => $xml,
240 sum => $sum,
241 tid => $tid,
242 msg => $msg,
243 percent => $par->{adminDefault}->{Voting}->{Limit}
244 });
245 }
246
247 # save back xml file (into archive)
248 #
249 if ($tnode -> hasChildNodes) {
250
251 # insert views and votings counter
252 #
253 for ($tnode -> getElementsByTagName ('Message')) {
254 my ($id) = $_ -> getAttribute ('id') =~ /(\d+)/;
255 $_ -> setAttribute ('views' => $sum->{$tid}->{$id}->{views});
256 $_ -> setAttribute ('votings' => $sum->{$tid}->{$id}->{votings});
257 }
258
259 # create archive dir, unless exists
260 #
261 my ($path, $error) = create_arcdir ($par -> {archivePath}, $msg->[0]->{time});
262
263 if ($error) {
264 $failed->{$tid} = $error;
265 }
266 else {
267 # save thread file
268 #
269 my $file = "${path}t$tid.xml";
270 save_file ($file => \($xml -> toString)) or $failed->{$tid} = "could not save '$file'";
271 }
272 }
273 }
274 }
275 }
276 else {
277 @$failed{@$obsolete} = 'could not load summary';
278 }
279 }
280 }
281
282 ### cut_tail () ################################################################
283 #
284 # shorten the main file and archive, if necessary
285 #
286 # Params: $param - hash reference
287 # (forumFile, messagePath, archivePath, lockFile, adminDefault,
288 # cachePath)
289 #
290 # Return: hash reference - empty if all right done
291 #
292 sub cut_tail ($) {
293 my $param = shift;
294 my %failed;
295
296 if (
297 $param->{adminDefault}->{Severance}->{severance} ne 'instant' or
298 $param->{adminDefault}->{Instant}->{execute}
299 ) {
300 # run only one instance at the same time
301 # (exlusive lock on sev_lock)
302 #
303 my $sev = new Lock ($param->{lockFile});
304 if ($sev -> lock(LH_EXCL)) {
305
306 # lock and parse forum main file
307 #
308 my $forum = new Lock ($param->{forumFile});
309 if ($forum -> lock (LH_EXCL)) {
310 my (
311 $threads,
312 $last_thread,
313 $last_message,
314 $dtd
315 ) = get_all_threads ($forum->filename, KEEP_DELETED);
316
317 # get obsolete threads...
318 #
319 my $obsolete = get_obsolete_threads ({
320 parsedThreads => $threads,
321 adminDefault => $param->{adminDefault}
322 });
323
324 unless (@$obsolete) {
325 # nothing to cut - we're ready
326 #
327 $forum -> unlock;
328 }
329 else {
330 # ...and delete them from main
331 #
332 my %obsolete;
333 for (@$obsolete) {
334 $obsolete{$_} = $threads->{$_};
335 delete $threads->{$_};
336 }
337
338 # save it back...
339 #
340 my $saved = save_file (
341 $param -> {forumFile},
342 create_forum_xml_string (
343 $threads,
344 {
345 dtd => $dtd,
346 lastMessage => $last_message,
347 lastThread => $last_thread
348 }
349 )
350 );
351
352 # ...and masterlock the obsolete thread files
353 #
354 if ($saved) {
355 for (@$obsolete) {
356 new Lock($param->{messagePath}."t$_.xml")->lock(LH_MASTER) or $failed{$_} = 'could not set master lock';
357 }
358 }
359
360 # release forum main file...
361 #
362 $forum -> unlock;
363
364 if ($saved) {
365 # ...and now process thread files
366 #
367 my $sev_opt = ($param -> {adminDefault} -> {Severance} -> {severance} eq 'instant')
368 ? $param -> {adminDefault} -> {Instant} -> {Severance}
369 : ($param -> {adminDefault} -> {Severance});
370
371 my $cache = new Posting::Cache ($param->{cachePath});
372
373 process_threads ({
374 opt => $sev_opt,
375 cache => $cache,
376 failed => \%failed,
377 obsolete => $obsolete,
378 messagePath => $param->{messagePath},
379 archivePath => $param->{archivePath},
380 adminDefault => $param->{adminDefault}
381 });
382
383
384 # delete processed files, that are not failed
385 #
386 for (grep {not exists($failed{$_})} @$obsolete) {
387 unlink ($param->{messagePath}."t$_.xml") or $failed{$_} = 'could not delete thread file';
388 #file_removed ($param->{messagePath}."t$_.xml");
389 }
390 $cache -> delete_threads (@$obsolete);
391 $cache -> garbage_collection;
392 }
393 }
394 # we're ready, tell this other instances
395 #
396 $sev -> unlock;
397 }
398 }
399 }
400
401 # return
402 \%failed;
403 }
404
405 # keep 'require' happy
406 1;
407
408 #
409 #
410 ### end of Arc::Archive ########################################################

patrick-canterino.de