| 1 |
< |
# |
| 2 |
< |
# ConfigArea.pm |
| 3 |
< |
# |
| 4 |
< |
# Written by Christopher Williams |
| 5 |
< |
# |
| 6 |
< |
# Description |
| 7 |
< |
# ----------- |
| 8 |
< |
# creates and manages a configuration area |
| 9 |
< |
# |
| 10 |
< |
# Notes |
| 11 |
< |
# ------- |
| 12 |
< |
# Persistency - remember to call the save method to make changes persistent |
| 13 |
< |
# |
| 14 |
< |
# Interface |
| 15 |
< |
# --------- |
| 16 |
< |
# new() : A new ConfigArea object |
| 17 |
< |
# name() : get/set project name |
| 18 |
< |
# setup(dir[,areaname]) : setup a fresh area in dir |
| 19 |
< |
# satellite(dir[,areaname]) : setup a satellite area in dir |
| 20 |
< |
# version() : get/set project version |
| 21 |
< |
# location([dir]) : set/return the location of the work area |
| 22 |
< |
# bootstrapfromlocation([location]) : bootstrap the object based on location. |
| 23 |
< |
# no location specified - cwd used |
| 24 |
< |
# return 0 if succesful 1 otherwise |
| 25 |
< |
# requirementsdoc() : get set the requirements doc |
| 26 |
< |
# searchlocation([startdir]) : returns the location directory. search starts |
| 27 |
< |
# from cwd if not specified |
| 28 |
< |
# scramversion() : return the scram version associated with |
| 29 |
< |
# area |
| 30 |
< |
# configurationdir() : return the location of the project |
| 31 |
< |
# configuration directory |
| 32 |
< |
# copy(location) : copy a configuration |
| 33 |
< |
# copysetup(location) : copy the architecture specific tool setup |
| 34 |
< |
# returns 0 if successful, 1 otherwise |
| 35 |
< |
# copyenv($ref) : copy the areas environment into the hashref |
| 36 |
< |
# toolbox() : return the areas toolbox object |
| 37 |
< |
# save() : save changes permanently |
| 38 |
< |
# linkto(location) : link the current area to that at location |
| 39 |
< |
# unlinkarea() : destroy link (autosave) |
| 40 |
< |
# linkarea([ConfigArea]) : link the current area to the apec Area Object |
| 41 |
< |
# archname() : get/set a string to indicate architecture |
| 42 |
< |
# archdir() : return the location of the administration arch dep |
| 43 |
< |
# directory |
| 44 |
< |
# objectstore() : return the objectStore object of the area |
| 45 |
< |
# - temporary |
| 46 |
< |
# align() : adjust hard paths to suit local loaction |
| 1 |
> |
=head1 NAME |
| 2 |
> |
|
| 3 |
> |
Configuration::ConfigArea - Creates and manages a configuration area (i.e. a project area). |
| 4 |
> |
|
| 5 |
> |
=head1 SYNOPSIS |
| 6 |
> |
|
| 7 |
> |
my $obj = Configuration::ConfigArea->new(); |
| 8 |
> |
|
| 9 |
> |
=head1 DESCRIPTION |
| 10 |
> |
|
| 11 |
> |
Create and manage SCRAM project configuration areas. |
| 12 |
> |
|
| 13 |
> |
=head1 METHODS |
| 14 |
> |
|
| 15 |
> |
=over |
| 16 |
> |
|
| 17 |
> |
=cut |
| 18 |
> |
|
| 19 |
> |
=item C<new()> |
| 20 |
> |
|
| 21 |
> |
Create a new Configuration::ConfigArea object. |
| 22 |
> |
|
| 23 |
> |
=item C<name()> |
| 24 |
> |
|
| 25 |
> |
Get/set project name. |
| 26 |
> |
|
| 27 |
> |
=item C<setup($dir[,$areaname])> |
| 28 |
> |
|
| 29 |
> |
Set up a fresh area in $dir. |
| 30 |
> |
|
| 31 |
> |
=item C<satellite($dir[,$areaname])> |
| 32 |
> |
|
| 33 |
> |
Set up a satellite area in $dir. |
| 34 |
> |
|
| 35 |
> |
=item C<version()> |
| 36 |
> |
|
| 37 |
> |
Get/set project version. |
| 38 |
> |
|
| 39 |
> |
=item C<location([$dir])> |
| 40 |
> |
|
| 41 |
> |
Set/return the location of the work area. |
| 42 |
> |
|
| 43 |
> |
=item C<bootstrapfromlocation([$location])> |
| 44 |
> |
|
| 45 |
> |
Bootstrap the object based on location. |
| 46 |
> |
No location specified - current directory used |
| 47 |
> |
Return 0 if succesful, 1 otherwise. |
| 48 |
> |
|
| 49 |
> |
=item C<requirementsdoc()> |
| 50 |
> |
|
| 51 |
> |
Get or set the requirements document. |
| 52 |
> |
|
| 53 |
> |
=item C<searchlocation([$startdir])> |
| 54 |
> |
|
| 55 |
> |
Returns the location directory. search starts |
| 56 |
> |
from current directory if not specified. |
| 57 |
> |
|
| 58 |
> |
=item C<scramversion()> |
| 59 |
> |
|
| 60 |
> |
Return the scram version associated with the area. |
| 61 |
> |
|
| 62 |
> |
=item C<configurationdir()> |
| 63 |
> |
|
| 64 |
> |
Return the location of the project configuration directory. |
| 65 |
> |
|
| 66 |
> |
=item C<copy($location)> |
| 67 |
> |
|
| 68 |
> |
Copy a configuration from $location. |
| 69 |
> |
|
| 70 |
> |
=item C<copysetup($location)> |
| 71 |
> |
|
| 72 |
> |
Copy the architecture-specific tool setup. |
| 73 |
> |
Returns 0 if successful, 1 otherwise. |
| 74 |
> |
|
| 75 |
> |
=item C<copyenv($ref)> |
| 76 |
> |
|
| 77 |
> |
Copy the area environment into the hashref $ref. |
| 78 |
> |
|
| 79 |
> |
=item C<toolbox()> |
| 80 |
> |
|
| 81 |
> |
Return the area toolbox object. |
| 82 |
> |
|
| 83 |
> |
=item C<save()> |
| 84 |
> |
|
| 85 |
> |
Save changes permanently. |
| 86 |
> |
|
| 87 |
> |
=item C<linkto($location)> |
| 88 |
> |
|
| 89 |
> |
Link the current area to that at location. |
| 90 |
> |
|
| 91 |
> |
=item C<unlinkarea()> |
| 92 |
> |
|
| 93 |
> |
Destroy link ($autosave). |
| 94 |
> |
|
| 95 |
> |
=item C<linkarea([Configuration::ConfigArea])> |
| 96 |
> |
|
| 97 |
> |
Link the current area to the specified area object. |
| 98 |
> |
|
| 99 |
> |
=item C<archname()> |
| 100 |
> |
|
| 101 |
> |
Get/set a string to indicate architecture. |
| 102 |
> |
|
| 103 |
> |
=item C<archdir()> |
| 104 |
> |
|
| 105 |
> |
Return the location of the administration |
| 106 |
> |
architecture-dependent directory. |
| 107 |
> |
|
| 108 |
> |
=item C<objectstore()> |
| 109 |
> |
|
| 110 |
> |
Return the B<objectStore> object of the area temporary. |
| 111 |
> |
|
| 112 |
> |
=item C<align()> |
| 113 |
> |
|
| 114 |
> |
Adjust hard paths to suit local location. |
| 115 |
> |
|
| 116 |
> |
|
| 117 |
> |
=back |
| 118 |
> |
|
| 119 |
> |
=head1 AUTHOR |
| 120 |
> |
|
| 121 |
> |
Originally written by Christopher Williams. |
| 122 |
> |
|
| 123 |
> |
=head1 MAINTAINER |
| 124 |
> |
|
| 125 |
> |
Shaun ASHBY |
| 126 |
> |
|
| 127 |
> |
=cut |
| 128 |
|
|
| 129 |
|
package Configuration::ConfigArea; |
| 130 |
|
require 5.004; |
| 228 |
|
return $self->{dbstore} |
| 229 |
|
} |
| 230 |
|
|
| 231 |
+ |
sub symlinks { |
| 232 |
+ |
my $self=shift; |
| 233 |
+ |
if (@_) {$self->{symlinks}=shift;} |
| 234 |
+ |
return $self->{symlinks}; |
| 235 |
+ |
} |
| 236 |
+ |
|
| 237 |
|
sub name { |
| 238 |
|
my $self=shift; |
| 239 |
|
@_?$self->{name}=shift |
| 250 |
|
my $self=shift; |
| 251 |
|
my $location=shift; |
| 252 |
|
my $areaname; |
| 253 |
+ |
my $symlinks=0; |
| 254 |
|
|
| 255 |
|
# -- check we have a project name and version |
| 256 |
|
my $name=$self->name(); |
| 267 |
|
if ( @_ ) { |
| 268 |
|
$areaname=shift; |
| 269 |
|
} |
| 270 |
+ |
if ( @_ ) { |
| 271 |
+ |
$symlinks=shift || 0; |
| 272 |
+ |
} |
| 273 |
|
if ( (! defined $areaname) || ( $areaname eq "" ) ) { |
| 274 |
< |
# -- make up a name from the project name and version |
| 184 |
< |
$vers=~s/^$name\_//; |
| 185 |
< |
$areaname=$name."_".$vers; |
| 274 |
> |
$areaname=$vers; |
| 275 |
|
} |
| 276 |
|
my $arealoc=$location."/".$areaname; |
| 277 |
|
my $workloc=$arealoc."/".$self->{admindir}; |
| 278 |
|
$self->verbose("Building at $arealoc"); |
| 279 |
|
$self->location($arealoc); |
| 280 |
+ |
$self->symlinks($symlinks); |
| 281 |
|
|
| 282 |
|
# -- create top level structure and work area |
| 283 |
|
AddDir::adddir($workloc); |
| 401 |
|
return $self->{sitename}; |
| 402 |
|
} |
| 403 |
|
|
| 404 |
+ |
sub admindir() |
| 405 |
+ |
{ |
| 406 |
+ |
my $self=shift; |
| 407 |
+ |
|
| 408 |
+ |
@_ ? $self->{admindir} = shift |
| 409 |
+ |
: $self->{admindir}; |
| 410 |
+ |
} |
| 411 |
|
|
| 412 |
|
sub bootstrapfromlocation { |
| 413 |
|
my $self=shift; |
| 607 |
|
sub copywithskip { |
| 608 |
|
my $self=shift; |
| 609 |
|
my $dest=shift; |
| 610 |
< |
my ($filetoskip)=@_; |
| 610 |
> |
my $filetoskip=shift || []; |
| 611 |
|
my $rv=1; |
| 612 |
|
# copy across the admin dir |
| 613 |
|
my $temp=$self->location()."/".$self->{admindir}."/".$self->arch(); |
| 614 |
|
my $temp2=$dest."/".$self->{admindir}."/".$self->arch(); |
| 615 |
|
if ( $temp ne $temp2 ) { |
| 616 |
|
if ( -d $temp ) { |
| 617 |
< |
AddDir::copydirwithskip($temp,$temp2,$filetoskip); |
| 617 |
> |
my $fs=[]; |
| 618 |
> |
foreach my $f (@$filetoskip) {push @$fs,"${temp}/${f}";} |
| 619 |
> |
AddDir::copydirwithskip($temp,$temp2,$fs); |
| 620 |
|
$rv=0; |
| 621 |
|
} |
| 622 |
|
} |
| 674 |
|
$self->_SaveEnvFile(); |
| 675 |
|
} |
| 676 |
|
|
| 677 |
+ |
sub reqdoc() |
| 678 |
+ |
{ |
| 679 |
+ |
my $self=shift; |
| 680 |
+ |
my ($path)=@_; |
| 681 |
+ |
return $path."/".$self->{reqdoc}; |
| 682 |
+ |
} |
| 683 |
+ |
|
| 684 |
+ |
sub creationtime() |
| 685 |
+ |
{ |
| 686 |
+ |
my $self=shift; |
| 687 |
+ |
my ($location)= @_; |
| 688 |
+ |
$location||=$self->location(); |
| 689 |
+ |
my $requirementsdoc = $self->reqdoc($location); |
| 690 |
+ |
my ($mode, $time) = (stat($requirementsdoc))[2, 9]; |
| 691 |
+ |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time); |
| 692 |
+ |
|
| 693 |
+ |
($sec < 10) ? ($sec = "0".$sec) : $sec; |
| 694 |
+ |
($min < 10) ? ($min = "0".$min) : $min; |
| 695 |
+ |
|
| 696 |
+ |
$year += 1900; |
| 697 |
+ |
my $months = |
| 698 |
+ |
{ |
| 699 |
+ |
0 => "Jan", 1 => "Feb", |
| 700 |
+ |
2 => "Mar", 3 => "Apr", |
| 701 |
+ |
4 => "May", 5 => "Jun", |
| 702 |
+ |
6 => "Jul", 7 => "Aug", |
| 703 |
+ |
8 => "Sept", 9 => "Oct", |
| 704 |
+ |
10 => "Nov", 11 => "Dec" }; |
| 705 |
+ |
|
| 706 |
+ |
my $days = { 1 => "Mon", 2 => "Tue", 3 => "Wed", 4 => "Thu", 5 => "Fri", 6 => "Sat", 7 => "Sun"}; |
| 707 |
+ |
|
| 708 |
+ |
# Return the timestamp (as string) of the requirementsdoc: |
| 709 |
+ |
return $days->{$wday}."-".$mday."-".$months->{$mon}."-".$year." ".$hour.":".$min.":".$sec; |
| 710 |
+ |
} |
| 711 |
+ |
|
| 712 |
|
# ---- support routines |
| 713 |
|
|
| 714 |
|
sub _SaveEnvFile |
| 729 |
|
print $fh "SCRAM_SOURCEDIR=".$self->sourcedir()."\n"; |
| 730 |
|
print $fh "SCRAM_ProjReqsDoc=".$self->{reqdoc}."\n"; |
| 731 |
|
print $fh "SCRAM_TOOLBOXVERSION=".$self->{toolboxversion}."\n"; |
| 732 |
+ |
print $fh "SCRAM_SYMLINKS=",$self->{symlinks},"\n"; |
| 733 |
|
|
| 734 |
|
if ( defined $self->linkarea() ) |
| 735 |
|
{ |
| 742 |
|
|
| 743 |
|
undef $fh; |
| 744 |
|
|
| 745 |
+ |
# Repeat the exercise to save as XML: |
| 746 |
+ |
my $fh=FileHandle->new(); |
| 747 |
+ |
open ( $fh, ">".$self->location()."/".$self->{admindir}."/". |
| 748 |
+ |
"Environment.xml" ) or |
| 749 |
+ |
$self->error("Cannot Open Environment.xml file to Save (" |
| 750 |
+ |
.$self->location().")\n $!"); |
| 751 |
+ |
print $fh "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"; |
| 752 |
+ |
print $fh "<doc type=\"Configuration::ProjectEnvironment\" version=\"1.0\">\n"; |
| 753 |
+ |
print $fh " <environment SCRAM_PROJECTNAME=\"".$self->name()."\"/>\n"; |
| 754 |
+ |
print $fh " <environment SCRAM_PROJECTVERSION=\"".$self->version()."\"/>\n"; |
| 755 |
+ |
print $fh " <environment SCRAM_CONFIGDIR=\"".$self->configurationdir()."\"/>\n"; |
| 756 |
+ |
print $fh " <environment SCRAM_SOURCEDIR=\"".$self->sourcedir()."\"/>\n"; |
| 757 |
+ |
print $fh " <environment SCRAM_ProjReqsDoc=\"".$self->{reqdoc}."\"/>\n"; |
| 758 |
+ |
print $fh " <environment SCRAM_TOOLBOXVERSION=\"".$self->{toolboxversion}."\"/>\n"; |
| 759 |
+ |
print $fh "<environment SCRAM_SYMLINKS=\"",$self->{symlinks},"\"/>\n"; |
| 760 |
+ |
|
| 761 |
+ |
if ( defined $self->linkarea() ) |
| 762 |
+ |
{ |
| 763 |
+ |
my $area=$self->linkarea()->location(); |
| 764 |
+ |
if ( $area ne "" ) |
| 765 |
+ |
{ |
| 766 |
+ |
print $fh " <environment RELEASETOP=\"".$area."\"/>\n"; |
| 767 |
+ |
} |
| 768 |
+ |
} |
| 769 |
+ |
|
| 770 |
+ |
print $fh "</doc>\n"; |
| 771 |
+ |
undef $fh; |
| 772 |
+ |
|
| 773 |
|
# Set the default permissions (-rw-r--r--): |
| 774 |
|
chmod $filemode, $self->location()."/".$self->{admindir}."/Environment"; |
| 775 |
+ |
chmod $filemode, $self->location()."/".$self->{admindir}."/Environment.xml"; |
| 776 |
|
} |
| 777 |
|
|
| 778 |
|
sub _LoadEnvFile |
| 818 |
|
} |
| 819 |
|
if ( defined $self->{ENV}{"SCRAM_TOOLBOXVERSION"} ) |
| 820 |
|
{ |
| 821 |
< |
$self->toolboxversion($self->{ENV}{"SCRAM_TOOLBOXVERSION"}); |
| 821 |
> |
if ($self->{ENV}{"SCRAM_TOOLBOXVERSION"} eq '') |
| 822 |
> |
{ |
| 823 |
> |
$self->toolboxversion("STANDALONE"); |
| 824 |
> |
} |
| 825 |
> |
else |
| 826 |
> |
{ |
| 827 |
> |
$self->toolboxversion($self->{ENV}{"SCRAM_TOOLBOXVERSION"}); |
| 828 |
> |
} |
| 829 |
|
} |
| 830 |
|
|
| 831 |
|
if ( ( defined $self->{ENV}{"RELEASETOP"} ) && |
