home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
rtsi.com
/
2014.01.www.rtsi.com.tar
/
www.rtsi.com
/
OS9
/
FAQ
/
cgi-bin
/
discus4_00
/
source
/
fcn-tree.pl
< prev
next >
Wrap
Text File
|
2009-11-06
|
12KB
|
406 lines
# FILE: fcn-tree.pl
# DESCRIPTION: Tree file manipulations
#-------------------------------------------------------------------------------
# DISCUS COPYRIGHT NOTICE
#
# Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
# The use of Discus is governed by the Discus License Agreement which is
# available from the Discus WWW site at:
# http://www.discusware.com/discus/license
#
# Pursuant to the Discus License Agreement, this copyright notice may not be
# removed or altered in any way.
#-------------------------------------------------------------------------------
use strict;
use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
###
### pages_upward_update
###
### Updates parent pages with new information from the tree file. Send
### in a list of child pages as an array reference in $pages...
###
sub pages_upward_update {
my ($tree_file_in, $cat_array, $pages, $args) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
undef my $do_nums;
foreach my $i (@{ $pages }) {
my $parents = tree_build_parents_of($tree_file_in, $cat_array, $i);
foreach my $l (@{ $parents }) {
$do_nums->{$l} += 1;
}
$do_nums->{$i} += 1 if $args->{do_page};
}
foreach my $i (keys(%{ $do_nums })) {
my $rescode = lock("--REGENERATE-SUBTOPICS--", "$DCONF->{message_dir}/$tree_file_in->[0]->{topic}/$i.$DCONF->{ext}");
if ($rescode == 1) {
my $pref = GetPage($tree_file_in->[0]->{topic}, $i);
$pref->{general}->{subtopic_raw} = 0;
$pref->{sublist} = expand_sublist($pref->{sublist}, $tree_file_in->[0]->{topic}, $tree_file_in);
SetPage($pref, { unlock => 1} );
}
}
}
###
### tree_remove_page
###
### Updates the tree file to reflect one or more pages being removed. Also
### handles deleting child pages and it works for links. Send entries for
### pages being removed.
###
sub tree_remove_page {
my ($tfi, $cat_array, $pages_to_remove, $p) = @_;
$cat_array = tree_categorize($tfi) if ! defined $cat_array;
my @REMOVED = ();
my @SAVED = ();
my %c = ref $pages_to_remove eq 'HASH' ? %{$pages_to_remove} : map { $_, 1 } split(/,/, $pages_to_remove);
foreach my $line (@{ $tfi }) {
if ($c{$line->{page}} || $c{$line->{parent}}) {
push @REMOVED, $line;
$c{$line->{page}} = 1;
} else {
push @SAVED, $line;
}
}
my @pg = ();
foreach my $line (@REMOVED) {
push @pg, split(/,/, $line->{post_list});
}
my $tf = \@SAVED;
my $ca = tree_categorize(\@SAVED);
($tf, $ca) = tree_upward_update($tf, $ca, $p, { metoo => 1, posts => join("", "-", scalar(@pg)), subs => join("", "-", scalar(@REMOVED)) }) if $p;
return ($tf, $ca, \@pg, \@REMOVED);
}
###
### tree_remove_message
###
### Updates the tree to reflect one or more messages removed -- optimized for
### use when deleting messages from a page either by pruning or deleting.
### Send messages being removed as an array reference with the following:
### page => Page from which messages are being removed
### messages => Comma-separated list of messages to be removed
###
sub tree_remove_message {
my ($tree_file_in, $cat_array, $messages_being_removed) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
foreach my $i (@{ $messages_being_removed }) {
my ($p, $m) = ($i->{page}, $i->{messages});
my $ind = $cat_array->{array_pos}->{$p};
my $fpl = $tree_file_in->[$ind]->{post_list};
my $rem = 0;
undef my $nix;
foreach my $j (split(/,/, $m)) {
$nix->{$j} = 1;
}
my @leave = ();
foreach my $j (split(/,/, $fpl)) {
if ($nix->{$j}) {
$rem += 1;
} else {
push (@leave, $j);
}
}
$tree_file_in->[$ind]->{post_list} = join(",", @leave);
($tree_file_in, $cat_array) = tree_upward_update($tree_file_in, $cat_array, $p, { metoo => 1, posts => "-$rem" }) if $rem;
}
return ($tree_file_in, $cat_array);
}
###
### tree_subtopic_reorder
###
### Performs reordering according to user-supplied information
###
sub tree_subtopic_reorder {
my ($tree_file_in, $cat_array, $starting, $coderef, $sor) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
my $tbco = tree_build_children_of($tree_file_in, $cat_array, $starting);
my @sor = sort {&{$coderef}} @{$tbco};
@sor = tree_flatten(\@sor);
@sor = sort sort_archive_method @sor if $sor && $GLOBAL_OPTIONS->{sort_archive_method_on};
unshift @sor, $cat_array->{page}->{$starting};
splice(@{ $tree_file_in }, $cat_array->{array_pos}->{$starting}, scalar(@sor), @sor);
return ($tree_file_in, $cat_array);
}
###
### tree_active_reorder
###
### Performs active reordering (reorder by last modified date)
###
sub tree_active_reorder {
my ($tree_file_in, $cat_array, $starting, $args) = @_;
my $coderef = sub { return $a->[0]->{lastmod} <=> $b->[0]->{lastmod} };
return tree_subtopic_reorder($tree_file_in, $cat_array, $starting, $coderef, 1);
}
###
### tree_flatten
###
### Flattens tree information
###
sub tree_flatten {
my ($array_in) = @_;
my @aout = ();
foreach my $x (@{$array_in}) {
if (ref $x eq 'ARRAY') {
push @aout, tree_flatten($x);
} else {
push @aout, $x;
}
}
return @aout;
}
###
### tree_upward_update
###
### Updates the tree in an upward direction
###
sub tree_upward_update {
my ($tree_file_in, $cat_array, $starting, $args) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
if ($args->{metoo}) {
$tree_file_in->[$cat_array->{array_pos}->{$starting}] = _tree_upward_update($tree_file_in->[$cat_array->{array_pos}->{$starting}], $args);
}
my $parent = $cat_array->{parent}->{$starting};
if ($parent != 0 && $parent != $starting) {
my $parent_pos = $cat_array->{array_pos}->{$parent};
$tree_file_in->[$parent_pos] = _tree_upward_update($tree_file_in->[$parent_pos], $args);
$args->{metoo} = undef;
($tree_file_in, $cat_array) = tree_upward_update($tree_file_in, $cat_array, $parent, $args);
}
return ($tree_file_in, $cat_array);
}
sub _tree_upward_update {
my ($hash, $args) = @_;
foreach my $part ('subs', 'posts') {
if ($args->{$part} =~ m|^-(\d+)|) {
$hash->{$part} -= $1;
} elsif ($args->{$part} =~ m|^\+(\d+)|) {
$hash->{$part} += $1;
}
}
if (! defined $args->{safe} || $args->{safe} == 0) {
$hash->{lastmod} = $args->{lastmod} if defined $args->{lastmod};
$hash->{last_poster} = $args->{last_poster} if defined $args->{last_poster};
} elsif ($args->{lastmod} > $hash->{lastmod}) {
$hash->{lastmod} = $args->{lastmod} if $args->{lastmod};
$hash->{last_poster} = $args->{last_poster} if defined $args->{last_poster};
}
return $hash;
}
###
### tree_insert_record
###
### Inserts a new record into the tree file
###
sub tree_insert_record {
my ($tree_file_in, $cat_array, $new_hash_in, $args) = @_;
my $position = defined $args->{position} ? $args->{position} : 0;
my @nh = ref $new_hash_in eq "ARRAY" ? @{ $new_hash_in } : ($new_hash_in);
my $new_hash = $nh[0];
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
$new_hash->{level} = 1 + ($cat_array->{page}->{$new_hash->{parent}}->{level});
my @tfin = @{ $tree_file_in };
if ($position == 1) {
splice(@tfin, 1+$cat_array->{array_pos}->{ $new_hash->{parent} }, 0, @nh);
} elsif ($position == 0) {
my $tldo = tree_last_descendant_of(\@tfin, $cat_array, $new_hash->{parent}, $new_hash->{param});
splice(@tfin, 1+$tldo->{array_pos}, 0, @nh);
} elsif ($position == 2) {
my $tbco = tree_build_children_of(\@tfin, $cat_array, $new_hash->{parent});
my @ch = ();
if (defined($tbco)) {
@ch = @{ $tbco };
}
push (@ch, @nh);
my $sortroutine = sub {
my $_a = ref $a eq 'ARRAY' ? lc(trim($a->[0]->{name})) : ref $a eq 'HASH' ? $a->{name} : "";
my $_b = ref $b eq 'ARRAY' ? lc(trim($b->[0]->{name})) : ref $b eq 'HASH' ? $b->{name} : "";
return $_a cmp $_b;
};
my @sor = tree_dump_into_array(sort { &{$sortroutine} } @ch);
splice(@tfin, 1+$cat_array->{array_pos}->{ $new_hash->{parent} }, scalar(@sor)-scalar(@nh), @sor);
}
return (\@tfin, $cat_array);
}
###
### tree_dump_into_array
###
### Collapses an array of arrays into one single array
###
sub tree_dump_into_array {
my @result = ();
while (my $x = shift (@_)) {
if (ref $x eq "ARRAY") {
push (@result, tree_dump_into_array(@{ $x }));
} else {
push (@result, $x);
}
}
return @result;
}
###
### tree_build_parents_of
###
### Builds up the parents of a given page
###
sub tree_build_parents_of {
my ($tree_file_in, $cat_array, $starting) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
my @result = ();
my $parent = $cat_array->{parent}->{$starting};
if ($parent != 0 && $parent != $starting) {
push (@result, $parent);
push (@result, @{tree_build_parents_of($tree_file_in, $cat_array, $parent)});
}
return \@result;
}
###
### tree_build_children_of
###
### Builds arrays of children of a given parent page
###
sub tree_build_children_of {
my ($tree_file_in, $cat_array, $inquiry) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
if (defined $cat_array->{child}->{$inquiry}) {
my @ret = ();
my @a = @{ $cat_array->{child}->{$inquiry} };
foreach my $a (@a) {
my @x = ();
push @x, $cat_array->{page}->{$a};
my $y = tree_build_children_of($tree_file_in, $cat_array, $a);
push @x, @{ $y };
push @ret, \@x;
}
return \@ret;
} else {
my @y = ();
return \@y;
}
}
###
### tree_build_siblings_of
###
### Finds sibling pages
###
sub tree_build_siblings_of {
my ($tree_file_in, $cat_array, $inquiry) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
my $par = $cat_array->{parent}->{$inquiry};
my @z = grep($_->{parent} == $par, @{$tree_file_in});
return \@z;
}
###
### tree_last_descendant_of
###
### Determines the last descendant of a given parent page
###
sub tree_last_descendant_of {
my ($tree_file_in, $cat_array, $inquiry, $param) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
if (defined $cat_array->{child}->{$inquiry}) {
my @a = @{ $cat_array->{child}->{$inquiry} };
@a = grep($cat_array->{page}->{$_}->{param} !~ /Archive/, @a) if $param !~ /Archive/;
my $lr = $a[$#a];
if ($lr != 0) {
return tree_last_descendant_of($tree_file_in, $cat_array, $lr, $param);
} else {
undef my $answer;
$answer->{childnum} = $inquiry;
$answer->{array_pos} = $cat_array->{array_pos}->{$inquiry};
return $answer;
}
} else {
undef my $answer;
$answer->{childnum} = $inquiry;
$answer->{array_pos} = $cat_array->{array_pos}->{$inquiry};
return $answer;
}
}
###
### tree_push_post
###
### Adds a post to a given hash in the tree file
###
sub tree_push_post {
my ($tree_file_in, $cat_array, $page, $post, $position) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
my @pl = split(/,/, $cat_array->{page}->{$page}->{post_list});
push @pl, $post if $position == 0;
unshift @pl, $post if $position == 1;
my $post_list = join(",", @pl);
$tree_file_in = tree_record_update($tree_file_in, $cat_array, { page => $page, post_list => $post_list });
$cat_array->{page}->{$page}->{post_list} = $post_list;
return ($tree_file_in, $cat_array);
}
###
### tree_record_update
###
### Updates one record from the tree file.
###
sub tree_record_update {
my ($tree_file_in, $cat_array, $updated_hash, $as_hash) = @_;
$cat_array = tree_categorize($tree_file_in) if ! defined $cat_array;
if (defined $cat_array->{array_pos}->{$updated_hash->{page}}) {
my $j = $cat_array->{page}->{$updated_hash->{page}};
foreach my $x ('level', 'topic', 'page', 'parent', 'name', 'param', 'url', 'posts', 'properties', 'islink', 'target', 'lastmod', 'originator', 'post_list', 'subs', 'last_poster', 'icon') {
$updated_hash->{$x} = defined $updated_hash->{$x} ? $updated_hash->{$x} : $j->{$x};
}
$tree_file_in->[ $cat_array->{array_pos}->{ $updated_hash->{page} } ] = $updated_hash;
}
return $tree_file_in if ! $as_hash;
return { tree => $tree_file_in, cat => $cat_array };
}
###
### tree_categorize
###
### Categorizes the tree file for easy updating.
###
sub tree_categorize {
my ($tree_file_in) = @_;
my $counter = 0;
undef my $cat;
foreach my $hash (@{ $tree_file_in }) {
$cat->{array_pos}->{ $hash->{page} } = $counter; $counter++;
$cat->{parent}->{ $hash->{page} } = $hash->{parent};
$cat->{page}->{ $hash->{page} } = $hash;
push (@{ $cat->{child}->{$hash->{parent}} }, $hash->{page}) if $hash->{page} != 0;
}
return $cat;
}
1;