#
#
# $Id: File.pm,v 1.43.2.16.6.5 2012/11/16 16:02:53 kyri Exp $
#
# (C) Copyright 1998 by Open Systems Consultants a.s, All rights reserved.
#
# This software may be used or copied only with the written permission by
# Open Systems Consultans a.s or in accordance with the terms and conditions
# stipulated in the agreement under which this software has been supplied.
#
# This file is part of Open iT Resources
#
# NAME:
#   Files
# AUTHOR:
#   Thomas Andre Berger and Christian Moen
# CREATED:
#   Fri Jul 1:50:57 MET 1996
# DESCRIPTION:
#   
#
###############################################################################


package OpeniT::File;

require Exporter;
use strict;
use Carp;
use Cwd;
use FileHandle;
use DirHandle;

use Date::Calc;
use File::Find;
use File::Path;
use Compress::Zlib qw(/gz/ /Z_/);

BEGIN {
    eval "use Win32::Symlink";
}

use OpeniT::Defaults;
use OpeniT::Config;


@OpeniT::File::ISA     = qw(Exporter);
@OpeniT::File::EXPORT  = qw(write_pid_file
			 get_pid_from_pid_file
			 account_data_file
			 account_data_dir
			 append_datafile
			 file_of_lock
			 lock
			 unlock
			 locked
			 assert_dir
			 assert_available_space
			 get_available_space_kb
			 get_available_space_pst
			 get_datafile_time_interval
			 get_license
			 get_temp_file_name
			 recursive_list_of_files
			 flat_list_of_files
			 flat_list_of_n_files
			 list_of_files
			 list_of_links
			 list_of_dir
			 infile
			 outfile
                         touch_file
			 gz_infile
			 gz_readline
			 gz_outfile
			 gz_write
			 gz_close
			 is_gz_file
			 gz_file_size
                         gunzip_file
                         gzip_file
			 check_lock_for_removal
			 check_file_for_removal_on_change
			 check_file_for_removal_on_access
                         get_canonical_filename
                         rename_temp
                         remake_temp
                         head_of_file
			 sort_psm_file
                         rdlink
                         islink
			 psm_sort_orderer
			 build_command
);

my $_tmp_suffix      = ".temp";
my $_lock_suffix     = ".lock";
my $_lock_info_delim = ':';
my $_lock_timeout    = 24 * 3600;

my $_avail_threshold = 1024 * 4;

my $bin_dir = &OpeniT::Config::BIN_DIR;

&OpeniT::Config::read("OpeniT::File");

my $filesep = &OpeniT::Defaults::file_separator();

###############################################################################
#
# NAME:
#   assert_dir
# PURPOSE:
#   check if dir exits, if not then create it (readable to user, group)
# ARGS:
#   dir to create
# RETURNS:
#   nothing
#

sub assert_dir {
    my ($dir) = @_;
    unless (-d $dir) {
		mkpath( [ $dir ], 0, 0777);
    }
}



###############################################################################
#
# NAME:
#   assert_available_space
# PURPOSE:
#   Makes sure we have arg available space in temp dir
#    This avoids temp-files to fill up / (root) if temp is on this filesystems
# ARGS:
#   Number of megabytes that should be available (optional)
#   How to handle error situations (undef = error and exit)
#   
# RETURNS:
#   ERRORs if not enough space available
#

sub assert_available_space {
    my $avail_req = shift;
    my $how_to_error = shift;
    my $avail;
    
    if (! defined($avail_req)) {
		$avail_req = $_avail_threshold;
    }
    
    if ( $avail =
		 get_available_space_kb(&OpeniT::Config::TEMP_DIR) > $avail_req ) {
		return TRUE;
    } else {
		my $error_message = "Not enough space ($avail) available in Open iT temp directory (required $avail_req)";
		if (defined($how_to_error) && $how_to_error eq "noexit") {
			ERROR($error_message, undef, "noexit");
			return FALSE;
		} else {
			ERROR($error_message);
		}
    }
}


###############################################################################
#
# NAME:
#   get_available_space_kb
# PURPOSE:
#   
# ARGS:
#   
# RETURNS:
#   
#

sub get_available_space_kb {
    my $path = shift;

    DEBUG( "Getting free space on '$path'" );

    $path = &File::Basename::dirname($path);

    DEBUG( "Directory name '$path'." );

    return (&_get_df($path))[4];
}


###############################################################################
#
# NAME:
#   get_available_space_pst
# PURPOSE:
#   
# ARGS:
#   
# RETURNS:
#   
#

sub get_available_space_pst {
    my $path = shift;
    
    return (&_get_df($path))[5];
}


###############################################################################
#
# NAME:
#   _get_df
# PURPOSE:
#   
# ARGS:
#   
# RETURNS:
#   
#

sub _get_df {
	my $path = shift;

	my $gnu_df_bin = &OpeniT::Config::BIN_DIR . '/df';

	$|=1;			# Autoflush
	my $df = new FileHandle;
	my $cmd = "$gnu_df_bin -kTP $path";
	DEBUG( "Running '$cmd'" );

	open($df, "$cmd 2>/dev/null |");

	my $header = <$df>;
	my $info   = <$df>;

	close($df);

	DEBUG( "Output from df:\n'$header$info'" );

	# Catch "no df" error
	if (! defined($info) || $info eq "") {
		&ERROR("Unable to read output from df command '$gnu_df_bin -kTP $path'",
			   undef, "noexit");
		return ("", "", 0, 0, 0, "0%", ""); # Empty fields.
	}

	chomp $info;
	DEBUG( "Info from df: $info" );

	return split(/\s+/, $info);
}


###############################################################################
#
# NAME:
#   infile
# PURPOSE:
#   Returns the filehandle to the filename given
# ARGS:
#   filename
# RETURNS:
#   filehandle
#

sub infile {
    my $filename = shift;
    
    if ( $filename eq "-" ) {
		DEBUG("Reading data from STDIN");
		return \*STDIN;
    } else {
		my $infilehandle = new FileHandle;
		DEBUG("Reading file: $filename");
		unless (open($infilehandle, $filename) ) {
			ERROR("Unable to read file: $filename, $!");
		}
		return $infilehandle;
    }
}


###############################################################################
#
# NAME:
#   outfile
# PURPOSE:
#   Returns the filehandle to the filename given, if it exitst, --force must
#   be given
# ARGS:
#   filename, force_option
# RETURNS:
#   filehandle
#

sub outfile {
    my ($filename, $mode) = @_;
    
    if ($filename eq "-") {
		return \*STDOUT;
    } else {
		my $open_arg = ">" . $filename . $_tmp_suffix;
		
		if (defined($mode) && $mode eq "append") {
			$open_arg = ">>" . $filename;
		}
		
		if ( -e $filename && !defined($mode) ) {
			ERROR("\"$filename\" file already exists - remove it if " .
				  "you want to generate it (or use --force)");
		}
		
		my $outfilehandle = new FileHandle;
		unless (open($outfilehandle, $open_arg)) {
			ERROR("Unable to open file $filename$_tmp_suffix for writing,$!");
		}
		
		DEBUG("Opening file $filename$_tmp_suffix for writing");
		return $outfilehandle;
    }
}

####
# Input: file name
# Output: TRUE on success
#         FALSE on error
#
sub touch_file {
    my $filename = shift @_;
    my $fh = outfile( $filename, "append" );
    if( ! defined $fh ) {
		ERROR( "Failed to touch $filename" );
		return FALSE;
    }
    close( $fh );
    return TRUE;
}

###############################################################################
#
# NAME:
#   gz_infile
# PURPOSE:
#   Returns the filehandle to the filename given using the Zlib module
# ARGS:
#   filename
# RETURNS:
#   object used to access compress methods on file
#

sub gz_infile {
    my $filename = shift;
    my $gz;

    if ( $filename eq "-" ) {
		DEBUG("Reading data from STDIN");
		unless($gz = gzopen( \*STDIN, "r")) {
			ERROR("Unable to read file STDIN: $gzerrno");
		}
    } else {
		DEBUG("Reading file: $filename");    
		unless ($gz = gzopen( $filename, "r" )) {
			ERROR("Unable to read file '$filename': $gzerrno");
		}
    }

    return $gz;
}


###############################################################################
#
# NAME:
#   gz_readline
# PURPOSE:
#   Reads a line from file referenced by object
# ARGS:
#   object used to access compress methods on file
# RETURNS:
#   string (line) of read data or 'undef' if read failes.
#

sub gz_readline {
    my ($gz) = @_;
    my $line;

    if( $gz->gzreadline($line) ) {
		return $line
    }

    return undef;
}


###############################################################################
#
# NAME:
#   gz_outfile
# PURPOSE:
#   Returns object used to access compress methods on file for
# ARGS:
#   filename, mode options
# RETURNS:
#   object used to access compress methods on file
#

sub gz_outfile {
    my ($filename, $mode) = @_;
    my $gz;
    
    if($filename eq "-") {
		unless($gz = gzopen(\*STDOUT, $mode)) {
			ERROR("Unable to write to STDOUT: $gzerrno");
		}
    } else {
		$filename .= $_tmp_suffix;

		unless($gz = gzopen( $filename, $mode )) {
			ERROR("Unable to write to file '$filename': $gzerrno");
		}

		DEBUG("Opening file $filename$_tmp_suffix for writing");
    }  

    return $gz;
}


###############################################################################
#
# NAME:
#   gz_write
# PURPOSE:
#   Writes data compressed to file
# ARGS:
#   object used to access compress methods on file, string of data
# RETURNS:
#   status of write operation (num of bytes written), wich will give
#   an (unwanted?) error if $line is a null string.
#

sub gz_write {
    my ($gz, $line) = @_;

    return $gz->gzwrite($line);
}

###############################################################################
#
# NAME:
#   gz_close
# PURPOSE:
#   Closes a file referenced by object
# ARGS:
#   object used to access compress methods on file
# RETURNS:
#   status from close
#

sub gz_close {
    my ($gz) = @_;
    
    return $gz->gzclose();
}



####
# Input: zipped file, of any other file
# Output: TRUE if file is zipped and has correct format
#         FALSE if not
#         undef on error
#
sub is_gz_file {
    my $filename = shift @_;
    my $fh = infile( $filename );
    if( ! defined $fh ) {
		DEBUG( "$filename is not gzipped" );
		return FALSE;
    }
    my $buf;
    if( read( $fh, $buf, 2 ) != 2 ) {
		close( $fh );
		DEBUG( "$filename is not gzipped" );
		return FALSE;
    }
    if( ord substr( $buf, 0, 1 ) != 31 || ord substr( $buf, 1, 1 ) != 139 ) {
		close( $fh );
		DEBUG( "$filename is not gzipped" );
		return FALSE;
    }
    DEBUG( "$filename is gzipped" );
    return TRUE;
}

####
# Input: zipped file
# Output: uncompressed size
#         undef on error
#
sub gz_file_size {
    my $filename = shift @_;

    my $fh = infile( $filename );
    if( ! defined $fh ) {
		ERROR( "Could not find file size of: $filename: $!",undef, "noexit" );
		return undef;
    }
    my $buf;
    if( read( $fh, $buf, 2 ) != 2 ) {
		ERROR( "Could not read for finding size of $filename: $!", undef,
			   "noexit" );
		close( $fh );
		return undef;
    }
    if( ord substr( $buf, 0, 1 ) != 31 || ord substr( $buf, 1, 1 ) != 139 ) {
		ERROR( "Could not find gz size of non-gz file: $filename", undef,
			   "noexit" );
		close( $fh );
		return undef;
    }
    if( ! seek( $fh, -4, 2 ) ) {
		ERROR( "Could not seek for size of gz file $filename: $!",
			   undef, "noexit" );
		close( $fh );
		return undef;
    }
    if( read( $fh, $buf, 4 ) != 4 ) {
		ERROR( "Could not read for finding size of $filename: $!", undef,
			   "noexit" );
		close( $fh );
		return undef;
    }
    close( $fh );
    my $size = unpack( "V", $buf );
    return $size;
}

####
# Input: filename of zipped file
# Output: Output file name if successful gunzip
#         FALSE if error
# Note: If file extension is ".gz" the file will be renamed
#       If ".gz" extension is used, "force" must be used if orig file exists
sub gunzip_file {
    my( $filename, $force ) = @_;
    DEBUG( "gunzip_file( $filename )" );
    if( ! -f $filename ) {
		ERROR( "No such file: $filename", undef, "noexit" );
		return FALSE;
    }
    if( ! &is_gz_file( $filename ) ) {
		ERROR( "Cannot gunzip non-gzip file: $filename", undef, "noexit" );
		return FALSE;
    }
    my $outfilename = $filename;
    if( $outfilename =~ s/\.gz$// ) {
		if( -f $outfilename && ! $force ) {
			ERROR( "gunzip: Can not overwrite $outfilename", undef, "noexit" );
			return FALSE;
		}
    }
    my $gztmp = ".gz-tmp";
    my $infile = gzopen( $filename, "r" );
    if( ! defined $infile ) {
		ERROR( "gunzip: Could not open $filename: $gzerrno", undef, "noexit" );
		return FALSE;
    }
    my $outfile = new FileHandle;
    if( ! open( $outfile, ">$outfilename$gztmp" ) ) {
		$infile->gzclose();
		ERROR( "gunzip: Could not open $outfilename$gztmp: $!",
			   undef, "noexit" );
		return FALSE;
    }
    my $line;
    while( $infile->gzreadline( $line ) ) {
		if( ! print $outfile $line ) {
			ERROR( "gunzip: Could not write to $outfilename$gztmp: $!",
				   undef, "noexit" );
			$infile->gzclose();
			close( $outfile );
			unlink "$outfilename$gztmp";
			return FALSE;
		}
    }
    if( ! $infile->gzeof() ) {
		ERROR( "gunzip: Could not read $filename: $gzerrno", undef, "noexit" );
		$infile->gzclose();
		close( $outfile );
		unlink "$outfilename$gztmp";
		return FALSE;
    }
    $infile->gzclose();
    close( $outfile );
    if( ! rename "$outfilename$gztmp", $outfilename ) {
		ERROR( "Could not rename $outfilename$gztmp to $outfilename",
			   undef, "noexit" );
		return FALSE;
    }
    if( $filename ne $outfilename ) {
		DEBUG( "Removing $filename" );
		if( ! unlink $filename ) {
			ERROR( "Could not unlink $filename: $!", undef, "noexit" );
		}
    }
    DEBUG( "Successfully gunzipped $filename, output $outfilename" );
    return $outfilename;
}


####
# Input: filename of plain file
# Output: Output file name if successful gzip
#         FALSE if error
# Note: File extension ".gz" is added and the old file is removed
#       "force" must be used if gz file with the new name exists
sub gzip_file {
    my( $filename, $force ) = @_;
    DEBUG( "gzip_file( $filename )" );
    if( ! -f $filename ) {
		ERROR( "gzip: No such file: $filename", undef, "noexit" );
		return FALSE;
    }
    my $outfilename = $filename;
    $outfilename .= ".gz";
    if( -f $outfilename && ! $force ) {
		ERROR( "gzip: Can not overwrite $outfilename", undef, "noexit" );
		return FALSE;
    }
    my $outfile = gzopen( $outfilename, "w" );
    if( ! defined $outfile ) {
		ERROR( "gzip: Could not open $outfilename: $gzerrno",
			   undef, "noexit" );
		return FALSE;
    }
    my $infile = new FileHandle;
    if( ! open( $infile, "<$filename" ) ) {
		ERROR( "gzip: Could not open $filename: $!",
			   undef, "noexit" );
		$outfile->gzclose();
		unlink $outfilename;
		return FALSE;
    }
    my $line;
    while( $line = readline( $infile ) ) {
		if( ! $outfile->gzwrite( $line ) ) {
			ERROR( "gzip: Could not write to $outfilename: $gzerrno",
				   undef, "noexit" );
			$outfile->gzclose();
			close( $infile );
			unlink $outfilename;
			return FALSE;
		}
    }
    if( $! ) {
		ERROR( "gzip: Could not read $filename: $!", undef, "noexit" );
		$outfile->gzclose();
		close( $infile );
		unlink $outfilename;
		return FALSE;
    }
    $outfile->gzclose();
    close( $infile );
    if( ! unlink $filename ) {
		ERROR( "gzip: Could not unlink $filename: $!", undef, "noexit" );
		return FALSE;
    }
    DEBUG( "Successfully gzipped $filename, output $outfilename" );
    return $outfilename;
}


###############################################################################
#
# NAME:
#   rename_temp
# PURPOSE:
#   Renames temporary file to its real name
# ARGS:
#   original filename
# RETURNS:
#   nothing
#

sub rename_temp {
    my $filename = shift;

    if ($filename ne "-") {
		rename($filename . $_tmp_suffix, $filename) || 
			ERROR("Couldn\'t save summary file as $filename," .
				  " saved as $filename$_tmp_suffix, $!");
		DEBUG("Renamed file $filename$_tmp_suffix as $filename");
    }
}

sub remake_temp {
    my $filename = shift;

    if ($filename ne "-") {
		rename($filename, $filename . $_tmp_suffix) || 
			ERROR("Couldn\'t save summary file as $filename$_tmp_suffix," .
				  " saved as $filename, $!");
		DEBUG("Renamed file $filename as $filename$_tmp_suffix");
    }
}




###############################################################################
#
# NAME:
#   unlink_temp
# PURPOSE:
#   Unlinks temporary file
# ARGS:
#   original filename
# RETURNS:
#   nothing
#

sub unlink_temp {
    my $filename = shift;

    if( $filename ne "-" && ! unlink $filename . $_tmp_suffix ) {
		ERROR( "Could not unlink_temp $filename.", undef, "noexit" );
    }
}


###############################################################################
#
# NAME:
#   write_pid_file
# PURPOSE:
#   Writes the pid in pidfilename
# ARGS:
#   pidfilename 
# RETURNS:
#   nothing
#

sub write_pid_file {
    my $filename = shift;
    
    if (open(PID, ">" . $filename)) {
		print PID $$, "\n";
		close PID;
    } else {
		WARNING("Unable to open pidfile for writing, $!");
    }
}


###############################################################################
#
# NAME:
#   get_pid_from_pid_file
# PURPOSE:
#   Return the PID of a daemon if present.  If daemon has cleaned up, the
#   file will not exist.  undef value will be returned.
# ARGS:
#   filename to pid-file
# RETURNS:
#   pid if pid is OK. -1 if error in pid file.  undef if non-existent.
#

sub get_pid_from_pid_file {
    my ( $filename ) = @_;

    my $pid;

    if ( -e $filename ) {

		if ( open(PID, "<". $filename) ) {
			$pid = <PID>;
			chomp $pid;

			if ( $pid !~ m/^\d+$/ ) {
				WARNING("Garbage in pid file, $filename ($pid)");
				$pid = -1;
			}

			close PID;
		} else {
			WARNING("Unable to open pidfile for reading, $!");
		}

    } else {
		DEBUG("No pid file to read ($filename)");
    }

    return $pid;
}


###############################################################################
#
# NAME:
#   file_of_lock
# PURPOSE:
#   Return filename og lock
# ARGS:
#   lock link name
# RETURNS:
#   file name
#

sub file_of_lock {
    my ($lock_link_name) = @_;
    
    $lock_link_name =~ /(.*)$_lock_suffix/;
    return $1;
}


###############################################################################
#
# NAME:
#   _read_lock
# PURPOSE:
#   Read lock
# ARGS:
#   lock link name
# RETURNS:
#   create time, create pid, create program
#

sub _read_lock {
    my $lock_link_name = shift;
    
    return rdlink($lock_link_name);
}


###############################################################################
#
# NAME:
#   _write_lock
# PURPOSE:
#   Write lock
# ARGS:
#   lock link name, create time, create pid, create program
# RETURNS:
#   1 on success, 0 otherwise
#

sub _write_lock {
    my $lock_link_name = shift;
    my $create_time    = shift;
    my $create_pid     = shift;
    my $create_prog    = shift;
    
    return _mklink($lock_link_name,
				   $create_time .
				   $_lock_info_delim .
				   $create_pid .
				   $_lock_info_delim .
				   $create_prog);
}


###############################################################################
#
# NAME:
#   lock
# PURPOSE:
#   Lock file exclusively
# ARGS:
#   file name
# RETURNS:
#   TRUE on success, FALSE otherwise
#

sub lock {
    my $file_name = shift;
    
    my $lock_link_name = $file_name . $_lock_suffix;
    
    # Try creating lock
    if (&_write_lock($lock_link_name, time(), $$, &PROGNAME)) {
		
		# Locked
		return TRUE;
		
    } else {
		# Couldn't create lock.  Try reading it.
		my $lock_info = &_read_lock($lock_link_name);
		
		if (defined($lock_info)) {
			
			my ($time, $pid, $prog) = split($_lock_info_delim, $lock_info);
			
			# Lock timed out?
			if (time() - $time > $_lock_timeout) {
				
				DEBUG("Lock $lock_link_name timed out, trying to steal it");
				
				# ATOMIC BEGIN
				
				if (unlink($lock_link_name)) {
					
					# Race condition here!!
					
					if (&_write_lock($lock_link_name, time(), $$, &PROGNAME)) {
						DEBUG("Stole lock $lock_link_name successfully.");
						return TRUE;
						
						# ATOMIC END
						
					} else {
						DEBUG("Couldn't steal $lock_link_name. Write failed.");
						# Assume someone else have written lock
						return FALSE;
					}
					
				} else {
					DEBUG("Couldn't unlink timed out lock $lock_link_name.");
					# Assume someone else have unlinked lock
					return FALSE;
				}
				
			} else {
				DEBUG("Lock $lock_link_name didn't time out.");
				return FALSE;
			}
		} else {
			# Couldn't write lock and read lock failed.
			# Assume we're in the race condition above.
			DEBUG("No lock info and couldn't write one.".
				  "  Assuming race condition (or wrong permissions?)");
			return FALSE;
		}
    }
    
    ERROR("When locking $lock_link_name, abnormal program point reaced!");
}


###############################################################################
#
# NAME:
#   unlock
# PURPOSE:
#   Unlock file
# ARGS:
#   file name
# RETURNS:
#   TRUE on success, FALSE otherwise
#

sub unlock {
    my $file_name = shift;
    
    my $lock_link_name = $file_name . $_lock_suffix;
    
    my $lock_info = &_read_lock($lock_link_name);
    
    if (defined($lock_info)) {
		
		my ($time, $pid, $program) = split($_lock_info_delim, $lock_info);
		
		if ($$ == $pid || (time() - $time > $_lock_timeout)) {
			
			# If we own the lock or it has times out, try unlinking.
			
			if (unlink($lock_link_name)) {
				return TRUE;
			} else {
				# Do not unlock files on error, as this causes a infinit loop
				ERROR("Couldn't unlink $lock_link_name: $!", 
					  "no_unlock", "noexit");
				return FALSE;
			}
			
		} else {
			
			# If not, error.
			
			ERROR("Can't unlock file $file_name.  Locked by " .
				  "program $program (pid $pid)", undef, "noexit");
			return FALSE;
		}
		
    } else {
		WARNING("File $file_name seems to be unlocked already.");
		return TRUE;
    }
}


###############################################################################
#
# NAME:
#   locked
# PURPOSE:
#   Get file lock status
# ARGS:
#   none
# RETURNS:
#   TRUE if locked, FALSE otherwise
#

sub locked {
    my $file_name = shift;
    my $lock_link_name = $file_name . $_lock_suffix;
    my $lock_info = &_read_lock($lock_link_name);
    if (defined($lock_info)) {
		my ($time, $pid, $prog) = split($_lock_info_delim, $lock_info);
		# Lock timed out?
		if (time() - $time > $_lock_timeout) {
			DEBUG("Lock $lock_link_name timed out.");
			return FALSE;
		} else {
			return TRUE;
		}
    } else {
		return FALSE;
    }
}


###############################################################################
#
# NAME:
#   account_data_file
# PURPOSE:
#   check to see if the directory structure is there, make symbolic
#   links from week structure to month structure if we create something
# ARGS:
#   type of data, time interval, date
# RETURNS:
#   global path name for data file
#

sub account_data_file {
    my ($datatype, $time_interval, $date, $ro, $dirname) = @_;

    return account_data_dir($datatype,
							$time_interval,
							$date,
							$ro,
							$dirname) . "${filesep}data";
}


###############################################################################
#
# NAME:
#   account_data_dir
# PURPOSE:
#   check to see if the directory structure is there, make symbolic
#   links from week structure to month structure if we create something
# ARGS:
#   type of data, time interval (seconds), date
# RETURNS:
#   global path name for data dir
#

sub account_data_dir {
    my ($datatype, $time_interval, $date, $ro, $dirname_raw) = @_;
    my ($linkfilename);

    my ($day, $month, $year) = split(/\s*[-.]\s*/, $date);

    if ($year < 1990 || ! &Date::Calc::check_date($year, $month, $day)) {
		ERROR("Date '$date' is not a valid date");
    }
    if( ! defined $dirname_raw ) {
		$dirname_raw                 = &DATA_DIR;
    }
    DEBUG( "Dirname_raw: $dirname_raw" );
    my $dirname = "$dirname_raw$filesep$datatype";
    &assert_dir($dirname) unless defined($ro);

    $dirname = "$dirname${filesep}M";
    &assert_dir($dirname) unless defined($ro);

    $dirname = "$dirname$filesep$year";
    &assert_dir($dirname) unless defined($ro);

    if ($time_interval == 31104000) { # Year resolution
		goto file;
    }

    $dirname = "$dirname$filesep$month";
    &assert_dir($dirname) unless defined($ro);

    if ($time_interval == 2592000) {  # Month resolution
		goto file;
    }

    $dirname = "$dirname$filesep$day";
    &assert_dir($dirname) unless defined($ro);

    # Now $dirname contains the day

	# Only regular (numeric) data types have week structure
	if ( $datatype =~ /^\d+$/ ) {
		my ($week, $year_w) = &Date::Calc::Week_of_Year($year, $month, $day);
		my $weekday         = &Date::Calc::Day_of_Week($year, $month, $day);

		$linkfilename = "$dirname_raw$filesep$datatype";
		# This must exist, have already called mkdir for this one

		$linkfilename = "$linkfilename${filesep}W";
		&assert_dir($linkfilename) unless defined($ro);

		$linkfilename = "$linkfilename$filesep$year_w";
		&assert_dir($linkfilename) unless defined($ro);

		$linkfilename = "$linkfilename$filesep$week";
		&assert_dir($linkfilename) unless defined($ro);

		if ($time_interval == 604800) {  # Week resolution
			$dirname = $linkfilename;
			goto file;
		}

		$linkfilename = "$linkfilename$filesep$weekday";

		# Linking the day under week structure to month structure
		if (!(islink( $linkfilename )) && !defined($ro)) {
			if( $^O eq "MSWin32" ) {
				if( -e $linkfilename && ! -d $linkfilename ) {
					ERROR("File exists and is not a symbolic link: $linkfilename");
				}
			} elsif (-e $linkfilename ) {
				ERROR("File exists and is not a symbolic link: $linkfilename");
			}
			my $dirlink = "..$filesep..$filesep..${filesep}M$filesep$year$filesep$month$filesep$day";
			DEBUG( "Linking from $dirlink -> $linkfilename" );
			unless (_mklink($linkfilename,$dirlink)) {
				ERROR("Unable to create symbolic link: $linkfilename -> $dirlink");
			}
		}
	}

    if ($time_interval == 86400) {   # Day resolution
		goto file;
    }

    # High resolution
    
    $dirname = "$dirname$filesep$time_interval";
    &assert_dir($dirname) unless defined($ro);
    
  file:
    return $dirname;
}


###############################################################################
#
# NAME:
#   archive_data_file
# PURPOSE:
#   
# ARGS:
#   none
# RETURNS:
#   nothing
#

sub archive_data_file {
    my $filename = shift;
    
    if (! &locked($filename)) {
		
		if (&lock($filename)) {
			
		} else {
			ERROR("Couldn't lock $filename when unlocked: $!");
			return;
		}
    } else {
		ERROR("$filename IS LOCKED.  YOU HAVE SCREWED UP BADLY.  GO AWAY!");
    }
}


###############################################################################
#
# NAME:
#   append_datafile
# PURPOSE:
#   Append unlocked temporary datafile to the real datafile
#   This action is atomic to ensure consistency.
# ARGS:
#   temporary datafile, destination dir
# RETURNS:
#   TRUE on success, FALSE otherwise
#

sub append_datafile {
    my $datafile = shift;
    my $dest_dir = shift;

    my $cpy_suffix = ".cpy";
    my $dest_file_name = $dest_dir . "/data";
    

    unless (-f $dest_file_name) {
		# Create the new datafile, because it doesn't exists
		my $time = time();
		unless (open(NONE, ">" . $dest_file_name)) {
			ERROR("Unable to create file: $dest_file_name, $!");
		}
		close(NONE);
    }

    # Return if destiniation is locked
    if (&locked($dest_file_name)) {
		return FALSE;
    }
    if (!&lock($dest_file_name)) {
		return FALSE;
    }
    
    #
    # Make a copy which we do the appending to
    #
    open(DST_FILE,     "<" . $dest_file_name              ) || return FALSE;
    open(DST_CPY_FILE, ">" . $dest_file_name . $cpy_suffix) || return FALSE;

    while (<DST_FILE>) {
		print DST_CPY_FILE;
    }

    close DST_FILE;

    # 
    # Append file to copy
    # 
    
    open(SRC_FILE, "<" . $datafile) || return FALSE;
	
    while (<SRC_FILE>) {
		print DST_CPY_FILE;
    }
	
    close(SRC_FILE);
    close(DST_CPY_FILE);
    
    # Move changes to the real data file
    unless (rename($dest_file_name . $cpy_suffix, $dest_file_name)) {
		FATAL("Unable to rename temporary file.  Keeping lock.");;
    }

    # All went well.  Unlock and exit.
    if (! &unlock($dest_file_name) ) {
		FATAL("Unable to unlock file $dest_file_name.  " .
			  "Manual intervetion required.");
    }

    # Success
    return TRUE;
}





###############################################################################
#
# NAME:
#   read_config_array_file
# PURPOSE:
#   reads an array description in file, makes array
# ARGS:
#   filename of configfile
#   reference to a scalar indicating error found
# RETURNS:
#   the array
#

sub read_config_array_file {
    my ($filename, $error) = @_;
    
    unless (open(FILE, $filename)) {
		ERROR("Can't open array file $filename, $!");
    }

    my $array="";

    my $line;
    while (defined($line = <FILE>)) {
		if ($line =~ /^\s*#/) {
			next;
		}
		$array .= $line;
    }

    close FILE;

    $array =~ s/\s//g;

    if( length( $array ) < 2 ) {
		$array = "()";
    }


    if( defined $error ) {
		$$error = 0;
    }
    my @value = OpeniT::Config::make_array($array, undef, $error );
    if( defined $error && $$error ) {
		DEBUG( "Failed to read '$filename'." );
		@value = ();
    }

    return @value;    
}



###############################################################################
#
# NAME:
#   save_config_array_file
# PURPOSE:
#   saves an array in a file
# ARGS:
#   filename, array to save
# RETURNS:
#   TRUE on success
#

sub save_config_array_file {
    my ($filename, @array) = @_;

    unless (open(FILE, ">" . $filename . ".tmp")) {
		ERROR_MESSAGE("Can't open array file $filename, $!");
    } else {
		my $old_handle = select();
		select(FILE); $| = TRUE;
		select($old_handle);
		if(! _save_array(\*FILE, @array)) {
			ERROR_MESSAGE("Can't write new '$filename', skipping");
			unlink("${filename}.tmp");
			return FALSE;
		}
		close FILE;
        &_duplicate_file_modes($filename, $filename . ".tmp");
        rename($filename . ".tmp", $filename);
        VERBOSE("save_config_array_file: renamed $filename.tmp\n");
        return TRUE;
    }
    return FALSE;
}

###############################################################################
#
# NAME:
#   _duplicate_file_modes
# PURPOSE:
#   copies file modes from one file to another
# ARGS:
#   file from, file to
# RETURNS:
#   TRUE on success
#

sub _duplicate_file_modes {
    my ($file_from, $file_to) = @_;
    my (@from_stat, $mode);

    unless(@from_stat = stat($file_from)) {
        return FALSE;
    }
    $mode = $from_stat[2] & 07777; # 2 = file mode
    if (chmod($mode, $file_from, $file_to)) { # Is TRUE/FALSE redefined?
        return TRUE;
    }
    return FALSE;
}


###############################################################################
#
# NAME:
#   _save_array
# PURPOSE:
#   
# ARGS:
#   none
# RETURNS:
#   1 if write succeds, else 0
#

sub _save_array {
    my ($FILE, @array) = @_;

    my $ret = 1;
    
    $ret = $ret && print $FILE "(";
    foreach my $i (0 .. $#array) {
		if (ref($array[$i]) eq "ARRAY") {
			$ret = $ret && _save_array($FILE, @{$array[$i]});
			if ($i != $#array) {
				$ret = $ret && print $FILE ",";
			}
		} else {
			my $item = $array[$i];
			$item =~ s/ /^/g;
			if ($i == $#array) {
				$ret = $ret && print $FILE "$item";
			} else {
				$ret = $ret && print $FILE "$item,";
			}	
		}
    }
    $ret = $ret && print $FILE ")\n";    

    return $ret;
}


###############################################################################
#
# NAME:
#   get_datafile_time_interval
# PURPOSE:
#   
# ARGS:
#   list of files
# RETURNS:
#   first date found, last date found
#
sub get_datafile_time_interval {
    my (@files) = @_;
    my $first = time(); # Data should be older that current time
    my $last = 0; 
    my ($cur_first, $cur_end);

    my ($file, $line);

    foreach $file (@files) {
		DEBUG("Finding dates in datafile '$file'");

		if(! open(INP, $file)) {
			WARNING("Couldn't open data file '$file'"); # Error or Warn?
			next; # Skip this file
		}

		# Skim until the first non comment line has been found
		$line = <INP>;
		while($line =~ /^\#/ ) {
			$line = <INP>;
		}

		# Test if we have data
		if(! defined($line)) {
			# No data in file?
			NOTICE("No data in file '$file'");
			close(INP);
			next; # Skip this file
		} else {
			# We can find start data
			$cur_first = (split(":", $line))[1];

			$cur_end = $cur_first;
			# Loop through file to find end date
			while(defined($line = <INP>)) {
				next if($line =~ /^\#/); # Skip comment
				last if($line !~ /:/);   # Leave when signature found
				$cur_end = (split(":", $line))[1];
			}
			close(INP);
		}

		DEBUG("Local limits found: $cur_first - $cur_end");

		# Check against current limits
		$first = $cur_first if($cur_first < $first);
		$last = $cur_end if($cur_end > $last);
    }

    DEBUG("Global limits found: $first - $last");

    return ($first, $last);
}


###############################################################################
#
# NAME:
#   get_temp_file_name
# PURPOSE:
#   
# ARGS:
#   dir, file
# RETURNS:
#   temporary filename
#

sub get_temp_file_name {
    my $tmp_dir = shift;
    my $tmp_file  = shift;
    my $tmp_suffix = shift;

    # Use /tmp if no dir is given
    $tmp_dir  = "/tmp" unless $tmp_dir;
    $tmp_file = "data" unless $tmp_file;
    $tmp_suffix = $_tmp_suffix unless $tmp_suffix;
    
    # filename
    $tmp_file = "$tmp_dir$filesep$tmp_file-" . time() . "-$$-";
    
    my $n = 1;
    
    while (-f "$tmp_file$n$tmp_suffix") {
		$n++;
    }
    
    $tmp_file .= $n . $tmp_suffix;
    
    # Remove redundant /'s
    $tmp_file =~ s!/+!/!g;
    
    return $tmp_file;
}



###############################################################################
#
# NAME:
#   recursive_list_of_files
# PURPOSE:
#   Lists files in a directory (like glob does, but glob is unstable)
# ARGS:
#   directory, matching regexp
# RETURNS:
#   list of matching files
#

sub recursive_list_of_files {
    my ($dir, $regexp) = @_;
    
    my @answer = &list_of_files( $dir, $regexp);
    return @answer;
}


###############################################################################
#
# NAME:
#   flat_list_of_files
# PURPOSE:
#   
# ARGS:
#   none
# RETURNS:
#   nothing
#

sub flat_list_of_files {
    my $dir    = shift;
    my $regexp = shift;
    my $skip_link = shift;
    # Return matches
    return grep(/$regexp/,
				&_find_all_files($dir, "non-recursive", $skip_link));
}



###############################################################################
#
# NAME:
#   flat_list_of_n_files
# PURPOSE:
#   
# ARGS:
#   directory
#   regexp
#   number of wanted files
#   ignore locked files
# RETURNS:
#   nothing
#

sub flat_list_of_n_files {
    my $dir    = shift;
    my $regexp = shift;
    my $n      = shift;
    my $locked = shift;

    if( ! defined $locked ) {
		$locked = FALSE;
    }

    if( $^O eq "MSWin32" && $dir =~ m/W\\\d+\\\d+\\\d/ ) {
		return ();
    }

    my $dir_handle = new DirHandle $dir;
    my @files = ();

    # Remove trailing /
    $dir =~ s!/*$!!;

    if( ! defined( $dir_handle ) ) {
		WARNING( "Couldn't read dir $dir: $!" );
		return ();
    } else {
		my $dir_entry;

		# Find files and dirs
		while( defined( $dir_entry = $dir_handle->read ) && $n > 0 ) {
			next if( $dir_entry eq "." || $dir_entry eq ".." );

			my $full_path = "$dir/$dir_entry";
			if( ! -d $full_path && $full_path =~ m/$regexp/ ) {
				if( $locked && islink("$full_path$_lock_suffix") ) {
					next;
				}
				push @files, $full_path;
				$n--;
			}
		}
    }

    undef $dir_handle;

    # Return matches
    return @files;
}



###############################################################################
#
# NAME:
#   list_of_files
# PURPOSE:
#   Lists files in a directory (like glob does, but glob is unstable)
# ARGS:
#   directory, matching regexp
# RETURNS:
#   list of matching files
#

sub list_of_files {
    my $dir    = shift;
    my $regexp = shift;
    my $skip_link = shift;
    # Return matches
    return grep(m|$regexp|, &_find_all_files($dir, "be_recursive", $skip_link));
}

###############################################################################
#
# NAME:
#   list_of_links
# PURPOSE:
#   Lists links in a directory
# ARGS:
#   directory, matching regexp
# RETURNS:
#   list of matching links
#

sub list_of_links {
    my $dir    = shift;
    my $regexp = shift;
    # Return matches
    return grep(m|$regexp|, &_find_all_links($dir, "be_recursive"));
}

###############################################################################
#
# NAME:
#   list_of_dir
# PURPOSE:
#   List files/dirs matching regexp in a directory with full path
# ARGS:
#   directory to find files/subdirs in, regexp to match
# RETURNS:
#   list of files matched with full path
#

sub list_of_dir {
    my ($path, $regexp, $skip_link) = @_;
    my ($dir, @dirs);

    if( $path =~ m#\.lock$# ) {
		return undef;
    }

    if( $skip_link && $^O ne "MSWin32" && -l $path ) {
		return undef;
    }

    if(! opendir(DIR, $path)) {
		return;
    }

    # Read dirs, if regexp matches dir, prepend path and put in return array
    foreach $dir (readdir(DIR)) {
		if(grep{ /$regexp/ } $dir) { 
			push @dirs, "$path$filesep$dir";
		}
    }

    closedir(DIR);

    return @dirs;
}

###############################################################################
#
# NAME:
#   _find_all_files
# PURPOSE:
#   Finds all files in directory tree
# ARGS:
#   directory name
# RETURNS:
#   list of files
# NOTES:
#   This function may barf if directory tree is very deep, that is,
#   deeper than the number of available open files allowed.
#

sub _find_all_files {
    my ($dir_name, $recursive, $skip_link) = @_;

    if ( $^O ne "MSWin32" && -l $dir_name && $skip_link) {
		return ();
    }

    my $dir_handle = new DirHandle $dir_name;
    my @files = ();
    my @dirs  = ();

    # Remove trailing /
    $dir_name =~ s!/*$!!;

    if (! defined($dir_handle)) {
		WARNING("Couldn't read dir $dir_name: $!");
		return ();
    } else {
		my $dir_entry;

		# Find files and dirs
		while (defined($dir_entry = $dir_handle->read)) {
			next if ($dir_entry eq "." || $dir_entry eq "..");
			if (-d "$dir_name$filesep$dir_entry" ) {
				push @dirs, "$dir_name$filesep$dir_entry";
			} else {
				push @files, "$dir_name$filesep$dir_entry";
			}
		}
    }

    undef $dir_handle;

    my $dir;

    if ( $recursive eq "be_recursive" ) {
		# Traverse dirs
		foreach $dir (@dirs) {
			push @files, &_find_all_files($dir, $recursive, $skip_link);
		}
    }

    return @files;
}

###############################################################################
#
# NAME:
#   _find_all_links
# PURPOSE:
#   Finds all links in directory tree
# ARGS:
#   directory name
# RETURNS:
#   list of links
# NOTES:
#   This function may barf if directory tree is very deep, that is,
#   deeper than the number of available open files allowed.
#

sub _find_all_links {
    my ($dir_name, $recursive) = @_;

    if ( $^O ne "MSWin32" && -l $dir_name) {
	return ();
    }

    my $dir_handle = new DirHandle $dir_name;
    my @links = ();
    my @dirs  = ();

    # Remove trailing /
    $dir_name =~ s!/*$!!;

    if (! defined($dir_handle)) {
	WARNING("Couldn't read dir $dir_name: $!");
	return ();
    } else {
	my $dir_entry;

	# Find links and dirs
	while (defined($dir_entry = $dir_handle->read)) {
	    next if ($dir_entry eq "." || $dir_entry eq "..");
	    if (-l "$dir_name$filesep$dir_entry" ) {
		push @links, "$dir_name$filesep$dir_entry";
	    }
		elsif ( -d "$dir_name$filesep$dir_entry" ) {
		push @dirs, "$dir_name$filesep$dir_entry";
	    }
		elsif ($^O eq "MSWin32" && $dir_entry =~ /^\d+$/) {
		push @links, "$dir_name$filesep$dir_entry";
		}
	}
    }

    undef $dir_handle;

    my $dir;

    if ( $recursive eq "be_recursive" ) {
	# Traverse dirs
	foreach $dir (@dirs) {
	    push @links, &_find_all_links($dir, $recursive);
	}
    }

    return @links;
}

###############################################################################
#
# NAME:
#   check_lock_for_removal
# PURPOSE:
#   Checks if a lock is dangling and can be removd.  Paranoia stuff.
# ARGS:
#   lock link name
# RETURNS:
#   nothing
#

sub check_lock_for_removal {
    my $lock_link_name = shift;
    
    DEBUG("Looking at lock $lock_link_name for removal");

    my $file_name = file_of_lock($lock_link_name);
    
    if (-e $file_name) {
		if (! -f $file_name) {
			WARNING("Lock $lock_link_name not of plain file $file_name");
		}
    } else {
		
		DEBUG("Trying to remove $lock_link_name");
		
		if (unlink($lock_link_name)) {
			DEBUG("Removed lock $lock_link_name");
		} else {
			WARNING("Unable to remove lock $lock_link_name: $!");
		}
    }
}


###############################################################################
#
# NAME:
#   check_file_for_removal_on_change
# PURPOSE:
#   Removes (unlinks) file, if it hasn't been changed since $older_than
#   But if $keep_unread is set, unread files may have a longer timeout
# ARGS:
#   filename, $keep_period, keep_unread_period
# RETURNS:
#   true if we remove, false otherwise
#

sub check_file_for_removal_on_change {
    my ($file, $oldness, $oldness_unread) = @_;

    return _test_file_for_delete( $file, 1, $oldness, $oldness_unread );
}


###############################################################################
#
# NAME:
#   check_file_for_removal_on_access
# PURPOSE:
#   Removes (unlinks) file, if it hasn't been read since $older_than
#   But if $keep_unread is set, unread files may have a longer timeout
# ARGS:
#   filename, $keep_period, keep_unread_period
# RETURNS:
#   true if we remove, false otherwise
#

sub check_file_for_removal_on_access {
    my ($file, $oldness, $oldness_unread) = @_;

    return _test_file_for_delete( $file, 0, $oldness, $oldness_unread );
}

###############################################################################
#
# NAME:
#   _test_file_for_delete
# PURPOSE:
#   Internal routine for check removal procesures
# ARGS:
#   none
# RETURNS:
#   nothing
#

sub _test_file_for_delete {
    my ($file, $time_index, $oldness, $oldness_unread) = @_;
    my $current_time = time();

    if ( !defined $oldness_unread ) {
		$oldness_unread = 0;
    }

    DEBUG("_tffd: rm? $file, $time_index, $oldness, $oldness_unread");

    my @time_list               =  (stat($file))[8,9,10];
    my ($atime, $mtime, $ctime) =  @time_list;
    

    if ( !defined( $atime ) ) {
		WARNING("Unable to stat file $file"); 
		return FALSE;
    }
    

    my $chk_time = $current_time - $time_list[$time_index];

    if ( $chk_time > $oldness ) {
		# File is old enough
		if ( ($mtime != $atime ) ) {
			# It has been read since creation
			DEBUG("Removing $file $current_time - $atime - $mtime"); 
			unlink $file;
			return TRUE;
		} else {
			# It has never been read (it sure looks like it)
			if ( ($current_time - $atime) > $oldness_unread ) {
				DEBUG("Removing $file $current_time - $atime - $mtime"); 
				unlink $file;
				return TRUE;
			} else {
				DEBUG("Keeping unread file $current_time (a:$atime m:$mtime)");
			} 
		}
		
    } else {
		DEBUG("Keeping new $file t:$current_time (chk:$chk_time)");
    }
    
    return FALSE;
}


###############################################################################
#
# NAME:
#   get_canonical_filename
# PURPOSE:
#   Find the filename of a file/dir without following any links
# ARGS:
#   A file name (pwd will be added to local filenames)
# RETURNS:
#   The real path to the filename/directory (may be the same as argument)
#   Undefined if the name does not point to a file or a directory

sub get_canonical_filename {
    my ( $filename ) = @_;
    
    # Wrapper that removes double // (allowed but ignored)
    $filename =~ s^//^/^g;
    $filename = _do_get_canonical_filename( $filename );
    $filename =~ s^//^/^g;
    
    # Remove trailing $filesep from file name (unless it is /)
    if ( substr( $filename, -1, 1 ) eq $filesep && length($filename) > 1) {
		chop $filename;
    }
	
    return $filename;
}

sub _do_get_canonical_filename {
    my ( $filename ) = @_;

    DEBUG("Trying to find canonical filename for $filename");

    my $index = 0;   # This points to the the next part to check in followParts
    my @followParts; # Parts of the file we will follow
    my $number_of_follows = 0;
    
    if ( $^O ne "MSWin32" && substr($filename, 0, 1) eq $filesep ||
		 $^O eq "MSWin32" && $filename =~ m/^\w:/) {
		# Global
		DEBUG(" Looking at global file: $filename");
    } else {
		# Local
		my $pwd = getcwd();
		$filename = "$pwd$filesep$filename";
		DEBUG(" Looking at local file: $filename");
    }
    


    @followParts = split('/', $filename); # Parts of the file we will follow
    shift @followParts; # remove undef value

    if (! @followParts) {
		# We have only root
		return $filesep;
    }
    
    # While we have a new part of the filename to follow
    while( $index < @followParts ) {

		DEBUG(" Index: $index");

		$number_of_follows++;
		
		if ( $number_of_follows > 200 ) {
			ERROR("Folloed file ($filename) too long, it may be a loop");
			exit;
		}
		
		my $newPart = $followParts[$index];

		if ($newPart eq ".") {
			splice( @followParts, $index, 1 );
			DEBUG("  Skipping '.'");
			next;
		}
		
		if ($newPart eq "..") {
			my @removed = splice( @followParts, $index -1, 2 );
			$index--;
			DEBUG("  Skipping '..' (removing @removed)");
			next;
		}
		
		my $check_file = $filesep . join( $filesep, @followParts[0..$index] );
		DEBUG("  Following $check_file");

		if (islink( $check_file) ) { # NOTE: This does not work on Windows
			# but it is not used anyway KY thinks
			my $link = rdlink($check_file);
			my @linkParts = split($filesep, $link); #The parts in the link to follow
			
			if ($linkParts[0] eq "") {
				# Global link
				shift @linkParts;
				splice( @followParts, 0, $index + 1, @linkParts ); # Replace
			} else {
				# Relative link
				splice( @followParts, $index, 1, @linkParts ); # Insert
			}
			
		} elsif (-d $check_file) {

			if (($index + 1) == @followParts) {
				my $dir_name = $filesep . join( $filesep, @followParts[0..$index] );
				DEBUG("FILENAME is a dir, returning '$dir_name'");
				return $dir_name;
			} else {
				DEBUG("More to follow ($index " . ( scalar(@followParts) -1) . 
					  ")");
				$index++;
			}
			
		} else {
			
			if (! -e $check_file) {
				# NOT FOUND!
				DEBUG("FILENAME not found $check_file");
				return undef;
			} else {
				if (($index + 1) == @followParts) {
					DEBUG("Found canonical filename $check_file");
					return $filesep . join( $filesep, @followParts[0..$index] );
				} else {
					DEBUG( "More to go in filename, but reaced the end." );
					DEBUG( " $index");
					DEBUG( " @followParts");
					return undef;
				}
			}
		}
    }
    
    return undef;
}


###############################################################################
#
# NAME:
#   sort_psm_file
# PURPOSE:
#   Sort psm datafile content to new file
# ARGS:
#   file name, new sorted file name
# RETURNS:
#   1 if ok else 0
#

sub sort_psm_file {
    my ($input, $output) = @_;

    my $sorted   = new FileHandle( "$output", "w");

    my %entries = ();
    my $uniq_index = 0;
    my $classification;
    my $values;

    my $unsorted = new FileHandle( "$input", "r");
    if (! defined( $unsorted ) ) {
		# In case of some error reading file, ignore sorting.
		ERROR("ERROR reading $input, $!", 0, 1);
		return 0;
    }

    while ( defined( $classification = <$unsorted> ) ) {
		$values = <$unsorted>;
		$uniq_index++;

		$entries{ $classification . "%$values%$uniq_index" } = $values;
    }

    foreach $classification ( sort psm_sort_orderer ( keys( %entries ) ) ) {
		$values = $entries{ $classification };
		$classification =~ 
			m/^(.*)%.*%\d+$/s; # remove uniq idenficator and values
		$classification = $1;
		print $sorted $classification, $values;
    }

    return 1;
}


###############################################################################
#
# NAME:
#   psm_sort_orderer
# PURPOSE:
#   Compare psm records for sorting
# ARGS:
#
# RETURNS:
#
#

sub psm_sort_orderer ($$) {
    my ($a, $b) = @_;

    my ($a_time, $a_rest) = (split(":", $a, 3))[1,2];
    my ($b_time, $b_rest) = (split(":", $b, 3))[1,2];

    my $val = $a_time <=> $b_time || $a_rest cmp $b_rest;

    return $val;
}


##
#  Find first $num line(s) of a file, and close the file. If the file is
#  zipped, it should also work. If it is zipped and a format error is
#  detected, or if another kind of error is detected, give a message and
#  return undef.
#  Return first $num line(s) or all file if there are fewer lines than
#  $num. Note that "" may be returned, but it is not an error condition.
#  The return value is a string scalar.
#
sub head_of_file {
    my( $file, $num ) = @_;
    DEBUG( "Looking for head of $file" );
    if( ! -f $file ) {
		ERROR( "Can not find top of file. No such file: $file.",
			   undef, "noexit" );
		return undef;
    }
    if( -z _ ) {  # Check quickly to possibly avoid slower gz check
		DEBUG( "Empty file $file" );
		return "";
    }
    my $lines = "";
    if( &is_gz_file( $file ) ) {
		my $fh = gz_infile( $file );
		if( ! defined $fh ) {
			ERROR( "Can not find top of file. Failed to open: $file.",
				   undef, "noexit" );
			return undef;
		}
		my $line = $fh->gz_readline();
		while( $num > 0 && defined $line ) {
			$lines .= $line;
			$num--;
			$line = $fh->gz_readline();
		}
		if( $num > 0 && $gzerrno ) {
			ERROR( "gzerrno on $file: $gzerrno", undef, "noexit" );
			$lines = undef;
			$fh->close();
		}
		$fh->close();
		return $lines;
    }
    my $fh = infile( $file );
    if( ! defined $fh ) {
		ERROR( "Can not find top of file. Failed to open: $file.",
			   undef, "noexit" );
		return undef;
    }
    $! = undef;
    my $line = readline( $fh );
    while( $num > 0 && defined $line ) {
		$lines .= $line;
		$num--;
		$! = undef;
		$line = readline( $fh );
    }
    if( $num > 0 && $! ) {
		ERROR( "Read error $file: $!", undef, "noexit" );
		$lines = undef;
		close( $fh );
    }
    close( $fh );
    DEBUG( "Head line(s):\n$lines" );
    return $lines;
}


sub _mklink {
    my( $from, $to ) = @_;
    if( $^O eq "MSWin32" ) {
		$from =~ s#/#\\#g;
		if( -e $from ) {
			DEBUG( "from-link exists: $from" );
			return FALSE;
		}
		if( ! open( LNOUT, ">$from" ) ) {
			DEBUG( "no link-fh ($from) $!" );
			return FALSE;
		}
		if( ! print LNOUT $to ) {
			DEBUG( "Failed to write to link ($to): $!" );
			close LNOUT;
			return FALSE;
		}
		close( LNOUT );
		DEBUG( "OK link" );
		return TRUE;
    }
    return symlink( $to, $from );
}

sub rdlink {
    my( $link ) = @_;
    if( $^O eq "MSWin32" ) {
		$link =~ s#/#\\#g;
		DEBUG( "rdlink Link $link" );
		if( ! open( LNIN, "<$link" ) ) {
			DEBUG( "Could not open link. Probably no link: $!" );
			return undef;
		}
		my $to = readline( *LNIN );
		if( ! defined $to ) {
			DEBUG( "Failed to read link $link: $!" );
		}
		close LNIN;
		DEBUG( "To: $to" );
		return $to;
    }
    return readlink $link;
}

sub _rmlink {
    my( $link ) = @_;
    if( $^O eq "MSWin32" ) {
		$link =~ s#/#\\#g;
    }
    unlink $link;
}

sub islink {
    my( $link ) = @_;
    if( $^O eq "MSWin32" ) {
		$link =~ s#/#\\#g;
		return -f $link;
    }
    return -l $link;
}

sub build_command {
    my ($bin) = @_;
	my $full_path = &OpeniT::Config::BIN_DIR() . "$filesep$bin";
	if( ! -x $full_path && ! -x "$full_path.exe" && defined $ENV{ "ALTUS" } ) {
		my $altus = $ENV{ "ALTUS" };
		$full_path =
			"$altus${filesep}src${filesep}perl${filesep}source$filesep$bin";
		my $perl_bin = $^X;
		if( $perl_bin =~ m/perl(.exe)?$/ ) {
			$full_path = "\"$perl_bin\" \"$full_path\"";
		}
	}
	my $command = $full_path;
	if( $command !~ m/^".*"$/ ) {
		$command = "\"$command\"";
	}
    return $command;
}



1;

__END__


=head1 NAME

OpeniT::File

=head1 SYNOPSIS

=head1 DESCRIPTION   

=cut

