home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / fcn-tree.pl < prev    next >
Text File  |  2009-11-06  |  12KB  |  406 lines
  1. # FILE: fcn-tree.pl
  2. # DESCRIPTION: Tree file manipulations
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### pages_upward_update
  20. ###
  21. ### Updates parent pages with new information from the tree file.  Send
  22. ### in a list of child pages as an array reference in $pages...
  23. ###
  24.  
  25. sub pages_upward_update {
  26.     my ($tree_file_in, $cat_array, $pages, $args) = @_;
  27.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  28.     undef my $do_nums;
  29.     foreach my $i (@{ $pages }) {
  30.         my $parents = tree_build_parents_of($tree_file_in, $cat_array, $i);
  31.         foreach my $l (@{ $parents }) {
  32.             $do_nums->{$l} += 1;
  33.         }
  34.         $do_nums->{$i} += 1 if $args->{do_page};
  35.     }
  36.     foreach my $i (keys(%{ $do_nums })) {
  37.         my $rescode = lock("--REGENERATE-SUBTOPICS--", "$DCONF->{message_dir}/$tree_file_in->[0]->{topic}/$i.$DCONF->{ext}");
  38.         if ($rescode == 1) {
  39.             my $pref = GetPage($tree_file_in->[0]->{topic}, $i);
  40.             $pref->{general}->{subtopic_raw} = 0;
  41.             $pref->{sublist} = expand_sublist($pref->{sublist}, $tree_file_in->[0]->{topic}, $tree_file_in);
  42.             SetPage($pref, { unlock => 1} );
  43.         }
  44.     }
  45. }
  46.  
  47. ###
  48. ### tree_remove_page
  49. ###
  50. ### Updates the tree file to reflect one or more pages being removed.  Also
  51. ### handles deleting child pages and it works for links.  Send entries for
  52. ### pages being removed.
  53. ###
  54.  
  55. sub tree_remove_page {
  56.     my ($tfi, $cat_array, $pages_to_remove, $p) = @_;
  57.     $cat_array = tree_categorize($tfi) if ! defined $cat_array;
  58.     my @REMOVED = ();
  59.     my @SAVED = ();
  60.     my %c = ref $pages_to_remove eq 'HASH' ? %{$pages_to_remove} : map { $_, 1 } split(/,/, $pages_to_remove);
  61.     foreach my $line (@{ $tfi }) {
  62.         if ($c{$line->{page}} || $c{$line->{parent}}) {
  63.             push @REMOVED, $line;
  64.             $c{$line->{page}} = 1;
  65.         } else {
  66.             push @SAVED, $line;
  67.         }
  68.     }
  69.     my @pg = ();
  70.     foreach my $line (@REMOVED) {
  71.         push @pg, split(/,/, $line->{post_list});
  72.     }
  73.     my $tf = \@SAVED;
  74.     my $ca = tree_categorize(\@SAVED);
  75.     ($tf, $ca) = tree_upward_update($tf, $ca, $p, { metoo => 1, posts => join("", "-", scalar(@pg)), subs => join("", "-", scalar(@REMOVED)) }) if $p;    
  76.     return ($tf, $ca, \@pg, \@REMOVED);
  77. }
  78.  
  79. ###
  80. ### tree_remove_message
  81. ###
  82. ### Updates the tree to reflect one or more messages removed -- optimized for
  83. ### use when deleting messages from a page either by pruning or deleting.
  84. ### Send messages being removed as an array reference with the following:
  85. ###        page =>        Page from which messages are being removed
  86. ###        messages =>    Comma-separated list of messages to be removed
  87. ###
  88.  
  89. sub tree_remove_message {
  90.     my ($tree_file_in, $cat_array, $messages_being_removed) = @_;
  91.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  92.     foreach my $i (@{ $messages_being_removed }) {
  93.         my ($p, $m) = ($i->{page}, $i->{messages});
  94.         my $ind = $cat_array->{array_pos}->{$p};
  95.         my $fpl = $tree_file_in->[$ind]->{post_list};
  96.         my $rem = 0;
  97.         undef my $nix;
  98.         foreach my $j (split(/,/, $m)) {
  99.             $nix->{$j} = 1;
  100.         }
  101.         my @leave = ();
  102.         foreach my $j (split(/,/, $fpl)) {
  103.             if ($nix->{$j}) {
  104.                 $rem += 1;
  105.             } else {
  106.                 push (@leave, $j);
  107.             }
  108.         }
  109.         $tree_file_in->[$ind]->{post_list} = join(",", @leave);
  110.         ($tree_file_in, $cat_array) = tree_upward_update($tree_file_in, $cat_array, $p, { metoo => 1, posts => "-$rem" }) if $rem;
  111.     }
  112.     return ($tree_file_in, $cat_array);
  113. }
  114.  
  115. ###
  116. ### tree_subtopic_reorder
  117. ###
  118. ### Performs reordering according to user-supplied information
  119. ###
  120.  
  121. sub tree_subtopic_reorder {
  122.     my ($tree_file_in, $cat_array, $starting, $coderef, $sor) = @_;
  123.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  124.     my $tbco = tree_build_children_of($tree_file_in, $cat_array, $starting);
  125.     my @sor = sort {&{$coderef}} @{$tbco};
  126.     @sor = tree_flatten(\@sor);
  127.     @sor = sort sort_archive_method @sor if $sor && $GLOBAL_OPTIONS->{sort_archive_method_on};
  128.     unshift @sor, $cat_array->{page}->{$starting};
  129.     splice(@{ $tree_file_in }, $cat_array->{array_pos}->{$starting}, scalar(@sor), @sor);
  130.     return ($tree_file_in, $cat_array);
  131. }
  132.  
  133. ###
  134. ### tree_active_reorder
  135. ###
  136. ### Performs active reordering (reorder by last modified date)
  137. ###
  138.  
  139. sub tree_active_reorder {
  140.     my ($tree_file_in, $cat_array, $starting, $args) = @_;
  141.     my $coderef = sub { return $a->[0]->{lastmod} <=> $b->[0]->{lastmod} };
  142.     return tree_subtopic_reorder($tree_file_in, $cat_array, $starting, $coderef, 1);
  143. }
  144.  
  145. ###
  146. ### tree_flatten
  147. ###
  148. ### Flattens tree information
  149. ###
  150.  
  151. sub tree_flatten {
  152.     my ($array_in) = @_;
  153.     my @aout = ();
  154.     foreach my $x (@{$array_in}) {
  155.         if (ref $x eq 'ARRAY') {
  156.             push @aout, tree_flatten($x);
  157.         } else {
  158.             push @aout, $x;
  159.         }
  160.     }
  161.     return @aout;    
  162. }
  163.  
  164. ###
  165. ### tree_upward_update
  166. ###
  167. ### Updates the tree in an upward direction
  168. ###
  169.  
  170. sub tree_upward_update {
  171.     my ($tree_file_in, $cat_array, $starting, $args) = @_;
  172.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  173.     if ($args->{metoo}) {
  174.         $tree_file_in->[$cat_array->{array_pos}->{$starting}] = _tree_upward_update($tree_file_in->[$cat_array->{array_pos}->{$starting}], $args);
  175.     }
  176.     my $parent = $cat_array->{parent}->{$starting};
  177.     if ($parent != 0 && $parent != $starting) {
  178.         my $parent_pos = $cat_array->{array_pos}->{$parent};
  179.         $tree_file_in->[$parent_pos] = _tree_upward_update($tree_file_in->[$parent_pos], $args);
  180.         $args->{metoo} = undef;
  181.         ($tree_file_in, $cat_array) = tree_upward_update($tree_file_in, $cat_array, $parent, $args);
  182.     }
  183.     return ($tree_file_in, $cat_array);
  184. }
  185.  
  186. sub _tree_upward_update {
  187.     my ($hash, $args) = @_;
  188.     foreach my $part ('subs', 'posts') {
  189.         if ($args->{$part} =~ m|^-(\d+)|) {
  190.             $hash->{$part} -= $1;
  191.         } elsif ($args->{$part} =~ m|^\+(\d+)|) {
  192.             $hash->{$part} += $1;
  193.         }
  194.     }
  195.     if (! defined $args->{safe} || $args->{safe} == 0) {
  196.         $hash->{lastmod} = $args->{lastmod} if defined $args->{lastmod};
  197.         $hash->{last_poster} = $args->{last_poster} if defined $args->{last_poster};
  198.     } elsif ($args->{lastmod} > $hash->{lastmod}) {
  199.         $hash->{lastmod} = $args->{lastmod} if $args->{lastmod};
  200.         $hash->{last_poster} = $args->{last_poster} if defined $args->{last_poster};
  201.     }
  202.     return $hash;
  203. }
  204.  
  205. ###
  206. ### tree_insert_record
  207. ###
  208. ### Inserts a new record into the tree file
  209. ###
  210.  
  211. sub tree_insert_record {
  212.     my ($tree_file_in, $cat_array, $new_hash_in, $args) = @_;
  213.     my $position = defined $args->{position} ? $args->{position} : 0;
  214.     my @nh = ref $new_hash_in eq "ARRAY" ? @{ $new_hash_in } : ($new_hash_in);
  215.     my $new_hash = $nh[0];
  216.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  217.     $new_hash->{level} = 1 + ($cat_array->{page}->{$new_hash->{parent}}->{level});
  218.     my @tfin = @{ $tree_file_in };
  219.     if ($position == 1) {
  220.         splice(@tfin, 1+$cat_array->{array_pos}->{ $new_hash->{parent} }, 0, @nh);
  221.     } elsif ($position == 0) {
  222.         my $tldo = tree_last_descendant_of(\@tfin, $cat_array, $new_hash->{parent}, $new_hash->{param});
  223.         splice(@tfin, 1+$tldo->{array_pos}, 0, @nh);
  224.     } elsif ($position == 2) {
  225.         my $tbco = tree_build_children_of(\@tfin, $cat_array, $new_hash->{parent});
  226.         my @ch = ();
  227.         if (defined($tbco)) {
  228.             @ch = @{ $tbco };
  229.         }
  230.         push (@ch, @nh);
  231.         my $sortroutine = sub {
  232.             my $_a = ref $a eq 'ARRAY' ? lc(trim($a->[0]->{name})) : ref $a eq 'HASH' ? $a->{name} : "";
  233.             my $_b = ref $b eq 'ARRAY' ? lc(trim($b->[0]->{name})) : ref $b eq 'HASH' ? $b->{name} : "";
  234.             return $_a cmp $_b;
  235.         };
  236.         my @sor = tree_dump_into_array(sort { &{$sortroutine} } @ch);
  237.         splice(@tfin, 1+$cat_array->{array_pos}->{ $new_hash->{parent} }, scalar(@sor)-scalar(@nh), @sor);
  238.     }
  239.     return (\@tfin, $cat_array);
  240. }
  241.  
  242. ###
  243. ### tree_dump_into_array
  244. ###
  245. ### Collapses an array of arrays into one single array
  246. ###
  247.  
  248. sub tree_dump_into_array {
  249.     my @result = ();
  250.     while (my $x = shift (@_)) {
  251.         if (ref $x eq "ARRAY") {
  252.             push (@result, tree_dump_into_array(@{ $x }));
  253.         } else {
  254.             push (@result, $x);
  255.         }
  256.     }
  257.     return @result;
  258. }
  259.  
  260. ###
  261. ### tree_build_parents_of
  262. ###
  263. ### Builds up the parents of a given page
  264. ###
  265.  
  266. sub tree_build_parents_of {
  267.     my ($tree_file_in, $cat_array, $starting) = @_;
  268.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  269.     my @result = ();
  270.     my $parent = $cat_array->{parent}->{$starting};
  271.     if ($parent != 0 && $parent != $starting) {
  272.         push (@result, $parent);
  273.         push (@result, @{tree_build_parents_of($tree_file_in, $cat_array, $parent)});
  274.     }
  275.     return \@result;
  276. }
  277.  
  278. ###
  279. ### tree_build_children_of
  280. ###
  281. ### Builds arrays of children of a given parent page
  282. ###
  283.  
  284. sub tree_build_children_of {
  285.     my ($tree_file_in, $cat_array, $inquiry) = @_;
  286.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  287.     if (defined $cat_array->{child}->{$inquiry}) {
  288.         my @ret = ();
  289.         my @a = @{ $cat_array->{child}->{$inquiry} };
  290.         foreach my $a (@a) {
  291.             my @x = ();
  292.             push @x, $cat_array->{page}->{$a};
  293.             my $y = tree_build_children_of($tree_file_in, $cat_array, $a);
  294.             push @x, @{ $y };
  295.             push @ret, \@x;
  296.         }
  297.         return \@ret;
  298.     } else {
  299.         my @y = ();
  300.         return \@y;
  301.     }
  302. }
  303.  
  304. ###
  305. ### tree_build_siblings_of
  306. ###
  307. ### Finds sibling pages
  308. ###
  309.  
  310. sub tree_build_siblings_of {
  311.     my ($tree_file_in, $cat_array, $inquiry) = @_;
  312.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  313.     my $par = $cat_array->{parent}->{$inquiry};
  314.     my @z = grep($_->{parent} == $par, @{$tree_file_in});
  315.     return \@z;
  316. }    
  317.  
  318. ###
  319. ### tree_last_descendant_of
  320. ###
  321. ### Determines the last descendant of a given parent page
  322. ###
  323.  
  324. sub tree_last_descendant_of {
  325.     my ($tree_file_in, $cat_array, $inquiry, $param) = @_;
  326.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  327.     if (defined $cat_array->{child}->{$inquiry}) {
  328.         my @a = @{ $cat_array->{child}->{$inquiry} };
  329.         @a = grep($cat_array->{page}->{$_}->{param} !~ /Archive/, @a) if $param !~ /Archive/;
  330.         my $lr = $a[$#a];
  331.         if ($lr != 0) {
  332.             return tree_last_descendant_of($tree_file_in, $cat_array, $lr, $param);
  333.         } else {
  334.             undef my $answer;
  335.             $answer->{childnum} = $inquiry;
  336.             $answer->{array_pos} = $cat_array->{array_pos}->{$inquiry};
  337.             return $answer;
  338.         }
  339.     } else {
  340.         undef my $answer;
  341.         $answer->{childnum} = $inquiry;
  342.         $answer->{array_pos} = $cat_array->{array_pos}->{$inquiry};
  343.         return $answer;
  344.     }
  345. }
  346.  
  347. ###
  348. ### tree_push_post
  349. ###
  350. ### Adds a post to a given hash in the tree file
  351. ###
  352.  
  353. sub tree_push_post {
  354.     my ($tree_file_in, $cat_array, $page, $post, $position) = @_;
  355.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  356.     my @pl = split(/,/, $cat_array->{page}->{$page}->{post_list});
  357.     push @pl, $post if $position == 0;
  358.     unshift @pl, $post if $position == 1;
  359.     my $post_list = join(",", @pl);
  360.     $tree_file_in = tree_record_update($tree_file_in, $cat_array, { page => $page, post_list => $post_list });
  361.     $cat_array->{page}->{$page}->{post_list} = $post_list;
  362.     return ($tree_file_in, $cat_array);    
  363. }
  364.  
  365. ###
  366. ### tree_record_update
  367. ###
  368. ### Updates one record from the tree file.
  369. ###
  370.  
  371. sub tree_record_update {
  372.     my ($tree_file_in, $cat_array, $updated_hash, $as_hash) = @_;
  373.     $cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
  374.     if (defined $cat_array->{array_pos}->{$updated_hash->{page}}) {
  375.         my $j = $cat_array->{page}->{$updated_hash->{page}};
  376.         foreach my $x ('level', 'topic', 'page', 'parent', 'name', 'param', 'url', 'posts', 'properties', 'islink', 'target', 'lastmod', 'originator', 'post_list', 'subs', 'last_poster', 'icon') {
  377.             $updated_hash->{$x} = defined $updated_hash->{$x} ? $updated_hash->{$x} : $j->{$x};
  378.         }
  379.         $tree_file_in->[ $cat_array->{array_pos}->{ $updated_hash->{page} } ] = $updated_hash;
  380.     }
  381.     return $tree_file_in if ! $as_hash;
  382.     return { tree => $tree_file_in, cat => $cat_array };
  383. }
  384.  
  385. ###
  386. ### tree_categorize
  387. ###
  388. ### Categorizes the tree file for easy updating.
  389. ###
  390.  
  391. sub tree_categorize {
  392.     my ($tree_file_in) = @_;
  393.     my $counter = 0;
  394.     undef my $cat;
  395.     foreach my $hash (@{ $tree_file_in }) {
  396.         $cat->{array_pos}->{ $hash->{page} } = $counter; $counter++;
  397.         $cat->{parent}->{ $hash->{page} } = $hash->{parent};
  398.         $cat->{page}->{ $hash->{page} } = $hash;
  399.         push (@{ $cat->{child}->{$hash->{parent}} }, $hash->{page}) if $hash->{page} != 0;
  400.     }
  401.     return $cat;
  402. }
  403.  
  404.  
  405. 1;
  406.