File Coverage

blib/lib/Tree/PseudoIncLib.pm

Criterion	Covered	Total	%
statement	665	728	91.3
branch	174	254	68.5
condition	26	51	50.9
subroutine	50	50	100.0
pod	20	20	100.0
total	935	1103	84.7

package Tree::PseudoIncLib;

# This package is developed primarily as a part of Apache::App::PerlLibTree web application.
# It encapsulates the object of description of perl library defined by @INC array.
# Internal description of the library exists in the form of internal array of hashes.
# It can be exported as either XML or DHTML files.
# A reference to the internal description can be exported too.

# Description instance can be created "from scratch" only,

# Logging information:
# --------------------
# I use full-scale Log::Log4perl. Log configurattion file is storied in data directory.

use 5.006;
use strict;
use warnings;
use File::Listing;
use File::Basename;
use File::chdir;
use POSIX qw(strftime);
use Cwd;
use UNIVERSAL qw(isa);
use Log::Log4perl;

use vars qw($VERSION);
$VERSION = "0.05";

use constant APPLICATION_DIRECTORY => '/app/pltree/'; # URL mask from the Apache Document_Root
use constant TREE_ID_DEFAULT  => 'Default_Tree';
use constant LIB_INDEX_PREFIX => 'lib'; # default prefix for root library name
use constant MIN_LIMIT_NODES  => 15;   # min value for max_nodes setting validation
use constant LIMIT_NODES      => 15000;# default for max_nodes
use constant RPM_TYPE         => 'RPM';# default type of packaging system, debian for instance is different
use constant NO_RPM_OWNER     => undef; # '-' is not that convenient...
use constant SKIP_EMPTY_DIR_DEFAULT => 1; # true
use constant SKIP_MODE_DEFAULT      => 0; # false
use constant SKIP_OWNER_DEFAULT     => 0; # false
use constant SKIP_GROUP_DEFAULT     => 0; # false

sub new { # class/instance constructor, ready for sub-classing
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self  = {};
	bless ($self, $class);

	# instance identification should include:
	$self->{tree_id} = TREE_ID_DEFAULT; # to display user-friendly
	$self->{application_directory} = APPLICATION_DIRECTORY; # default

	$self->{max_nodes} = LIMIT_NODES; # to decrement foreach documented node
	$self->{skip_empty_dir} = SKIP_EMPTY_DIR_DEFAULT;
	$self->{skip_mode} = SKIP_MODE_DEFAULT;
	$self->{skip_owner} = SKIP_OWNER_DEFAULT;
	$self->{skip_group} = SKIP_GROUP_DEFAULT;

	$self->{descript} = undef; # a reference to the array of hashes finally...

	# all simple keys have to be defined in order to be restorable from DBI when necessary...
	$self->{descript_internal_start_time} = undef;
	$self->{descript_internal_finish_time} = undef;
	$self->{descript_start_time_text} = undef;
	$self->{descript_finish_time_text} = undef;

	$self->{rpm_type} = RPM_TYPE;
	$self->{rpm_active} = 1; # TRUE might be for known RPM types only...
	$self->{lib_index_prefix} = LIB_INDEX_PREFIX; # default for internal names

	# default @INC comes from my old development machine:
	$self->{p_INC} = [
		'/usr/lib/perl5/5.6.1/i386-linux',
		'/usr/lib/perl5/5.6.1',
		'/usr/lib/perl5/site_perl/5.6.1/i386-linux',
		'/usr/lib/perl5/site_perl/5.6.1',
		'/usr/lib/perl5/site_perl/5.6.0',
		'/usr/lib/perl5/site_perl',
		'/usr/lib/perl5/vendor_perl/5.6.1/i386-linux',
		'/usr/lib/perl5/vendor_perl/5.6.1',
		'/usr/lib/perl5/vendor_perl'
	];

	# default array of allowed for keeping files:
	$self->{allow_files} = [
		{ mask => '.pm$',	icon => 'file.gif',
			name_on_click_action => 'source',
			icon_on_click_action => 'pod2html',
			name_mouse_over_prompt => 'source',
			icon_mouse_over_prompt => 'documentation',},
		{ mask => '.pod$',	icon => 'file_note.gif',
			name_on_click_action => 'source',
			icon_on_click_action => 'pod2html',
			name_mouse_over_prompt => 'source',
			icon_mouse_over_prompt => 'document',},
		{ mask => '.html$',	icon => 'file_html.gif',
			name_on_click_action => 'source',
			icon_on_click_action => 'source',
			name_mouse_over_prompt => 'no prompt',
			icon_mouse_over_prompt => 'no prompt',},
		{ mask => '.htm$',	icon => 'htm_file.jpg',
			name_on_click_action => 'source',
			icon_on_click_action => 'source',
			name_mouse_over_prompt => 'no prompt',
			icon_mouse_over_prompt => 'no prompt',},
	];

	$self->{plog} = Log::Log4perl->get_logger(); # __PACKAGE__ might be featured in log

	# optional parameters:
	my $parm = { @_ }; # a reference to the hash
	if ( $parm ) {
		$self->application_directory ($parm->{application_directory}) if defined $parm->{application_directory};
		$self->tree_id ($parm->{tree_id})		if defined $parm->{tree_id};
		$self->max_nodes ($parm->{max_nodes})		if defined $parm->{max_nodes};
		$self->pseudo_INC ($parm->{p_INC})		if defined $parm->{p_INC};
		$self->skip_empty_dir ($parm->{skip_empty_dir})	if defined $parm->{skip_empty_dir};
		$self->skip_mode ($parm->{skip_mode})		if defined $parm->{skip_mode};
		$self->skip_owner ($parm->{skip_owner})		if defined $parm->{skip_owner};
		$self->skip_group ($parm->{skip_group})		if defined $parm->{skip_group};
		$self->allow_files ($parm->{allow_files})	if defined $parm->{allow_files};

		# a group of RPM settings is not quite independent:
		$self->rpm_type ($parm->{rpm_type})		if defined $parm->{rpm_type}; # even empty
		$self->rpm_active ($parm->{rpm_active})		if defined $parm->{rpm_active}; # overwrite
	}

	# log if/what necessary:
	my $incoming_parameters = join("\n\t",map{$_.' => '.$parm->{$_}}(sort keys %{$parm}));
	$incoming_parameters = "\n\t".$incoming_parameters if $incoming_parameters;
	my $message = "( $incoming_parameters ); an instance of $class is created.\n";
	$self->{plog}->debug($message.$self->status_as_string);
	return $self;
}

sub status_as_string { # internal data
	my $self = shift;
	my $simple_key_data = 'Internals:'."\n";
	# I got tied over here to fight with
	# map { $simple_key_data .= "\t".$_.' => '.eval{$self->{$_}}."\n" } @{$self->list_simple_keys};
	# that complained about the
	# Use of uninitialized value in concatenation (.) or string at
	# blib/lib/Apache/App/ModPerlLibTree/AppLib/OneLibInitialDescription.pm line 141.
	foreach (@{$self->list_simple_keys}){
		if (!defined $self->{$_}){
			$simple_key_data .= "\t".$_.' => undef'."\n";
		} else {
			$simple_key_data .= "\t".$_.' => '.$self->{$_}."\n";
		}
	}
	my $current_inc = 'Pseudo-@INC:'."\n";
	map { $current_inc .= "\t".$_."\n" } @{ $self->{p_INC} };
	my $curr_allow = 'Allowed for Storage Files:';
	map {my $i=$_; $curr_allow.= "\n\tmask => $_->{mask}\t".join "\t",
        	map {if($_ eq 'mask'){} else {"$_ => $i->{$_}"}} sort keys %$_ } @{$self->{allow_files}};
	return $simple_key_data.$current_inc.$curr_allow;
}

sub allow_files {
	my $self = shift;
	my $p_r = shift; # a reference to a new version of array of hashes
	if ($p_r) {
		unless (isa($p_r, 'ARRAY')){
			$self->{plog}->error("($p_r); parameter must be a reference to ARRAY\n");
			return undef;
		}
		$self->{allow_files} = $p_r;
		my $message = "($p_r); internal reference is updated.\n";
		my $curr_allow = 'Allowed for Storage Files:';
		map {my $i=$_; $curr_allow.= "\n\tmask => $_->{mask}\t".join "\t",
        	map {if($_ eq 'mask'){} else {"$_ => $i->{$_}"}} sort keys %$_ } @{$self->{allow_files}};
		$self->{plog}->debug($message.$curr_allow);
	}
	return $self->{allow_files};
}

sub application_directory {
	my $self = shift;
	my $pr = shift;
	if ($pr) {
		$self->{application_directory} = $pr;
		$self->{plog}->debug("($pr); value is updated\n");
	}
	return $self->{application_directory};
}

sub tree_id {
	my $self = shift;
	my $pr = shift; # a new value for ID
	if ($pr) {
		$self->{tree_id} = $pr;
		$self->{plog}->debug("($pr); value is updated\n");
	}
	return $self->{tree_id};
}

sub pseudo_INC {
	my $self = shift;
	my $p_r = shift; # a reference to a new version of pseudo_INC array
	if ($p_r) {
		unless (isa($p_r, 'ARRAY')){
			$self->{plog}->error("($p_r); parameter must be a reference to ARRAY\n");
			return undef;
		}
		$self->{p_INC} = $p_r;
		my $current_inc = 'Pseudo-@INC:'."\n";
		map { $current_inc .= "\t".$_."\n" } @{ $self->{p_INC} };
		$self->{plog}->debug("($p_r); internal reference is updated. $current_inc");
	}
	return $self->{p_INC};
}

sub rpm_type { # one optional parameter:
	my $self = shift;
	my $val = shift;
	if ( defined $val ){ # might be empty string
		$self->{rpm_type} = $val;
		$self->{plog}->debug("($val); rpm_type is changed to $self->{rpm_type}\n");
		unless ($self->{rpm_type}){
			$self->{rpm_active} = 0;
			$self->{plog}->debug('rpm_type disables the rpm_active'."\n");
		}
	}
	return $self->{rpm_type};
}

sub rpm_active { # one optional parameter:
	my $self = shift;
	my $val = shift;
	if ( defined $val ){ # might be 0
		if ( !$self->{rpm_type} && $val ){ # error
			$self->{plog}->error("($val); unable to set up rpm_active for unknown rpm_type\n");
			$self->{rpm_active} = 0;
			return 0;
		}
		$self->{rpm_active} = $val;
		$self->{plog}->debug("($val); rpm_active is changed to $self->{rpm_active}\n");
	}
	return $self->{rpm_active};
}

sub skip_empty_dir { # one optional parameter:
	my $self = shift;
	my $val = shift;
	if ( defined $val ){ # might be 0
		$self->{skip_empty_dir} = $val;
		$self->{plog}->debug("( $val ); skip_empty_dir is changed to $self->{skip_empty_dir}\n");
	}
	return $self->{skip_empty_dir};
}

sub skip_mode { # one optional parameter:
	my $self = shift;
	my $val = shift;
	if ( defined $val ){ # might be 0
		$self->{skip_mode} = $val;
		$self->{plog}->debug("( $val ); skip_mode is changed to $self->{skip_mode}\n");
	}
	return $self->{skip_mode};
}

sub skip_owner { # one optional parameter:
	my $self = shift;
	my $val = shift;
	if ( defined $val ){ # might be 0
		$self->{skip_owner} = $val;
		$self->{plog}->debug("($val); skip_owner is changed to $self->{skip_owner}\n");
	}
	return $self->{skip_owner};
}

sub skip_group { # one optional parameter:
	my $self = shift;
	my $val = shift;
	if ( defined $val ){ # might be 0
		$self->{skip_group} = $val;
		$self->{plog}->debug("($val); skip_group is changed to $self->{skip_group}\n");
	}
	return $self->{skip_group};
}

sub max_nodes { # one optional parameter:
	my $self = shift;
	my $val = shift;
	# max_nodes value has to be integer > 1 if defined
	if ( $val ){
		if ( $val < MIN_LIMIT_NODES ){ # error?
			$self->{plog}->warn("($val); must be not less than ".MIN_LIMIT_NODES."\n");
			$val = MIN_LIMIT_NODES;
		}
		$self->{max_nodes} = $val;
		$self->{plog}->debug("($val); max_nodes is changed to $self->{max_nodes}\n");
	}
	return $self->{max_nodes};
}

sub _dir_description {
# This member-function is used by from_scratch member function in order to
# create a primary description of so-called 'root directory' using recursion.
# The result is a pretty complicated structure of arrays and hashes.
# Primarily, it is an array of hashes, where some keys might reference another (child)
# arrays of hashes, and so on... Upon success _dir_description returns a reference to the array of hashes.

# Every file/directory/symlink is described with the hash using the following set of keys:
#
# {type} - can be 'd', 'l', or 'f' (stand for 'directory', 'link', or 'file');
# {inode} - associated with the item;
# {permissions_octal_text} - like '0755'
# {size} - in bytes
# {owner} - name of the owner;
# {group} - name of the group;
# {level} - depth in the tree (since 1 for the names listed in @INC);
# {name} - local name of the file/link/directory (inside the parent directory);
# {full_name} - absolute path-and-name like /full/path/to/the/file
# {pseudo_cpan_name} - makes sense for the .pm file only; indeed is generated recursively;
# {last_mod_time_text} - date/time of last modification in format "%B %d, %Y at %H:%M"
# {parent_index} - unique name of the parent node/object;
# {self_index} - unique name for the self node/object;
# {child_dir_list} - a reference to the array of children descriptions;
# {rpm_package_name} - for real files only;
# {allow_index} - for real files only;

# all children in every array are sorted by the name alphabetically.

# Input hash keys:
#
# {root_dir} - absolute name of the directory to explore (the trailing slash / might be skipped);
# {pseudo_cpan_root_name} - estimation of the CPAN name for root_dir;
# {parent_index} - unique object name for the root_dir;
# {parent_depth_level} - depth level of root_dir inside the result tree;
# {prior_libs} - a reference to the array of prior library names those should not be repeated again;
# {inc_lib} - name of current library in @INC;
# {allow_masks} - a reference to the array of masks for allow-files
	my $self = shift;
	# and input parameters:
	my $params = { @_ }; # a reference to the hash
	# real parameters of the call are important for debug:
	my $message = '(';
	my $incoming_parameters = join("\n\t",map{$_.' => '.$params->{$_}}(sort keys %{$params}));
	$incoming_parameters = "\n\t".$incoming_parameters if $incoming_parameters;
	$message .= $incoming_parameters.'); started'."\n";
	$self->{plog}->debug($message);

	# incoming data validation...
	unless ( defined $params->{root_dir} && $params->{root_dir} ){
		$self->{plog}->error('no incoming root_dir'."\n");
		return undef;
	}
	my $dir_path = $params->{root_dir};
	unless ( defined $params->{pseudo_cpan_root_name} ){
		$self->{plog}->error('undefined incoming pseudo_cpan_root_name'."\n");
		return undef;
	}
	my $pseudo_cpan_root_name = $params->{pseudo_cpan_root_name};
	unless ( defined $params->{parent_index} && $params->{parent_index} ){
		$self->{plog}->error('no incoming parent_index'."\n");
		return undef;
	}
	my $parent_index = $params->{parent_index}; # unique part of parent js object
	unless ( defined $params->{parent_depth_level} ){
		$self->{plog}->error('undefined incoming parent_depth_level'."\n");
		return undef;
	}
	my $depth_level = $params->{parent_depth_level} + 1;
	unless ( defined $params->{prior_libs} && $params->{prior_libs} ){
		$self->{plog}->error('no incoming prior_libs'."\n");
		return undef;
	}
	my $prior_libs = $params->{prior_libs};
	unless (isa($prior_libs, 'ARRAY')){
		$self->{plog}->error('prior_libs must be a reference to ARRAY'."\n");
		return undef;
	}
	unless ( defined $params->{inc_lib} && $params->{inc_lib} ){
		$self->{plog}->error('no incoming inc_lib'."\n");
		return undef;
	}
	my $inc_lib = $params->{inc_lib};
	unless ( defined $params->{allow_masks} && $params->{allow_masks} ){
		$self->{plog}->error('no incoming allow_masks'."\n");
		return undef;
	}
	my $allow_masks = $params->{allow_masks};
	unless (isa($allow_masks, 'ARRAY')){
		$self->{plog}->error('allow_masks must be a reference to ARRAY'."\n");
		return undef;
	}

	# check for repeatition:
	foreach ( @{$prior_libs} ){
		if ( $_ eq $dir_path ) {
			# this should not be considered an error or abnormal anyway...
			$self->{plog}->debug('skipping the repeatition of '.$_."\n");
			return undef;
		}
	}
	# make sure the $dir_path is referencing the directory:
	$dir_path .= '/' unless $dir_path =~ /\/$/;

	my $common_array = []; # to store the result
	my $internal_index = 0;
	for (parse_dir(`ls -l $dir_path`)) {
		$internal_index += 1; # nodes in one diredtory ???

		my $row = {}; # hash to store the description of one file/sub-directory

		$row->{parent_index} = $parent_index;
		$row->{inc_lib} = $inc_lib; # the same for all levels
		$row->{level} = $depth_level;

		# rule to create {self_index} in string form:
		my $self_index = $parent_index.'_'.$internal_index;
		$row->{self_index} = $self_index;

		my ($name, $type, $size, $m_mtime, $m_mode) = @$_;
		# on this stage the $size is undefined for sub-directory...
		$row->{name} = $name;

		# It was a warning over here:  Use of uninitialized value in join or string at
		#     /usr/lib/perl5/site_perl/5.6.1/Apache/App/ModPerlLibTree.pm line 175.
		# for the initial operator:
		#     my $pseudo_cpan_name = join ('::', $pseudo_cpan_root_name, $name);
		#
		# I made this working:
		my $pseudo_cpan_name = $pseudo_cpan_root_name;
		if ( $pseudo_cpan_root_name ) {
			$pseudo_cpan_name .= '::'.$name;
		} else {
			$pseudo_cpan_name = $name;
		}
		$row->{pseudo_cpan_name} = $pseudo_cpan_name;

		$row->{type} = $type;

		my $now_string = strftime "%B %d, %Y at %H:%M", localtime ($m_mtime);
		$row->{last_mod_time_text} = $now_string;

		unless ($self->{skip_mode}){
			my $permissions = sprintf "%04o", $m_mode & 07777;
			$row->{permissions_octal_text} = $permissions;
		}

		my $full_file_name = $dir_path.$name;
		$row->{full_name} = $full_file_name;

		# retrieve the rest of details from the stat:
		my (	$dev,     # device number of filesystem
			$ino,     # inode number
			$mode,    # file mode  (type and permissions)
			$nlink,   # number of (hard) links to the file
			$uid,     # numeric user ID of file's owner
			$gid,     # numeric group ID of file's owner
			$rdev,    # the device identifier (special files only)
			$size_2,  # total size of file, in bytes
			$atime,   # last access time in seconds since the epoch
			$mtime,   # last modify time in seconds since the epoch
			$ctime,   # inode change time (NOT creation time!) in seconds since the epoch
			$blksize, # preferred block size for file system I/O
			$blocks   # actual number of blocks allocated
				) = stat ($full_file_name);

		# on this stage the sub-directory has some (fictive in my understanding) size...
		$row->{size} = $size_2;
		$row->{inode} = $ino;
		$row->{owner} = getpwuid($uid) unless $self->{skip_owner};
		$row->{group} = getgrgid($gid) unless $self->{skip_group};

		if ($type eq 'd') {
			# one directory might have multiple rpm-owners like:
			#    [slava@PBC110 slava]$ rpm -qf /usr/lib/perl5/5.6.1/i386-linux
			#    perl-5.6.1-34.99.6
			#    perl-DBI-1.21-1
			#    perl-DBD-Pg-1.01-8
			#    perl-DBD-MySQL-1.2219-6
			# I care about the rpm-owners of particular files only:

			# recursion into the sub-directory:

			my $child  = $self->_dir_description (
					root_dir => $full_file_name,
					prior_libs => $prior_libs,
					pseudo_cpan_root_name => $pseudo_cpan_name,
					parent_index => $self_index,
					inc_lib => $inc_lib,
					parent_depth_level => $depth_level,
					allow_masks => $allow_masks );

			if ( $child && scalar(@{$child}) ){ # successfully created

				$row->{child_dir_list} = $child;	# a reference to the array
									# of child's description
				push @{$common_array}, $row;
				$self->{max_nodes} -= 1;
				last if $self->{max_nodes} < 1;

			} elsif ( !$self->{skip_empty_dir} ) { # keep it storied

				push @{$common_array}, $row;
				$self->{max_nodes} -= 1;
				last if $self->{max_nodes} < 1;

			} else {
				# skip empty directory (with no children) but log this...
				$self->{plog}->debug("skips empty directory $full_file_name\n");
			}

		} elsif ($type eq 'f') {

			# I limit files to be stored by the rule of 'allowed only':
			my $keepit = 0; # false initially
			my $allow_index = 0;
			foreach (@{$self->{allow_files}}){
				my $mask = $_->{mask};
				if ( $name =~ /$mask/i ){
					$row->{allow_index} = $allow_index; # to get the action later
					$keepit = 1;
					last; # the first allowed is a right one
				}
				$allow_index++;
			}
			if ($keepit) {
				# no child reference for the file:
				$row->{child_dir_list} = undef;

				# determine the rpm package when appropriate:
				if ( $self->{rpm_active} ) {
					# I have Red Hat RPM only: rpm --version
					# RPM version 4.0.4
					my $rpm_name = `rpm -qf $full_file_name`;
					# as an example, in my tests I get initially on Red Hat:
					# file /some/real/full/name/file_1.pm is not owned by any package
					# I use simple mask: /^file \// to recognize no-rpm right away
					# in order to save some storage memory:
					#	my $no_rpm_mask = '^file /';
					chomp $rpm_name;
					$row->{rpm_package_name} = ($rpm_name =~ /^file \//o)
						? NO_RPM_OWNER : $rpm_name; # =~ m/(\S.*\S)/;
				}

				push @{$common_array}, $row;
				$self->{max_nodes} -= 1;
				last if $self->{max_nodes} < 1;
			} else {
				# I skip all other files but log this...
				my $message = 'skips '.$full_file_name." due to unknown type\n";
				$self->{plog}->debug($message);
			}

		} else {
			# this is supposed to be a link:

			# In my test for real symlink I have for example:
			# type=>l file_3.txt
			# name=>file_4.htm
			# on Red Hat Linux 9.0 after:
			# ln -s file_3.txt file_4.htm
			# having:
			# lrwxrwxrwx  1 slava group  10 Aug  7 09:08 file_4.htm -> file_3.txt

			$row->{child_dir_list} = undef;
			$row->{link_target} = substr($type, 2); # check this for other platforms!
			$row->{type} = 'l'; # make it clear for the further use

			# I don't follow symlinks in order to avoid loops

			$self->{plog}->debug('has a link called '.$name."\n");
			push @{$common_array}, $row;
			$self->{max_nodes} -= 1;
			last if $self->{max_nodes} < 1;
		}
	}
	# common_array is created.

	@{$common_array} = sort { $a->{name} cmp $b->{name} } @{$common_array};

	$self->{plog}->debug('done on level='.$depth_level.' in '.$dir_path."\n");
	return $common_array;
}

sub from_scratch {
	# A member function that creates the discription of perl-library defined by {p_INC} reference.
	# no incoming parameters
	# The result reference is stored internally in {descript} and is returned upon success.
	my $self = shift;

	my $internal_start_time = time;
	# this time will be assigned as a time of the creation of description
	$self->{descript_internal_start_time} = $internal_start_time;
	my $now_string = strftime "%A, %B %e, %Y at %H:%M:%S", localtime($internal_start_time);
	$self->{descript_start_time_text} = $now_string;

	$self->{plog}->info('started on '.$now_string."\n");

	# I need to create this array ones for all nested calls:
	my $allow_masks = []; # to select files
	map { push @{$allow_masks},$_->{mask} } @{$self->{allow_files}};

	my $depth_level = 1;	# to control the depth of the tree,
				# I have the list of @INC names on level 1...
	my $lib_list_ref = [];  # a reference to the array of hashes; every hash describes one library:

# {parent_index} - unique name of the parent node/object;
# {self_index} - unique name for the self node/object;
# {name} - name of the file/link/directory;
# {pseudo_cpan_name} - makes sense for the .pm file only; indeed is generated recursively;
# {type} - can be 'd', 'l', or 'f'; However, see features of 'l'...
# {last_mod_time_text} - date/time of last modification in format "%B %d, %Y at %H:%M"
# {permissions_octal_text} - like '0755'
# {full_name} - absolute name like /full/path/to/the/file
# {size} - in bytes
# {owner} - name of the owner;
# {group} - name of the group;
# {child_dir_list} - a reference to the array of children descriptions;
# {inode} - associated with the item;
# {level} - depth in the tree (=1 for the names listed in @INC);

	# I don't want to have stupid repititions in the tree structure.
	# For example, in Red Hat distribution 7.3 you might have:
	#
	# @INC =
	# /usr/lib/perl5/5.6.1/i386-linux
	# /usr/lib/perl5/5.6.1
	# /usr/lib/perl5/site_perl/5.6.1/i386-linux
	# /usr/lib/perl5/site_perl/5.6.1
	# /usr/lib/perl5/site_perl/5.6.0
	# /usr/lib/perl5/site_perl
	# /usr/lib/perl5/vendor_perl/5.6.1/i386-linux
	# /usr/lib/perl5/vendor_perl/5.6.1
	# /usr/lib/perl5/vendor_perl
	# .                        !!! This is '/' for mod_perl !!!
	# /etc/httpd/              !!! Loop is here !!!
	# /etc/httpd/lib/perl      !!! Does not exist on my machine !!!
	#
	# It is not supposed to make a real sence in terms of pseudo-cpan names...

	my $prior_libs = []; # a reference to the array of already explored libraries

	my $local_index = 0; # to create unique names

	foreach (@{ $self->{p_INC} }) {

		$local_index += 1;
		my $lib_descr = {};
		$lib_descr->{level} = $depth_level;

		my $lib_index_name = $self->{lib_index_prefix}.'_'.$local_index;
		$lib_descr->{self_index} = $lib_index_name;
		$lib_descr->{parent_index} = undef;
		my $dir = $_;

		my $message = 'serves $INC['.$local_index.'] = '.$dir." named $lib_index_name\n";
		$self->{plog}->debug($message);

		$lib_descr->{name} = $dir;
		$lib_descr->{type} = 'd'; # always directory in @INC
		# retrieve the rest of details from the stat:
		my $dir_path = $dir;
		$dir_path .= '/' unless $dir =~ /\/$/;
		my (	$dev,     # device number of filesystem
			$ino,     # inode number
			$mode,    # file mode  (type and permissions)
			$nlink,   # number of (hard) links to the file
			$uid,     # numeric user ID of file's owner
			$gid,     # numeric group ID of file's owner
			$rdev,    # the device identifier (special files only)
			$size_2,  # total size of file, in bytes
			$atime,   # last access time in seconds since the epoch
			$mtime,   # last modify time in seconds since the epoch
			$ctime,   # inode change time (NOT creation time!) in seconds since the epoch
			$blksize, # preferred block size for file system I/O
			$blocks   # actual number of blocks allocated
				) = stat ($dir_path);
		# on this stage the sub-directory has some (fictive in my understanding) size...
		$lib_descr->{size} = $size_2;

		my $now_string = strftime "%B %d, %Y at %H:%M", localtime ($mtime);
		$lib_descr->{last_mod_time_text} = $now_string;

		$lib_descr->{full_name} = $dir;

		unless ($self->{skip_mode}){
			my $permissions = sprintf "%04o", $mode & 07777;
			$lib_descr->{permissions_octal_text} = $permissions;
		}

		$lib_descr->{owner} = getpwuid($uid) unless $self->{skip_owner};
		$lib_descr->{group} = getgrgid($gid) unless $self->{skip_group};
		$lib_descr->{inode} = $ino;

		$lib_descr->{child_dir_list} = $self->_dir_description (
			root_dir		=> $dir,
			prior_libs		=> $prior_libs,
			pseudo_cpan_root_name	=> '', # it warns in debug when I use undef over here
			parent_index		=> $lib_index_name,
			inc_lib			=> $dir,
			parent_depth_level	=> $depth_level,
			allow_masks		=> $allow_masks );

		# never skip the root (level 1) directory, even empty...

		# when the limit on global number of nodes is exceeded in _dir_description
		# it can return undef. This should be safe for the following push...
		if ( defined($lib_descr->{child_dir_list})
				&& scalar( @{$lib_descr->{child_dir_list}} ) eq 0 ){
			$lib_descr->{child_dir_list} = undef;
		}
		push @{$lib_list_ref}, $lib_descr;
		$self->{max_nodes} -= 1;
		last if $self->{max_nodes} < 1;
		push @{$prior_libs}, $dir;
	}
	# time stamp of the finish:
	my $internal_finish_time = time;
	my $now_finish_string = strftime "%A, %B %e, %Y at %H:%M:%S", localtime($internal_finish_time);
	$self->{descript_internal_finish_time} = $internal_finish_time;
	$self->{descript_finish_time_text} = $now_finish_string;

	# create a simple list of all accumulated items:

	$self->{descript} = $self->_object_list ($lib_list_ref);
	$self->_mark_shaded_names();

	if ( $self->{max_nodes} < 1 ){ # ERROR
		# terminating this late, I keep the accumulated result viewable
		$self->{plog}->error('ERROR termination: max_nodes exceeded'."\n");
		return undef;
	}
	my $duration = $internal_finish_time - $internal_start_time;

	# I will clean up the following mess later...
	my $hh = int($duration/3600);
	my $mm = int(($duration - 3600 * $hh)/60);
	my $ss = $duration - 60 * $mm - 3600 * $hh;
	my $duration_text = sprintf "%02d:%02d:%02d", $hh,$mm,$ss;

	$self->{plog}->info('done on '.$now_finish_string." duration=$duration_text\n");
	return scalar(@{$self->{descript}});
}

sub _object_list {
	# transforms the description tree structure
	# to the simple (regular) array of simple hashes:

	my $self = shift;
	my $source = shift; # a reference to the array of dir descriptions
	# source data validation:
	#
	# I can take an empty incoming array when the directory is empty;
	# that's fine, I will respond with the reference to an empty array then...
	# The problem could appear if the $source is udefined,
	# or is referencing something that is not an array...
	unless (isa($source, 'ARRAY')){
		$self->{plog}->error('incoming parameter must be a reference to ARRAY'."\n");
		return undef;
	}
	my $result = []; # a reference to return

	# 09/10/04: a bug appears over here: $source->[0]->{level} is undef ocasionaly.
	my $in_size = scalar @{$source};
	unless ( defined $source->[0]->{level} ){
		$self->{plog}->warn("undefined level value when the size=$in_size\n");
		return $result; # empty...
	}
	my $dbg_nodes = []; # to drill into the bug

	my $current_level = $source->[0]->{level};
	$self->{plog}->debug("start level=$current_level size=$in_size\n");

	foreach ( @{$source} ) {

		my $lib_descr = {}; # my very simple hash for one row

		# this is not a full list of incoming keys:

		$lib_descr->{pseudo_cpan_name}		= $_->{pseudo_cpan_name};
		$lib_descr->{level}			= $_->{level};
		$lib_descr->{inc_lib}			= $_->{inc_lib};
		$lib_descr->{parent_obj_name}		= $_->{parent_index};
		$lib_descr->{self_obj_name}		= $_->{self_index};
		$lib_descr->{name}			= $_->{name};
		$lib_descr->{type}			= $_->{type};
		$lib_descr->{size}			= $_->{size};
		$lib_descr->{last_mod_time_text}	= $_->{last_mod_time_text};
		$lib_descr->{full_name}			= $_->{full_name};
		$lib_descr->{inode}			= $_->{inode};
		$lib_descr->{permissions_octal_text}=$_->{permissions_octal_text} if $_->{permissions_octal_text};
		$lib_descr->{owner}		= $_->{owner} if $_->{owner};
		$lib_descr->{group}		= $_->{group} if $_->{group};
		$lib_descr->{allow_index}	= $_->{allow_index} if defined $_->{allow_index};# files only
		$lib_descr->{rpm_package_name}	= $_->{rpm_package_name} if $_->{rpm_package_name};
		$lib_descr->{link_target}	= $_->{link_target} if $_->{link_target};

		push @{$result}, $lib_descr;
		push @{$dbg_nodes}, $_->{inode};

		if ( $_->{child_dir_list} ) {

			# this is a good place for

			# recursion inside the same namespace/class omly:
			my $subset = _object_list($self, $_->{child_dir_list});
			push @{$result}, @{$subset};

			# this is a good place for

			$_->{child_dir_list} = undef; # release the memory
		};
	}
	$self->{plog}->debug("done level=$current_level for nodes:\n\t"
			.join("\n\t",@{$dbg_nodes})."\n");
	return $result;
}

sub _mark_shaded_names {
	# creates extended descriptions for shaded .pm files.

	# Since Aug 13, 2004 I extend the same record with additional keys
	# (instead of referencing additional hash in previous versions)
	# in order to simplify the main data structure, XML representation,
	# and serialization/deserialization mechanism.

	# no parameters:
	my $self = shift;
	$self->{plog}->debug("start\n");

	my %first; # to store pseudo_cpan_name's
	foreach ( @{ $self->{descript} } ){

		next unless $_->{type} eq 'f' and lc $_->{name} =~ /\.pm$/;

		my $actual_file_name = $_->{pseudo_cpan_name};
		if ( $first{$actual_file_name} ){

			# this file is shaded
			$_->{shaded_by_lib}		= $first{$actual_file_name}->{lib};
			$_->{shaded_by_inode}		= $first{$actual_file_name}->{inode};
			$_->{shaded_by_last_modified}	= $first{$actual_file_name}->{last_modified};

		} else {
			my $details = {};
			$details->{lib}			= $_->{inc_lib};
			$details->{inode}		= $_->{inode};
			$details->{last_modified}	= $_->{last_mod_time_text};

			$first{$actual_file_name} = $details; # to check other files
		}
	}

	my $shaded_cpan_names = [];
	map {push @{$shaded_cpan_names},$_->{pseudo_cpan_name} if $_->{shaded_by_lib} } @{$self->{descript}};
	$self->{plog}->debug("Shaded Files:\n".join(', ', @{$shaded_cpan_names} ));

	$self->{plog}->debug('done'."\n");
	return $shaded_cpan_names;
}

sub list_simple_keys {
	# returns a reference to the array that contains a
	# sorted alphabetically set of names of simple keys of the object.
	my $self = shift;

	my $ref_keys = []; # final array of key names
	foreach (sort keys %{$self}){
		if (!defined $self->{$_}){
			push @{$ref_keys},$_;
		} elsif ($self->{$_}=~/HASH/ or $self->{$_}=~/ARRAY/){
			next;
		} else {
			push @{$ref_keys},$_;
		}
	}
	$self->{plog}->debug( "Outgoing List:\n\t".join("\n\t",@{$ref_keys})."\n" );

	return $ref_keys;
}

sub list_descript_keys {
	# returns a reference to the array that contains
	# sorted alphabetically names of keys used anywhere inside descriptions.
	my $self = shift;

	my $ref_descript_keys = []; # final array of all keys
	my %r; # to fill out with full set of available description keys (no duplications):
	map { map{ $r{$_} = 1 } keys %{$_} } @{$self->{descript}};
	# sorted list of all keys:
	map { push @{$ref_descript_keys},$_ } sort keys %r;
	$self->{plog}->debug( "Outgoing List:\n\t".join("\n\t",@{$ref_descript_keys})."\n" );

	return $ref_descript_keys;
}

######################### HTML ##################
sub w3c_doctype {
	my $self = shift;

	$self->{plog}->debug('started'."\n");

	my $parms = { @_ }; # a reference to the hash
	# 1 mandatory parameter:
	my $type = $parms->{type};
	$self->{plog}->error('has no incoming type') unless $type;
	return undef unless $type;

	my $res = ''; # to output
	if ( $type =~ /xhtml/i ){
		$res =<

    "http://www.w3.org/TR/xhtml1/DTD/strict.dtd">

TOP_PART
	} elsif ( $type =~ /html/i ){
		$res =<

TOP_PART
	} else {
		$self->{plog}->error('has unknown type: '.$type);
		return undef;
	}
	$self->{plog}->debug('done'."\n");
	return $res;
}

sub inline_CSS {
	# no parameters ?

	my $res =<
 </td>
</tr>

<tr>
<td  class="h" >
<a name="926">926</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	body { </td>
</tr>

<tr>
<td  class="h" >
<a name="927">927</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		background-color: #ffffff; </td>
</tr>

<tr>
<td  class="h" >
<a name="928">928</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		color: #000000; </td>
</tr>

<tr>
<td  class="h" >
<a name="929">929</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		font-family: helvetica, arial, verdana, sans-serif; </td>
</tr>

<tr>
<td  class="h" >
<a name="930">930</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		/* font-size: 1.0em; */ </td>
</tr>

<tr>
<td  class="h" >
<a name="931">931</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		position: relative !important; /* needed for ie5*/ </td>
</tr>

<tr>
<td  class="h" >
<a name="932">932</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	} </td>
</tr>

<tr>
<td  class="h" >
<a name="933">933</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	/* Default Text Appearance */ </td>
</tr>

<tr>
<td  class="h" >
<a name="934">934</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	* { font-family: Tahoma, Arial, Helvetica, Sans-Serif; font-size: 10pt; color: black; } </td>
</tr>

<tr>
<td  class="h" >
<a name="935">935</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="936">936</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	/* Link Appearance */ </td>
</tr>

<tr>
<td  class="h" >
<a name="937">937</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	a { color: black; text-decoration: none; } </td>
</tr>

<tr>
<td  class="h" >
<a name="938">938</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	a:hover { text-decoration: underline; color: #000080; } </td>
</tr>

<tr>
<td  class="h" >
<a name="939">939</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="940">940</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	.headSell { background-color: #dddddd; } </td>
</tr>

<tr>
<td  class="h" >
<a name="941">941</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	.r0 { background-color: #eeeeee; } </td>
</tr>

<tr>
<td  class="h" >
<a name="942">942</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	.r1 { background-color: #ddffff; } </td>
</tr>

<tr>
<td  class="h" >
<a name="943">943</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	table { border: 1} </td>
</tr>

<tr>
<td  class="h" >
<a name="944">944</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="945">945</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	div { padding-top: 2px } </td>
</tr>

<tr>
<td  class="h" >
<a name="946">946</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="947">947</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">
END
	return $res;
}

sub _html_head {
	my $self = shift;

	$self->{plog}->debug('started'."\n");

	my $parms = { @_ }; # a reference to the hash
	# 3 parameters:
	my $title = $parms->{title};
	my $jslib = $parms->{jslib};
	my $css = $parms->{css};
	my $overLib = $parms->{overLib};

	my $res =<

	$title
END
	if ($css and ($css eq 'inline')){
		$res .= $self->inline_CSS;
	} elsif ($css) {
		$res .=<

END
	} # scip css otherwise...

	if ($jslib){
		$res .=<

END
	}
	if ($overLib){
		$res .=<
	<!-- overLIB (c) Erik Bosrup -->
END
	}
	$res .=<

END
	$self->{plog}->debug('done'."\n");
	return $res;
}

sub inc_html_table {
	# list content of pseudo-inc linking names to the main descripts
	# make human readable HTML format:
	my $self = shift;

	$self->{plog}->debug('started'."\n");

	my $parms = { @_ }; # a reference to the hash
	# 1 parameter:
	my $title = $parms->{title};
	my $res =<
'."\n";  




1005




 





 





 





 





 





 



 	$title 




1006




 





 





 





 





 





 



 END 




1007




1





 





 





 





 





1



 	my $loc_ind = 1; 




1008




1





 





 





 





 





3



 	foreach ( @{$self->{p_INC}} ){ 




 




1





 





 





 





 





6



   




1009




2





 





 





 





 





7



 		my $link = $self->{lib_index_prefix}.'_'.$loc_ind; # create it here: 




1010




2





 





 





 





 





12



 		$res .= "\t".''.$_.'




1011




2





 





 





 





 





5



 		$loc_ind += 1; 




1012




 





 





 





 





 





 



 	} 




1013




1





 





 





 





 





5



 	$self->{plog}->debug('done'."\n"); 




1014




1





 





 





 





 





13



 	return $res.''."\n";

END
	my $loc_ind = 1;
	foreach ( @{$self->{p_INC}} ){
		my $link = $self->{lib_index_prefix}.'_'.$loc_ind; # create it here:
		$res .= "\t".'
		$loc_ind += 1;
	}
	$self->{plog}->debug('done'."\n");
	return $res.'
}

sub _descript_html_table_head_row {
	my $self = shift;
	$self->{plog}->debug('started'."\n");

	my $res = '
	# header row of the table:
	my @hdr_list;
	push @hdr_list, 'mode' unless $self->{skip_mode};
	push @hdr_list, 'owner' unless $self->{skip_owner};
	push @hdr_list, 'group' unless $self->{skip_group};
	push @hdr_list, 'inode', 'tree', 'size', 'last_modified', 'use_model';
	push @hdr_list, 'package' if $self->{rpm_active};
	map {$res .= '
	$self->{plog}->debug('done'."\n");
	return $res.'
}

sub export_to_DHTML {
	# create a multi-string of dynamic HTML page
	my $self = shift;
	$self->{plog}->debug('started'."\n");

	my $parm = { @_ }; # a reference to the hash
	my $title = $parm->{title};
	# all following parameters should be object properties?..
	my $image_dir = $parm->{'image_dir'};
	unless ( $image_dir ){
		$self->{plog}->error('has no image_dir'."\n");
		return undef;
	}
	my $icon_shaded = $parm->{'icon_shaded'};
	unless ( $icon_shaded ){
		$self->{plog}->error('has no icon_shaded'."\n");
		return undef;
	}
	my $icon_folder_opened = $parm->{'icon_folder_opened'};
	unless ( $icon_folder_opened ){
		$self->{plog}->error('has no icon_folder_opened'."\n");
		return undef;
	}
	my $icon_symlink =$parm->{'icon_symlink'};
	unless ( $icon_symlink ){
		$self->{plog}->error('has no icon_symlink'."\n");
		return undef;
	}
	my $tree_intend = $parm->{'tree_intend'};
	$self->{plog}->warn('has undefined tree_intend'."\n") unless defined $tree_intend;
	my $row_class = $parm->{'row_class'} || 'r0';

	my $css =$parm->{'css'} || 'inline';
	my $jslib =$parm->{'jslib'} || '';
	my $overlib =$parm->{'overlib'};
	unless ( $overlib ){
		$self->{plog}->error('has no overlib'."\n");
		return undef;
	}

	my $res = $self->w3c_doctype( type => 'html' );
	$res .=<

END
	$res .= $self->_html_head(
		title	=> $title,
		css	=> $css,
		jslib	=> $jslib,
		overLib	=> $overlib,
	);
	$res .=<


END
	my $start = $self->{descript_start_time_text};
	my $v = $^V ? sprintf "v%vd", $^V : $];
	$res .=<
Perl $v$self->{tree_id}created on $start
INC array:
END
	$res .= $self->inc_html_table(title => 'Library');
	$res .=<
Tree of Libraries:
 




1098




 





 





 





 





 





 



 END 




1099




1





 





 





 





 





4



 	$res .= $self->_descript_html_table_head_row(); 




1100




 





 





 





 





 





 



 	# list all descriptions: 




1101




1





 





 





 





 





4



 	$self->{lib_index} = 1; # to link pseudo_INC list to right rows of description 




1102




1





 





 





 





 





2



 	foreach ( @{$self->{descript}} ) { 




 




1





 





 





 





 





3



   




1103




 





 





 





 





 





 



 		# 11/19/03: need to make a flexible input for the _data_row_HTML: 




1104




13





 





 





 





 





34



 		$res .= $self->_data_row_HTML( 




1105




 





 





 





 





 





 



 			current_row_description	=> $_, 




1106




 





 





 





 





 





 



 			image_dir		=> $image_dir, 




1107




 





 





 





 





 





 



 			icon_shaded		=> $icon_shaded, 




1108




 





 





 





 





 





 



 			icon_folder_opened	=> $icon_folder_opened, 




1109




 





 





 





 





 





 



 			icon_symlink		=> $icon_symlink, 




1110




 





 





 





 





 





 



 			tree_intend		=> $tree_intend, 




1111




 





 





 





 





 





 



 			row_class		=> $row_class, 




1112




 





 





 





 





 





 



 		)."\n"; 




1113




 





 





 





 





 





 



 	} 




1114




1





 





 





 





 





3



 	$self->{lib_index} = undef; # release this temporary key from possible saving operations 




1115




1





 





 





 





 





3



 	$res .=<




1116
END
	$res .= $self->_descript_html_table_head_row();
	# list all descriptions:
	$self->{lib_index} = 1; # to link pseudo_INC list to right rows of description
	foreach ( @{$self->{descript}} ) {
		# 11/19/03: need to make a flexible input for the _data_row_HTML:
		$res .= $self->_data_row_HTML(
			current_row_description	=> $_,
			image_dir		=> $image_dir,
			icon_shaded		=> $icon_shaded,
			icon_folder_opened	=> $icon_folder_opened,
			icon_symlink		=> $icon_symlink,
			tree_intend		=> $tree_intend,
			row_class		=> $row_class,
		)."\n";
	}
	$self->{lib_index} = undef; # release this temporary key from possible saving operations
	$res .=<




REST
	$self->{plog}->debug('done'."\n");
	return $res;
}

sub _data_row_HTML {
	# this method creates one regular row only,
	# it does not serve the root (and I have no root row anymore...)
	my $self = shift;
	$self->{plog}->debug('started'."\n");

	my $parm = { @_ };
	my $source = $parm->{'current_row_description'};
	unless ( $source ){
		$self->{plog}->error('has no current_row_description'."\n");
		return undef;
	}

	# all following parameters should be object properties?..
	my $image_dir = $parm->{'image_dir'};
	unless ( $image_dir ){
		$self->{plog}->error('has no image_dir'."\n");
		return undef;
	}
	my $icon_shaded = $parm->{'icon_shaded'};
	unless ( $icon_shaded ){
		$self->{plog}->error('has no icon_shaded'."\n");
		return undef;
	}
	my $icon_folder_opened = $parm->{'icon_folder_opened'};
	unless ( $icon_folder_opened ){
		$self->{plog}->error('has no icon_folder_opened'."\n");
		return undef;
	}
	my $icon_symlink =$parm->{'icon_symlink'};
	unless ( $icon_symlink ){
		$self->{plog}->error('has no icon_symlink'."\n");
		return undef;
	}
	my $tree_intend = $parm->{'tree_intend'};
	$self->{plog}->warn('has undefined tree_intend'."\n") unless defined $tree_intend;
	my $row_class = $parm->{'row_class'} || 'r0';

	# a level==1 directory should be accomplished with a local link anchor:
	my $anchor = '';
	if ( $source->{level} eq 1 ) {
		$anchor = '';
		$self->{lib_index} += 1;
	}
	my $result = '
	unless ( $self->{skip_mode} ){
		$result .= '
		$anchor = '';
	}
	unless ( $self->{skip_owner} ){
		$result .= '
		$anchor = '';
	}
	unless ( $self->{skip_group} ){
		$result .= '
		$anchor = '';
	}
	$result .= '

	# tree sell:
	$result .= '
	if ( $source->{level} ) {
		$result .= '
	}

	my $icon = $image_dir;
	if ( $source->{type} eq 'f'){
		$icon .= ($source->{shaded_by_lib}) ?
			$icon_shaded : $self->{allow_files}->[$source->{allow_index}]->{icon};
	} elsif ( $source->{type} eq 'd'){
		$icon .= $icon_folder_opened;
	} else { # $source->{type} eq 'l':
		$icon .= $icon_symlink;
	}

	my $application_directory = $self->{application_directory};

	if ( $source->{shaded_by_lib} ){
		# make the message to display by overLib on_mouse_over:
		my $ollibname = $source->{shaded_by_lib} || 'Unknown';
		my $olinode = $source->{shaded_by_inode};
		my $ollast_mod = $source->{shaded_by_last_modified};
		my $olMessage = 'Click to view this document'
		.'shaded by:' ' library:' 




1209




 





 





 





 





 





 



 		.$ollibname.'




1210




 





 





 





 





 





 



 		.'inode:'.$olinode.' 




1211




 





 





 





 





 





 



 		.'modified_on:'.$ollast_mod.' ';
		.$ollibname.'
		.'
		.'
		my $allow_index = $source->{allow_index};
		$result .= '
			icon_src => $icon,
	#		on_click_href => '/display-document'.$source->{full_name},
			on_click_href => $application_directory.$self->{allow_files}->[$allow_index]->{icon_on_click_action}.$source->{full_name},
			on_mouse_over_message => $olMessage,
			hspace => 1,
			align => 'absmiddle',
			border => 0 ).'
	} else {
		if ( $source->{type} eq 'f' ){
			my $allow_index = $source->{allow_index};
			unless ( defined $allow_index ) { # zerro is fine
				$self->{plog}->error($source->{full_name}.' has no allow_index'."\n");
				return undef;
			}
			$result .= '
				icon_src => $icon,
				on_click_href => $application_directory.$self->{allow_files}->[$allow_index]->{icon_on_click_action}.$source->{full_name},
				on_mouse_over_message => $self->{allow_files}->[$allow_index]->{icon_mouse_over_prompt},
				hspace => 1,
				align => 'absmiddle',
				border => 0 ).'
		} else { # this is a directory or a link:
			$result .= '
		}
	}

	# short name for the item:
	if ( $source->{type} eq 'f' ){
		my $allow_index = $source->{allow_index};
		my $left_space = ''; # default for .pod icon that has own space...
		my $olMessage = $self->{allow_files}->[$allow_index]->{name_mouse_over_prompt};
		$left_space = '  ';
		$result .= '
			text => $source->{name},
			href => $application_directory.$self->{allow_files}->[$allow_index]->{name_on_click_action}.$source->{full_name},
			on_mouse_over_message => $olMessage ).'
	} else {
		# no links for directory or symlink:
		$result .= '
	}
	$result .= '

	# output the rest of the row:
	if ( $source->{type} eq 'f' ){
		$result .= '
		.'
		if ( lc $source->{name} =~ /\.pm$/ ){
			my $real_name = substr($source->{pseudo_cpan_name}, 0, -3);
			$result .= '
		} else {
			$result .= '
		}
	} elsif ( ($source->{type} eq 'd') and ($source->{level} eq 1 ) ) {
		$result .= '
		$result .= '
	} elsif ( $source->{type} eq 'l' ) {
		$result .= '
	} else {
		$result .= '
	}
	# one directory might have multiple rpm-owners like:
	#	[slava@PBC110 slava]$ rpm -qf /usr/lib/perl5/5.6.1/i386-linux
	#	perl-5.6.1-34.99.6
	#	perl-DBI-1.21-1
	#	perl-DBD-Pg-1.01-8
	#	perl-DBD-MySQL-1.2219-6
	# I care about the rpm-owners of particular files only:
	if ( $self->{rpm_active} ){
		my $rpm_package_name = $source->{rpm_package_name};
		$rpm_package_name = '-'
			if defined $rpm_package_name and $rpm_package_name =~ /^file \//; # make short output
		if ( $rpm_package_name ){
			$result .= '
		} else {
			$result .= '
		}
	}
	$self->{plog}->debug('done'."\n");
	return $result.'
}

sub _link_icon_overLib {
	my $self = shift;
	my $parm = { @_ };
	my $icon_src = $parm->{'icon_src'};
	unless ( $icon_src ){
		$self->{plog}->error("has no icon_src\n");
		return undef;
	}
	return '
1304
		.$parm->{'on_mouse_over_message'}.'\');" onmouseout="return nd();">
1305
		.$icon_src.'" hspace="'.$parm->{'hspace'}.'" border="'.$parm->{'border'}.'" align="'
		.$parm->{'align'}.'">';
}

sub _link_text_overLib {
	my $self = shift;
	my $parm = { @_ };
	my $href = $parm->{'href'};
	unless ( $href ){
		$self->{plog}->error("has no href\n");
		return undef;
	}
	return '
1318
		.'" onmouseover="return overlib(\''.$parm->{'on_mouse_over_message'}.'\');"'
		.' onmouseout="return nd();">'.$parm->{'text'}.'';
}

1;
__END__