File Coverage

blib/lib/mqs/spool.pm

Criterion	Covered	Total	%
statement	89	96	92.7
branch	16	30	53.3
condition	2	6	33.3
subroutine	12	12	100.0
pod	0	7	0.0
total	119	151	78.8

package mqs::spool;

require 5.005_62;
use strict;
use warnings;

require Exporter;
require DynaLoader;
use AutoLoader qw(AUTOLOAD);

our @ISA = qw(Exporter DynaLoader);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use mqs::spool ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
		initspooldirectory
		newfilename
		putinspool
		listfiles
		delfile
		readfile
);
our $VERSION = '0.02';

bootstrap mqs::spool $VERSION;

# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

use Cwd;
use POSIX;

my $size_spool = 32;
my $spool_chmod = 0750;
my $max_priority = 5;
my $min_priority = 1;
my $rnd_coeff = 64000; # value from 0 to $rnd_coeff to generate
			# randomized file names

sub initspooldirectory
{
	my %spool;
	my $dir = $_[0];
	if($dir eq "")
	{
		return -1;
	}
	unless(-d $dir)
	{
		mkdir ($dir,$spool_chmod) or return $!;
	}
	my $currentdir = getcwd();
	chdir($dir);
	my $it;
	for($it = 0; $it < $size_spool; $it++)
	{
		unless(-d $it)
		{
			mkdir ($it,$spool_chmod) or return $!;
		}
	}
	$spool{"type"} = "dir";
	$spool{"directory"} = getcwd();
	chdir $currentdir;
	return %spool;
}

sub newfilename
{
	my $dir = $_[0];
	$dir = $dir."/".int(rand($size_spool));
	my $entire_name = gen_name($dir);
	$entire_name = $entire_name.int(rand($rnd_coeff));
	return $entire_name;
}

sub putinspool
{
	my $spool_ref = $_[0];
	my %spool = %$spool_ref;
	my $content = $_[1];
	my $priority = $_[2];
	my $filename;
	if($spool{'directory'} eq "" or $spool{'type'} ne "dir")
	{
		return -1;
	}
	if(-d $spool{'directory'})
	{
		$filename = newfilename($spool{'directory'});
	}
	else
	{
		return -1;
	}
	$filename = $filename.".".$priority;
#	if((write_file("$filename.tmp",$content)) == -1)
#	{
#		return -1;
#	}
# C code has a bug with some caracthers, ... did not find why, I come
# back in Perl code for this part
        open(OUT,">$filename.tmp") or return $!;
        print OUT"$content";
        close(OUT);
	rename("$filename.tmp","$filename.mqs");
	return 1;
}

sub listfiles
{
	my $spool_ref = $_[0];
	my %spool = %$spool_ref;
	my $priority = $_[1];		# not yet used
	if($spool{'directory'} eq "" or $spool{'type'} ne "dir")
	{
		return -1;
	}
	my $dir;
	my $it = 0;
	my @files;
	for($dir = 0; $dir < $size_spool; $dir++)
	{
		opendir(DIR,$spool{'directory'}."/".$dir) or return $!;
		while($files[$it] = readdir(DIR))
		{
			if($files[$it] =~ /.*\.mqs$/)
			{
				$files[$it] = $spool{'directory'}."/".$dir."/".$files[$it];
				$it++;
			}
		}
		closedir(DIR);
	}
	$#files = $#files - 1;
	if($priority == 1)
	{
		return &priority_spool(@files);
	}
	else
	{
		return @files;
	}
}

sub priority_spool
{
	my @files = @_;
	my $tmp;
	my @tab;
	my @return;
	my $pos = 0;
	my $i;
	for($i = $max_priority; $i != $min_priority - 1; $i--)
	{
		foreach $tmp (@files)
		{
			@tab = split(/\./,$tmp);
			if($tab[$#tab-1] == $i)
			{
				$return[$pos] = $tmp;
				$pos++;
			}
		}
	}
	return @return;
}

sub delfile
{
	my $file = $_[0];
	unlink($file) or return $!;
	return 1;
}

sub readfile
{
	my $file = $_[0];
	my @tab = split(/\./,$file);
	my $priority = $tab[$#tab - 1];
	my @line;
	open(IN,"<$file") or return -1;
	@line = ;
	close(IN);
	my $content = join("",@line);
	my @return = ($content,$priority);
	return @return;
}



1;

__END__