File Coverage

blib/lib/Dir/Project.pm

Criterion	Covered	Total	%
statement	30	161	18.6
branch	0	50	0.0
condition	0	29	0.0
subroutine	10	27	37.0
pod	7	10	70.0
total	47	277	16.9

# See copyright, etc in below POD section.
######################################################################

package Dir::Project;
require 5.005;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw( $Project $HostDir );

use FindBin qw($RealBin);
use Carp;
use Cwd qw(abs_path getcwd);
use File::Basename;
use IO::File;
use IO::Handle;
use IO::Dir;
use Sys::Hostname;

use strict;
use vars qw($VERSION $Debug $Project %Env_Vars);

######################################################################
#### Configuration Section

$VERSION = '3.026';

# List of all environment variables we might generate
%Env_Vars = (
	     DIRPROJECT		=> \&_get_project,
	     );

######################################################################
#### Begin

######################################################################
######################################################################
######################################################################
#### User callable

sub default_script_dir {
    return "$ENV{DIRPROJECT_PREFIX}/bin";
}

sub get_set_project {
    get_set_all();
}
sub get_set_all {
    # This ordering matters
    {	# Compute temporary DIRPROJECT... We may end up changing the chip number,
	# which will cause DIRPROJECT to change.
	local $ENV{DIRPROJECT};
	_get_set("DIRPROJECT");
    }
    # Project may have changed, make sure by recomputing
    _get_set("DIRPROJECT");
    # DIRPROJECT now correct
    foreach (sort (keys %Env_Vars)) {
	print "$_ = ",($ENV{$_}||''),"\n" if $Debug && $Debug > 1;
    }
}

######################################################################
######################################################################
######################################################################
#### File utilities

sub simplify_dirnames {
    my $file = shift;
    return undef if !defined $file;
    #$file =~ s!^/nfs/remote/home!/home!;
    return $file;
}

sub program_paths {
    my %params = (#program =>		# Name of program without path
		  #default_exe =>	# Name of default program if not found
		  @_);
    $params{default_exe} ||= Dir::Project::default_script_dir()."/$params{program}__notfound";

    my @paths;
    my $path = ($ENV{DIRPROJECT_PATH}||"");
    foreach my $ppath (split (':', $path)) {
	my $try = $ppath."/".$params{program};
	if ($try =~ m!^project/!) {  # Else we allow absolute paths also
	    next if !defined $Project;
	    $try =~ s!^project!$Project!;
	}
	push @paths, $try;
    }
    push @paths, $params{default_exe};

    return @paths;
}

sub program_bin {
    my %params = (paths=>[],		# From program_paths
		  @_);

    foreach my $ppath (@{$params{paths}}) {
	if (-r $ppath) {
	    return $ppath;
	}
    }
    return undef;
}

######################################################################
######################################################################
######################################################################
#### Makefile

sub makefile_path {
    return ($ENV{TEMP}||$ENV{TMP}||"/tmp")."/project_dir";
}

sub _makefile_lines {
    my $fh = shift;

    foreach (sort (keys %Env_Vars)) {
	my $val = $ENV{$_};
	$val = "%Error_".$_."_not_found" if (!defined $val);
	print $fh "$_ = $val\n";
    }
    print $fh "\n";
    foreach (sort (keys %Env_Vars)) {
	print $fh "export $_\n";
    }
}

sub makefile {
    # Produce a makefile that will be included by project_bin.mk

    my $umask = umask();
    umask 0;

    get_set_all();

    my $makefile_path = makefile_path();
    mkdir $makefile_path, 0777;
    _makefile_clean();
    my $filename = "${makefile_path}/mktmp_$$";
    my $fh = IO::File->new ($filename, ">", 0666) or die "%Error: $! $filename\n";

    print $fh "DIRPROJECT_MK_FILENAME = $filename\n";
    _makefile_lines ($fh);
    $fh->close();

    # Tell make to include this file
    print "$filename\n";

    umask $umask;
}

sub makefile_cat {
    get_set_all();
    my $fh = new IO::Handle;
    $fh->fdopen(fileno(STDOUT),"w");
    _makefile_lines ($fh);
}

sub undefine_all {
    foreach (keys %Env_Vars) {
	delete $ENV{$_};
    }
}

sub _makefile_clean {
    # See if we can clean up our clutter
    my $clean_age = 600;	# Seconds of time to leave them around

    my $now = time();

    my $makefile_path = makefile_path();
    my $dir = new IO::Dir $makefile_path or return;
    my $basefile;
    while (defined($basefile = $dir->read)) {
	my $file = "$makefile_path/$basefile";
	next if ($file eq "." || $file eq "..");
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime)
	    = stat($file);
	if (($atime-$now) > $clean_age) {
	    #print "Cleaning tmp $file $atime $now ", $now - $atime, "\n" if $Debug;
	    unlink $file;
	}
    }
}

######################################################################
######################################################################
######################################################################
#### Setting each of the variables

sub _get {
    my $envvar = shift;
    # Get the value for what would be the given environment variable
    # without setting the environment at all
    my $func = $Env_Vars{$envvar} or die "%Error: $envvar is unknown in Env_Vars";
    my $value = &{$func};
    return $value;
}

sub _get_set {
    my $envvar = shift;
    # Get the value for the given environment variable
    # and set it
    my $value = _get($envvar);
    #print "_get_set($envvar) = $value\n" if $Debug;
    if (defined $value) {
	$ENV{$envvar} = $value;
    } else {
	delete $ENV{$envvar};
    }
}

sub _get_project {
    # Get the workarea/project pointer and set the DIRPROJECT environment variable
    $Project = _get_root ("DIRPROJECT", 'project', undef);
    return $Project;
}

######################################################################
######################################################################
######################################################################
#### Internals

sub _get_root {
    my $envvar = shift;		# if $ENV{envvar}...
    my $linkfile = shift;	# if readlink $linkfile...
    my $default = shift;
    #

    my $value = undef;
    my $comment = "undef";
  search:
    while (1) {
	if (defined $ENV{$envvar}) {
	    $value = _resolve ($ENV{$envvar});
	    $comment = "set from environment $ENV{$envvar}";
	    last search;
	}

	# Look for magic under cwd
	my $cwd = getcwd();
	print "_get_root: PWD=$cwd\n" if $Debug && $envvar eq "DIRPROJECT";
	my $dir = $cwd."/.";
	while ($dir =~ s/^(.*)\/.*$/$1/) {
	    last if $dir =~ m!/homes?/?$!;   # Else automounter goes berserk
	    if (-r "$dir/Project_Root") {
		$value = $dir;
		$comment = "set from Project_Root under cwd";
		last search;
	    }
	    if (-r "$dir/$linkfile" && readlink "$dir/$linkfile") {
		$value = _resolve ("$dir/$linkfile");
		$comment = "set from $dir/$linkfile link under cwd";
		last search;
	    }
	}

	# Look for magic under binary directory
	$cwd = $RealBin;
	print "_get_root: BINDIR=$cwd\n" if $Debug && $envvar eq "DIRPROJECT";
	$dir = $cwd."/.";
	while ($dir =~ s/^(.*)\/.*$/$1/) {
	    last if $dir =~ m!/homes?/?$!;   # Else automounter goes berserk
	    if (-r "$dir/Project_Root") {
		$value = $dir;
		$comment = "set from Project_Root under bin dir";
		last search;
	    }
	    if (-r "$dir/$linkfile" && readlink "$dir/$linkfile") {
		$value = _resolve ("$dir/$linkfile");
		$comment = "set from $dir/$linkfile link under bin dir";
		last search;
	    }
	}

	if (defined $default) {
	    $value = $default;
	    $comment = "default";
	    last search;
	}

	last;
    }

    $value = simplify_dirnames($value);

    print "_get_root: $envvar=",$value||'undef',"; $comment\n" if $Debug;
    return ($value);
}

sub _resolve {
    # Rip apart any links in the path
    my $file = shift;

    $file = abs_path($file);
    return $file if ($file =~ /^\//);
    if (readlink $file) {
	$file = readlink $file;
	$file = _resolve($file);
    }
    return $file;
}

######################################################################
######################################################################
######################################################################
#### Package return
1;

__END__