view release on metacpan or  search on metacpan

Plain.pm  view on Meta::CPAN

				@real_ele = split(/\//, $self->home_path());
			} else {
				push(@real_ele, $_);
			}
		}
		$path_out = join('/', @real_ele);
	}
	
	$path_out = (substr($path_out, 0, 1) eq '/') ? $path_out : '/'.$path_out;

	return $path_out;
}

# Given a file's full path and name, produce a full ls line
sub _ls_stat {
	my ($self, $full_fn, $fn) = @_;
		
	my @modes = ("---------", "rwxrwxrwx");
	# Determine the current year, for time comparisons
	my $curr_year = (localtime())[5]+1900;

	# Perform stat() on current file.
	my ($mode,$nlink,$uid,$gid,$size,$mtime) = (CORE::stat($full_fn))[2 .. 5,7,9];
	#my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	#		$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat($full_fn);
	
	# Format the mod datestamp into the ls format
	my ($day, $mm, $dd, $time, $yr) = (localtime($mtime) =~ m/(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/);
	
	# Get a string of 0's and 1's for the binary file mode/type
	my $bin_str  = substr(unpack("B32", pack("N", $mode)), -16);
	
	# Produce a permissions map from the file mode
	my $mode_bin = substr($bin_str, -9);
	my $mode_str = '';
	
	for (my $i=0; $i<9; $i++) {
		$mode_str .= substr($modes[substr($mode_bin, $i, 1)], $i, 1);
	}
		
	# Determine what type of file this is from the file type
	my $type_bin = substr($bin_str, -16, 7);
	my $type_str = '-';
	$type_str = 'd' if ($type_bin =~ m/^01/);
	
	# Assemble and return the line
	return sprintf("%1s%9s %4s %-8s %-8s %8s %3s %2s %5s %s",
		 $type_str, $mode_str, $nlink,
		 $self->_user($uid), $self->_group($gid), $size, $mm, $dd,
		 ($curr_year eq $yr) ? substr($time,0,5) : $yr, $fn);
}

# Lookup user name by uid

{
	my %user;
	sub _user {
		my ($self, $uid) = @_;
		if (!exists($user{$uid})) {
			if (defined($uid)) {
				my $obj = getpwuid($uid);
				if ($obj) {
					$user{$uid} = $obj->name;
				} else {
					$user{$uid} = "#$uid";
				}
			} else {
				return '#?';
			}
		}
		return $user{$uid};
	}
}

# Lookup group name by gid

{
	my %group;
	sub _group {
		my ($self, $gid) = @_;
		if (!exists($group{$gid})) {
			if (defined($gid)) {
				my $obj = getgrgid($gid);
				if ($obj) {
					$group{$gid} = $obj->name;
				} else {
					$group{$gid} = "#$gid";
				}
			} else {
				return '#?';
			}
		}
		return $group{$gid};
	}
}

1;

__END__

=head1 AUTHOR

David Davis, E<lt>xantus@cpan.orgE<gt>, http://teknikill.net/

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

perl(1), L<Filesys::Virtual>, L<Filesys::Virtual::SSH>,
L<Filesys::Virtual::DAAP>, L<POE::Component::Server::FTP>,
L<Net::DAV::Server>, L<HTTP::Daemon>,
http://perladvent.org/2004/20th/

=cut