xref: /dports/devel/cvsmonitor/cvsmonitor/modules/CVSMonitor/MetaData.pm

package CVSMonitor::MetaData;

# Provides an interface to the MetaData stored in the scratch area.

# When refering to modules in this package, a special format can be
# used. This involves seperating the name of the repository and module
# with a period.
#
# e.g.  RepositoryName.ModuleName
#
# If only the Module name is provided, we search through all the repositories
# and if only one module has the name, it will be returned.

require 5.005;
use strict;
use UNIVERSAL 'isa';
use Fcntl ();
use Storable ();
use File::Spec ();
use Sort::Versions ();
use Class::Autouse 'File::Flat';





#####################################################################
# Globals

use vars qw{$errstr};
BEGIN { $errstr = '' }




#####################################################################
# Inheritable constants and path stuff

sub _fileIndex       { 'index.dat' }
sub _directoryRoot   { 'CVSMonitor_MetaData_0_6' }
sub pathAdminLogDir  { File::Spec->catdir( $_[0]->root, 'adminlogs' ) }
sub pathAdminLogFile {
	my $self = shift;

	# If they have provided a good PID, use that. Otherwise use
	# the PID for the current process.
	my $pid = $_[0] =~ /^\d+$/ ? shift : $$;

	File::Spec->catfile( $self->pathAdminLogDir, "$pid.log" );
}





#####################################################################

# Constructors and basics
# You should provide a temporary directory for the statistics
# generator to use. It will need to create a lot of files.
sub new {
	my $class = shift;
	my $base = shift;
	my $root = $class->_checkWorkArea( $base ) or return undef;
	my $pragma = shift || 'readonly';

	# Make sure the CVS client on this platform is OK
	return undef unless $class->cvsok;

	# Create the object
	my $self = {
		base => $base,
		root => $root,
		indexFile => File::Spec->catfile( $root, $class->_fileIndex ),
		_REPOSITORIES => {},  # New modules structure
		_DIRTY => 1,
		_NEW => 1,
		};
	bless $self, $class;

	# If the index file exists, make sure we have write access to it
	my $file = $self->{indexFile};
	if ( -e $file ) {
		return $class->_error( "Directory is in the way of the index" ) if -d $file;
		if ( -f $file ) {
			# Can we write to the index file
			return $class->_error( "No read access to old index file" ) unless -r $file;
			return $class->_error( "No write access to old index file" ) unless -w $file;
		}
	}

	# Save ourselves
	$self->save( $pragma eq 'lock' ? 'keeplock' : undef ) or return undef;

	$self;
}

sub load {
	my $class = shift;
	my $root = $class->_checkWorkArea( shift ) or return undef;
	my $pragma = shift || 'readonly';
	return undef unless $pragma =~ /^(?:lock|readonly)$/;

	# Does the file exist?
	my $file = File::Spec->catfile( $root, $class->_fileIndex ) or return undef;
	return $class->_error( "Index does not exist" ) unless -e $file;
	return $class->_error( "Cannot read index file" ) unless -r $file;

	# In order to avoid nasty destroy warnings during the quit() phase, we need
	# To have all modules loaded that are likely to get ->DESTROY calls. That is,
	# any classes present in the Storable object.
	Class::Autouse->load( 'CVSMonitor::MetaData::Repository' );
	Class::Autouse->load( 'CVSMonitor::MetaData::Module' );

	# Get a handle to the file
	open( METADATA, "+<$file" ) or return $class->_error( "Error opening file: $!" );
	my $fh = \*METADATA;

	# Exclusive lock the file if we are going to use lock mode
	if ( $pragma eq 'lock' ) {
		flock( $fh, Fcntl::LOCK_EX() ) or return undef;
	}

	# Load the index file and return the CVSMonitor::MetaData object.
	my $self = Storable::fd_retrieve( $fh );
	return undef unless isa( $self, $class );

	if ( $pragma eq 'lock' ) {
		# Attach the filehandle to the object if locked.
		# This allows the object to maintain the exclusive lock.
		$self->{_FH} = $fh;
	} else {
		# Close the filehandle.
		close $fh;
	}

	# Reconnect the Repository parent links
	foreach ( values %{ $self->{_REPOSITORIES} } ) {
		$_->{_PARENT} = $self;
	}

	$self;
}

# Save the index.
# Serialize some basics and dump to disk
sub save {
	my $self = shift;
	my $lock = shift;
	unless ( exists $self->{_DIRTY} ) {
		$self->releaseLock unless $lock;
		return 1;
	}

	# Do we have a lock?
	unless ( exists $self->{_FH} or exists $self->{_NEW} ) {
		return $self->_error( "No lock on index file" );
	}

	# Prepare to do the save
	delete $self->{_DIRTY};
	if ( $self->{_NEW} ) {
		# There should be no attached filehandle on new files
		return undef if $self->{_FH};

		# Create a handle for the new file
		delete $self->{_NEW};
		open( METADATA, "+>$self->{indexFile}" )
			or return $self->_error( "Error creating new index file" );
		$self->{_FH} = \*METADATA;
	}

	# Get the freezable structure
	my $freezable = $self->_freezable or return undef;

	# Truncate and seek 0 on the filehandle to prepare to save
	seek $self->{_FH}, 0, 0;
	truncate $self->{_FH}, 0;

	# Freeze to the file.
	Storable::store_fd( $freezable, $self->{_FH} ) or return undef;

	# Do we want to keep a lock?
	$self->releaseLock unless $lock;

	# Make the index permissive
	chmod 0666, $self->{indexFile};

	1;
}

# Load if we can, or create a new one
sub loadOrNew {
	my $class = shift;
	my $root = shift;
	my $pragma = shift || 'readonly';

	# Check ourselves if the index exists
	my $base = $class->_checkWorkArea( $root ) or return undef;
	my $file = File::Spec->catfile( $base, $class->_fileIndex ) or return undef;
	if ( -e	$file ) {
		# Try to load it
		return $class->load( $root, $pragma );
	} else {
		# Create a new one
		return $class->new( $root, $pragma );
	}
}

# Reload from the file, and get lock back.
# The is an in place reload that works by overwriting the values
# in the old object with values in a newly loaded object, and taking
# the newly loaded object's lock.
# If a module exists in the OLD CVSMonitor::MetaData, but not in the
# NEW one, the Module will be reblessed as a
# CVSMonitor::MetaData::Module::Deleted, which will catch any calls,
# and return an error. This module, however, will NOT be available from
# the MetaData objects ->getModule type methods.
# Add a 'nolock' second argument to reload without locking.
sub reload {
	my $self = shift;
	my $lock = shift;
	my $class = ref $self;
	$lock = (defined $lock and $lock eq 'nolock') ? undef : 'lock';
	my $replacement = $class->load( $self->base, $lock ) or return undef;

	# Work out if any Repositories have been added
	my %state = ();
	foreach ( $replacement->getRepositoryNames ) {
		$state{$_} = $self->getRepository($_) ? 'replace' : 'add';
	}

	# Add or Replace the Repositories
	foreach my $name ( keys %state ) {
		if ( $state{$name} eq 'add' ) {
			# Transfer the Repository from the replacement
			$self->{_REPOSITORIES}->{$name} = $replacement->{_REPOSITORIES}->{$name};
			$self->{_REPOSITORIES}->{$name}->{_PARENT} = $self;
			delete $replacement->{_REPOSITORIES}->{$name};
		} else {
			# Reload the repository
			$self->{_REPOSITORIES}->{$name}->_reload( $replacement->{_REPOSITORIES}->{$name} ) or return undef;
		}
	}

	# Remove and replace all our scalar properties.
	# One of these will be the file lock
	foreach ( grep { $_ ne '_REPOSITORIES' } keys %$self ) {
		delete $self->{$_};
	}
	foreach ( grep { $_ ne '_REPOSITORIES' } keys %$replacement ) {
		$self->{$_} = $replacement->{$_};
	}

	# Since we have a copy of the replacement's index lock, remove their copy.
	# Also, delete their module hash to remove circular dependencies so the object
	# will immediately garbage collect.
	delete $replacement->{_FH};
	delete $replacement->{_REPOSITORIES};

	1;
}

# Remove ALL module, delete the root directory, and start fresh.
# ->_reloadDelete all modules will ensure nobody can use them.
sub reset {
	my $self = shift;

	# Do we have an index lock?
	unless ( $self->haveLock ) {
		return $self->_error( "We do not hold a lock on the index" );
	}

	# Get the module list
	my @Modules = $self->getModules;

	# Don't do this if there are any locked, non-broken modules
	my $locked = scalar grep { $_->locked and $_->lockHolderExists } @Modules;
	if ( $locked ) {
		return $self->_error( "Cannot reset cache while processes hold locked Modules" );
	}

	# Remove all the modules
	foreach my $Module ( @Modules ) {
		$Module->_reloadDelete;
	}

	# Remove the root directory
	my $root = $self->root;
	my $rv = system( 'rm -rf $root' );
	if ( $rv ) {
		return $self->_error( "Error while trying to delete repository cache" );
	}

	# Now create a new MetaData object
	my $class = ref $self;
	my $MetaData = $class->new() or return $self->_error( "Failed to recreate the cache" );

	# Copy the hash elements into outselves
	delete $self->{$_} foreach keys %$self;
	$self->{$_} = $MetaData->{$_} foreach keys %$MetaData;

	1;
}

# Remove files that should not be in the cache directory
sub clearDebris {
	my $self = shift;

	# Create an list of files that SHOULD be in the directory
	my %hash = ( $self->_fileIndex => 1 );

	# Add the main directories for each module
	foreach my $Module ( $self->getModules ) {
		$hash{ $Module->name } = 1;        # The directory
	}

	# Get the list of objects in the directory
	my $root = $self->root;
	opendir( DIR, $root );
	my @files = readdir DIR;
	closedir DIR;

	# Filter out ourselves, things in the index, and things we can't delete
	@files = grep { ! /^\.+$/ and ! $hash{$_} and -w $_ } @files;

	# Remove the remaining things
	# Remove the filesystem objects that arn't in the index
	foreach ( @files ) {
		File::Flat->remove( "$root/$_" ) or return undef;
	}

	1;
}

# Removes a MetaData Cache
sub removeMetaDataCache {
	my $class = shift;
	my $base = shift;

	# Get the root directory for the MetaData cache
	my $root = File::Spec->catfile( $base, $class->_fileIndex );

	# Call the system to remove it
	if ( system( "rm -rf $root" ) ) {
		return $class->_error( "System error while trying to remove MetaData cache ( 'rm -rf $root' )" );
	}

	1;
}





#####################################################################
# Working with MetaData Object

# Get the base directory ( e.g. /tmp )
sub base { $_[0]->{base} }

# Get the root directory ( e.g. /tmp/CVSMonitor_MetaData )
sub root { $_[0]->{root} }

# Make the MetaData object dirty
sub dirty { $_[0]->{_DIRTY} = 1 }

# Is there an active task in progress?
sub active {
	my $self = shift;

	# We are active if there are any transient, non-broken modules
	my $transients = scalar grep { ! $_->broken }
		grep { $_->transient }
		$self->getModules;

	$transients ? 1 : 0;
}




#####################################################################
# Locking

# Release an unneeded lock on the object
sub releaseLock {
	my $self = shift;
	if ( $self->{_FH} ) {
		# Unlock and close the filehandle
		flock( $self->{_FH}, Fcntl::LOCK_UN() );
		close $self->{_FH};
		delete $self->{_FH};
	}

	1;
}

# Do we have a lock?
sub haveLock { $_[0]->{_FH} ? 1 : 0 }





#####################################################################
# Working with Repositaries

# Get the Repository names.
# Return in sorted order.
sub getRepositoryNames { sort keys %{ $_[0]->{_REPOSITORIES} } }

# Get the Repositaries.
# Return in sorted order.
sub getRepositories {
	my $self = shift;
	map { $self->{_REPOSITORIES}->{$_} }
		sort keys %{ $self->{_REPOSITORIES} };
}

# Get a single Repository by name
sub getRepository { $_[0]->{_REPOSITORIES}->{$_[1]} }

# Add a new repository
sub addRepository {
	my $self = shift;
	my $name = shift;
	my $cvsroot = shift;
	my $options = shift || {};
	return $self->_error( 'You did not set a label' ) unless $options->{label};

	# Check the formats of the arguments
	unless ( defined $name and length $name ) {
		return $self->_error( 'No symbolic name was provided' );
	}
	unless ( $self->_checkFormat( 'symbol', $name ) ) {
		return $self->_error( 'Symbolic name is not in the correct format' );
	}
	unless ( defined $cvsroot and length $cvsroot ) {
		return $self->_error( 'No CVSROOT was provided' );
	}

	# Check for duplicates
	foreach ( $self->getRepositories ) {
		# Is the name the same
		if ( $name eq $_->name ) {
			return $self->_error( 'A Repository with that name already exists' );
		}

		# Is the label the same
		if ( $options->{label} eq $_->getLabel ) {
			return $self->_error( "A Repository with that label already exists" );
		}

		# Does that cvsroot already exist?
		if ( $cvsroot eq $_->cvsroot ) {
			return $self->_error( "A repository with that cvsroot already exists" );
		}
	}

	# Do we hold a lock?
	unless ( $self->haveLock ) {
		return $self->_error( "Cannot create module. We do not have a lock on the index file" );
	}

	# Create the Repository object
	my $Repository = CVSMonitor::MetaData::Repository->new( $name, $cvsroot, $options, $self );
	return undef unless defined $Repository;

	# Add it
	$self->{_REPOSITORIES}->{$name} = $Repository;
	$self->{_DIRTY} = 1;

	1;
}

# Delete a Repository ( and everything in it )
sub deleteRepository {
	my $self = shift;
	my $name = shift or return undef;

	# Does the Repository exist?
	my $Repository = $self->getRepository( $name ) or return undef;

	# Make sure that non of the modules inside the repository are locked
	foreach my $Module ( $Repository->getModules ) {
		if ( $Module->locked ) {
			return $self->_error( "One or more modules in the repository are locked" );
		}
	}

	# Do we hold a metadata lock?
	unless ( $self->haveLock ) {
		return $self->_error( "Cannot delete Repository. We do not have a lock on the index file" );
	}

	# Delete all the modules from inside the Repository
	foreach my $Module ( $Repository->getModules ) {
		$Module->delete or return undef;
	}

	# Remove the repositories entry
	delete $self->{_REPOSITORIES}->{$name}->{_PARENT};
	delete $self->{_REPOSITORIES}->{$name};
	$self->dirty;

	1;
}





#####################################################################
# Working with modules
# We provide this layer for convenience.
# It uses the dotted format for modules 'Repository.Module'

# Get all the ( full ) module names
sub getModuleNames {
	my $self = shift;

	# Iterate over the repositories
	my @names = ();
	foreach my $Repository ( $self->getRepositories ) {
		my $repository_name = $Repository->name;
		push @names, map {
			$repository_name . '.' . $_->name
			} $Repository->getModulesNames;
	}

	@names;
}

# Get all the modules
sub getModules {
	my $self = shift;
	map { $_->getModules } $self->getRepositories;
}

# Get a given module by name
# This goes perhaps a little over the top, but hey, it's easy to write,
# and I can just remove it later if it seems un-nescesary.
sub getModule {
	my $self = shift;
	my $name = shift or return undef;

	# Do we have a proper full name
	if ( CVSMonitor::MetaData->_checkFormat( 'module', $name ) ) {
		my ( $repository_name, $module_name ) = split /\./, $name;
		my $Repository = $self->getRepository( $repository_name );
		unless ( $Repository ) {
			return $self->_error( "The repository '$repository_name' does not exist" );
		}
		my $Module = $Repository->getModule( $module_name );
		return $Module || $self->_error( "Module '$module_name' does not exist in Repository '$repository_name'" );
	}

	# Do we have just the module name
	if ( CVSMonitor::MetaData->_checkFormat( 'symbol', $name ) ) {
		# Search through the repositories to see if the module exists
		# in only one repository
		my $Module = undef;
		foreach my $Repository ( $self->getRepositories ) {
			if ( $Repository->getModule( $name ) ) {
				if ( $Module ) {
					# More than one
					return $self->_error( "More than one module with the name '$name' exist" );
				} else {
					$Module = $Repository->getModule( $name );
				}
			}
		}

		return $Module || $self->_error( "The module '$name' does not exist in any repositories" );
	}

	$self->_error( "Invalid format for a module name" );
}




#####################################################################
# Working on all modules

# Update all updatable modules
sub update {
	my $self = shift;
	foreach my $Module ( $self->getModules ) {
		$Module->update or return undef;
	}

	1;
}

# As for Repositories and Modules, work out the update cost
sub updateCost {
	my $self = shift;
	my $total = 0;

	# Iterate over the modules and add them up
	foreach my $Module ( $self->getModules ) {
		my $cost = $Module->updateCost;
		return undef unless defined $cost;
		$total += $cost;
	}

	$total;
}





#####################################################################
# Platform checking

# Is this platform OK with regards to it's CVS client
sub cvsok {
	my $self = shift;

	# Is cvs installed
	unless ( $self->cvslocation ) {
		return $self->_error( "CVS Client not installed" );
	}

	# Get the version
	my $version = $self->cvsversion;
	unless ( $version ) {
		return $self->_error( "Could not determine the CVS version" );
	}

	# Make sure the version is high enough
	if ( Sort::Versions::versioncmp( $version, '1.11.1' ) >= 0 ) {
		return 1;
	} else {
		return $self->_error( "CVS Client is too old. Please install 1.11.1 or greater" );
	}
}

# Find the installed location of CVS.
# Returns the location of CVS on success.
# Returns undef if CVS not found.
sub cvslocation {
	my $self = shift;
	my @location = `which cvs`;
	scalar @location
		? chomp($location[0])
		: undef;
}

# Get the version of the CVS client.
# Returns the version if we can find it.
# Returns undef if cannot find version.
sub cvsversion {
	my $self = shift;
	my @output = `cvs -v`;
	chomp(@output);
	if ( $output[1] =~ /\b(1\.[\d\.p]+)/ ) {
		return $1;
	} else {
		return undef;
	}
}





#####################################################################
# Utilities and Error Handling

sub _checkWorkArea {
	my $class = shift;

	# Get and check the directory we are supposed
	# to either create in or attach to.
	my $base = shift;
	if ( $base ) {
		unless ( -d $base ) {
			return $class->_error( "Base directory does not exist" );
		}
	} else {
		# Set base to the default temp directory
		$base = File::Spec->tmpdir();
	}

	# Does the work area root directory exist? If not, create it
	my $root = File::Spec->catdir( $base, $class->_directoryRoot );
	unless ( -d $root ) {
		# Everyone needs to be able to write to this directory
		# because this module could be used by multiple users.
		unless ( mkdir $root, 0777 ) {
			return $class->_error( "Unable to create workarea directory '$root'" );
		}
	}

	$root;
}

# Get a freezable struct for this module
sub _freezable {
	my $self = shift;

	# Copy our main hash
	my $copy = bless { %{ $self } }, ref $self;

	# Remove unwanted things from the copy
	delete $copy->{_FH};
	delete $copy->{_DIRTY};
	delete $copy->{_NEW};

	# Remove the parent references in the repositories
	my $repositories = { %{ $copy->{_REPOSITORIES} } };
	foreach ( keys %$repositories ) {
		$repositories->{$_} = $repositories->{$_}->_freezable;
		$repositories->{$_}->{_PARENT} = $copy;
	}
	$copy->{_REPOSITORIES} = $repositories;

	$copy;
}

# Provides string format checking available to all packages
sub _checkFormat {
	my $class = shift;
	my $type = shift or return undef;
	my $string = shift;

	# Split on type
	if ( $type eq 'module' ) {
		# Check for a full referenced module name
		# This should be [symbol].[symbol]
		return $string =~ /^\w{1,32}\.\w{1,32}$/i ? 1 : '';

	} elsif ( $type eq 'symbol' ) {
		# Checks the format of a symbolic name
		# ( For a Repository or Module )
		# This should be 1 to 32 alphanumeric characters
		return $string =~ /^\w{1,32}$/i ? 1 : '';

	} elsif ( $type eq 'type' ) {
		# Only support pserver
		return $string eq 'pserver' ? 1 : '';

	} elsif ( $type eq 'username' ) {
		# The username restrictions are amazingly flexible.
		# It MUST be at least one character long, and must NOT
		# contain the characters : / or whitespace.
		# At least, that's what I read into the specs in root.c
		# in the CVS source.
		return $string =~ /^[^\s\:\/]+$/ ? 1 : '';

	} elsif ( $type eq 'password' ) {
		# Password. Ummm... anything that's defined
		return undef unless defined $string;

	} elsif ( $type eq 'path' ) {
		# Assume this is correct for now
		return 1;

	} else {
		# Unknown format
		return undef;
	}
}

# Generate a date in a particular format
sub date {
	return undef unless $_[1];
	my @t = gmtime $_[1];

	# Create an ISO formatted GMT date
	$t[4] += 1;
	$t[5] += 1900;
	$t[0] = '0' . $t[0] if length $t[0] < 2;
	$t[1] = '0' . $t[1] if length $t[1] < 2;
	$t[2] = '0' . $t[2] if length $t[2] < 2;
	$t[3] = '0' . $t[3] if length $t[3] < 2;
	$t[4] = '0' . $t[4] if length $t[4] < 2;
	"$t[5]/$t[4]/$t[3] $t[2]:$t[1]:$t[0]";
}

sub _error { $errstr = $_[1]; undef }
sub errstr { $errstr }

1;

__END__

# Copyright (C) 2002-2004 Adam Kennedy
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# Should you wish to utilise this software under a different licence,
# please contact the author.