Tree-PseudoIncLib
view release on metacpan or search on metacpan
PseudoIncLib.pm view on Meta::CPAN
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:
PseudoIncLib.pm view on Meta::CPAN
# /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:
( run in 3.312 seconds using v1.01-cache-2.11-cpan-d8267643d1d )