src/Scram/ScramProjectDB.pm

#
# ScramProjectDB.pm - Keep a track of available projects
#
# Originally Written by Christopher Williams
#
# Description
# -----------
# Stores project area information
#
# Interface
# ---------
# new(dbfile)              : A new dbobject object
# file()                   : return the db file
# getarea(name,version) : return the object matching the name version
# addarea(ConfigArea)   : add a project - return 0 for success 1 for abort
# list()                : list local areas (retunns $name,$version pairs)
# listall()             : list local and linked areas
# listlinks()           : Show a list of links
# removearea(name,version) : remove the named project
# link(dblocation) : link with specified db 
# unlink(dblocation) : remove link with a specified db

package Scram::ScramProjectDB;
use Utilities::Verbose;
require 5.004;
@ISA=qw(Utilities::Verbose);

sub new {
        my $class=shift;
        my $self={};
        bless $self, $class;
        $self->{dbfile}=shift;
        $self->_readdbfile($self->{dbfile});
        $self->{projectobjects}={};
        return $self;
}

sub file {
        my $self=shift;
        return $self->{dbfile};
}

sub getarea
   {
   require Configuration::ConfigArea;
   my $self=shift;
   my $name=shift;
   my $version=shift;
   my $area=undef;
   my $index=$self->_findlocal($name,$version);
   
   if ( $index != -1 )
      { 
      my $location=$self->{projects}[$index][3];
      if ( defined $self->{projectobjects}{$location} )
         {
         $area=$self->{projectobjects}{$location};
         }
      else
         {
         $area=Configuration::ConfigArea->new();
         $self->verbose("Attempt to ressurect $name $version from $location");
         if ( $area->bootstrapfromlocation($location) == 1 )
            {
            undef $area;
                 $self->verbose("attempt unsuccessful");
            }
         else
            {
            $self->verbose("area found");
            $self->{projectobjects}{$location}=$area;
            }
         }
      }
   else
      {
      # -- search in linked databases
      foreach $db ( @{$self->{linkeddbs}} )
         {
         $self->verbose("Searching in $db->file() for $name $version");
         $area=$db->getarea($name,$version);
         last if (defined $area);
         }
      }
   if ( ! defined $area )
      {
      $self->verbose("Area $name $version not found");
      }

   return $area;
   }


sub addarea
   {
   my $self=shift;
   my $flag=shift;
   my $name=shift;
   my $version=shift;
   my $area=shift;

   my $rv=1;
   my $type="file";
   my $url=$area->location()."/.SCRAM/InstallFile";

   # -- check for duplicates
   for ( my $index=0; $index<=$#{$self->{projects}}; $index++ )
      {
      if  ( $self->{projects}[$index][0] eq $name )
         {
         if ( $self->{projects}[$index][1] eq $version )
            {
            if ($flag == 1)
               {
               $rv=0;
               $self->{projects}[$index]=[ ($name,$version,$type,$url) ];
               }
            else
               {
               print "$name $version already exists. Overwrite? (y/n) : ";
               if ( ! (<STDIN>=~/y/i ) )
                  {
                  print "Aborting install ...\n";
                  return 1;
                  }
               else
                  {
                  $rv=0;
                  $self->{projects}[$index]=[ ($name,$version,$type,$url) ];
                  }
               }
            }
         else
            {
            print "Related Project : $name ".$self->{projects}[$index][1]."\n";
            }
         }
      }
   
   if ( $rv )
      {
      # -- add to our list and save
      push @{$self->{projects}}, [ ($name,$version,$type,$url) ];
      }
   $self->_save();
   return 0;
   }

sub listlinks {
        my $self=shift;

        my  @dbfile=();
        foreach $db ( @{$self->{linkeddbs}} ) {
          push @dbfile, $db->file();
        }
        return @dbfile;
}

sub list {
        my $self=shift;
        return @{$self->{projects}};
}

sub listall {
        my $self=shift;
        my @list=$self->list();
        
        foreach $db ( @{$self->{linkeddbs}} ) {
          $self->verbose("Adding list from $db");
          push @list, $db->listall();
        }

        return @list;
}

sub removearea
   {
   ###############################################################
   # removearea(name,version)                                    #
   ###############################################################
   # modified : Mon May 28 11:24:29 2001 / SFA                   #
   # params   :                                                  #
   #          :                                                  #
   #          :                                                  #
   #          :                                                  #
   # function : Remove project area from scramdb file.           #
   #          :                                                  #
   #          :                                                  #
   ###############################################################
   my $self=shift;
   my $flag=shift;
   my $name=shift;
   my $version=shift;
   my $vfound=0;
   my $nfound=0;
   
   print "\n","Going to remove $name $version from the current scram database.....","\n"; 
   print "\n";

   for ( my $index=0; $index<=$#{$self->{projects}}; $index++ )
      {
      # Look for a project with name $name:
      if  ( $self->{projects}[$index][0] eq $name )
         {
         $nfound=1; 
         # Check the version:
         if ( $self->{projects}[$index][1] eq $version )
            {
            # We have a match for project name and version:
            $vfound=1;
            if ($flag == 1)
               {
               # Remove the project:
               print "\n";
               print "Removing project:\t$name\t$version","\n\n";
               splice(@{$self->{projects}},$index,1);
               }
            else
               {
               print "Project $name Version $version exists. Remove it? (y/n): ";
               if ( ! (<STDIN>=~/y/i ) )
                  {
                  print "\n","Aborting project removal...bye.\n\n";
                  return 1;
                  }
               else
                  {
                  # Remove the project:
                  print "\n";
                  print "Removing project:\t$name\t$version","\n\n";
                  splice(@{$self->{projects}},$index,1);
                  }
               }
            }
         } 
      }
   
   if ( ! $nfound || ! $vfound )
      {
      # There was a problem finding either the
      # named project or the desired version:
      print "ERROR: Unable to find project $name with version $version in the database.","\n\n";
      return 1;
      }
   
   print "\n";   
   # Save our new array:
   $self->_save();
   return 0;
   }

sub link {
        my $self=shift;
        my $dbfile=shift;

        my $newdb=Scram::ScramProjectDB->new($dbfile);
        push @{$self->{linkeddbs}},$newdb; 
        $self->_save();
}

sub unlink {
        my $self=shift;
        my $file=shift;
        my $db;
        
        for (my $i=0; $i<=$#{$self->{linkeddbs}}; $i++ ) {
           $db=${$self->{linkeddbs}}[$i];
           if  ( $db->file() eq $file ) {
             $self->verbose("Removing link $file");
             splice (@{$self->{linkeddbs}},$i,1);
             $self->_save();
           }
        }
}

# -- Support Routines

#
# Search through the project list until we get a match
sub _findlocal {
        my $self=shift;
        my $name=shift;
        my $version=shift;

        my $found=-1;
        for (my $i=0; $i<=$#{$self->{projects}}; $i++ ) {
          if  ( ( $self->{projects}[$i][0] eq $name) && 
                ( $self->{projects}[$i][1] eq $version) ) {
            $found=$i;
            last;
          }
        }
        return $found;
}

sub _save {
        my $self=shift;

        use FileHandle;
        my $fh=FileHandle->new();
        my $filename=$self->{dbfile};
        open ( $fh, ">$filename" );
        # print current links 
        foreach $db ( @{$self->{linkeddbs}} ) {
           print $fh "\!DB ".$db->file()."\n";
        }
        # save project info
        my $temp;
        foreach $elem ( @{$self->{projects}} ) {
          $temp=join ":", @{$elem};
          print $fh $temp."\n";
        }
        undef $fh;
}

sub _readdbfile {
        my $self=shift;
        my $file=shift;
        
        use FileHandle;
        my $fh=FileHandle->new();
        $self->verbose("Initialising db from $file");
        open ( $fh, "<$file" );

        my @vars;
        my $newdb;
        while ( $map=<$fh> ) {
          chomp $map;
          if ( $map=~/^\!DB (.*)/ ) { # Check for other DB files
                my $db=$1;
                if ( -f $db ) {
                  $self->verbose("Getting Linked DB $db");
                  $newdb=Scram::ScramProjectDB->new($db);
                  push @{$self->{linkeddbs}},$newdb; 
                }
                next;
          }
          @vars = split ":", $map;
          $self->verbose("registering project $map");
          push @{$self->{projects}}, [ @vars ];
        }
        undef $fh;
}
Revision:	1.7.4.1
Committed:	Fri Feb 27 15:34:56 2004 UTC (21 years, 2 months ago) by sashby
Content type:	text/plain
Branch:	SCRAM_V1_BRANCH
CVS Tags:	SCRAM_V1, SCRAMV1_IMPORT
Changes since 1.7:	+67 -37 lines
Log Message:	First import of new SCRAM packages into CMS cvs repos.
#	User	Rev	Content
1	williamc	1.2	#
2			# ScramProjectDB.pm - Keep a track of available projects
3			#
4			# Originally Written by Christopher Williams
5			#
6			# Description
7			# -----------
8			# Stores project area information
9			#
10			# Interface
11			# ---------
12			# new(dbfile) : A new dbobject object
13			# file() : return the db file
14			# getarea(name,version) : return the object matching the name version
15			# addarea(ConfigArea) : add a project - return 0 for success 1 for abort
16	williamc	1.3	# list() : list local areas (retunns $name,$version pairs)
17			# listall() : list local and linked areas
18			# listlinks() : Show a list of links
19	williamc	1.2	# removearea(name,version) : remove the named project
20			# link(dblocation) : link with specified db
21			# unlink(dblocation) : remove link with a specified db
22
23			package Scram::ScramProjectDB;
24			use Utilities::Verbose;
25			require 5.004;
26			@ISA=qw(Utilities::Verbose);
27
28			sub new {
29			my $class=shift;
30			my $self={};
31			bless $self, $class;
32			$self->{dbfile}=shift;
33			$self->_readdbfile($self->{dbfile});
34			$self->{projectobjects}={};
35			return $self;
36			}
37
38			sub file {
39			my $self=shift;
40			return $self->{dbfile};
41			}
42
43	sashby	1.7	sub getarea
44			{
45			require Configuration::ConfigArea;
46			my $self=shift;
47			my $name=shift;
48			my $version=shift;
49			my $area=undef;
50			my $index=$self->_findlocal($name,$version);
51
52			if ( $index != -1 )
53			{
54			my $location=$self->{projects}[$index][3];
55			if ( defined $self->{projectobjects}{$location} )
56			{
57			$area=$self->{projectobjects}{$location};
58	williamc	1.2	}
59	sashby	1.7	else
60			{
61	williamc	1.2	$area=Configuration::ConfigArea->new();
62			$self->verbose("Attempt to ressurect $name $version from $location");
63	sashby	1.7	if ( $area->bootstrapfromlocation($location) == 1 )
64			{
65			undef $area;
66			$self->verbose("attempt unsuccessful");
67			}
68			else
69			{
70			$self->verbose("area found");
71			$self->{projectobjects}{$location}=$area;
72			}
73	williamc	1.2	}
74	sashby	1.7	}
75			else
76			{
77			# -- search in linked databases
78			foreach $db ( @{$self->{linkeddbs}} )
79			{
80			$self->verbose("Searching in $db->file() for $name $version");
81			$area=$db->getarea($name,$version);
82			last if (defined $area);
83	williamc	1.2	}
84	sashby	1.7	}
85			if ( ! defined $area )
86			{
87			$self->verbose("Area $name $version not found");
88			}
89
90			return $area;
91			}
92
93	williamc	1.2
94	sashby	1.7.4.1	sub addarea
95			{
96			my $self=shift;
97			my $flag=shift;
98			my $name=shift;
99			my $version=shift;
100			my $area=shift;
101
102			my $rv=1;
103			my $type="file";
104			my $url=$area->location()."/.SCRAM/InstallFile";
105
106			# -- check for duplicates
107			for ( my $index=0; $index<=$#{$self->{projects}}; $index++ )
108			{
109			if ( $self->{projects}[$index][0] eq $name )
110			{
111			if ( $self->{projects}[$index][1] eq $version )
112			{
113			if ($flag == 1)
114			{
115	williamc	1.2	$rv=0;
116			$self->{projects}[$index]=[ ($name,$version,$type,$url) ];
117	sashby	1.7.4.1	}
118			else
119			{
120			print "$name $version already exists. Overwrite? (y/n) : ";
121			if ( ! (<STDIN>=~/y/i ) )
122			{
123			print "Aborting install ...\n";
124			return 1;
125			}
126			else
127			{
128			$rv=0;
129			$self->{projects}[$index]=[ ($name,$version,$type,$url) ];
130			}
131			}
132	williamc	1.2	}
133	sashby	1.7.4.1	else
134			{
135	williamc	1.2	print "Related Project : $name ".$self->{projects}[$index][1]."\n";
136	sashby	1.7.4.1	}
137	williamc	1.2	}
138	sashby	1.7.4.1	}
139
140			if ( $rv )
141			{
142			# -- add to our list and save
143			push @{$self->{projects}}, [ ($name,$version,$type,$url) ];
144			}
145			$self->_save();
146			return 0;
147			}
148	williamc	1.2
149	williamc	1.3	sub listlinks {
150			my $self=shift;
151
152			my @dbfile=();
153			foreach $db ( @{$self->{linkeddbs}} ) {
154			push @dbfile, $db->file();
155			}
156			return @dbfile;
157			}
158
159	williamc	1.2	sub list {
160			my $self=shift;
161			return @{$self->{projects}};
162			}
163
164	williamc	1.3	sub listall {
165			my $self=shift;
166			my @list=$self->list();
167	sashby	1.7
168	williamc	1.3	foreach $db ( @{$self->{linkeddbs}} ) {
169			$self->verbose("Adding list from $db");
170			push @list, $db->listall();
171			}
172	sashby	1.7
173	williamc	1.3	return @list;
174			}
175
176	sashby	1.5	sub removearea
177			{
178			###############################################################
179			# removearea(name,version) #
180			###############################################################
181			# modified : Mon May 28 11:24:29 2001 / SFA #
182			# params : #
183			# : #
184			# : #
185			# : #
186			# function : Remove project area from scramdb file. #
187			# : #
188			# : #
189			###############################################################
190			my $self=shift;
191	sashby	1.7.4.1	my $flag=shift;
192	sashby	1.5	my $name=shift;
193			my $version=shift;
194	sashby	1.6	my $vfound=0;
195			my $nfound=0;
196
197			print "\n","Going to remove $name $version from the current scram database.....","\n";
198			print "\n";
199	williamc	1.2
200	sashby	1.6	for ( my $index=0; $index<=$#{$self->{projects}}; $index++ )
201			{
202			# Look for a project with name $name:
203			if ( $self->{projects}[$index][0] eq $name )
204			{
205			$nfound=1;
206			# Check the version:
207			if ( $self->{projects}[$index][1] eq $version )
208			{
209			# We have a match for project name and version:
210			$vfound=1;
211	sashby	1.7.4.1	if ($flag == 1)
212	sashby	1.6	{
213			# Remove the project:
214			print "\n";
215			print "Removing project:\t$name\t$version","\n\n";
216			splice(@{$self->{projects}},$index,1);
217	sashby	1.7.4.1	}
218			else
219			{
220			print "Project $name Version $version exists. Remove it? (y/n): ";
221			if ( ! (<STDIN>=~/y/i ) )
222			{
223			print "\n","Aborting project removal...bye.\n\n";
224			return 1;
225			}
226			else
227			{
228			# Remove the project:
229			print "\n";
230			print "Removing project:\t$name\t$version","\n\n";
231			splice(@{$self->{projects}},$index,1);
232			}
233	sashby	1.6	}
234			}
235			}
236			}
237
238			if ( ! $nfound \|\| ! $vfound )
239			{
240			# There was a problem finding either the
241			# named project or the desired version:
242			print "ERROR: Unable to find project $name with version $version in the database.","\n\n";
243			return 1;
244			}
245
246			print "\n";
247			# Save our new array:
248			$self->_save();
249			return 0;
250	sashby	1.5	}
251	williamc	1.2
252			sub link {
253			my $self=shift;
254			my $dbfile=shift;
255
256			my $newdb=Scram::ScramProjectDB->new($dbfile);
257			push @{$self->{linkeddbs}},$newdb;
258			$self->_save();
259			}
260
261	williamc	1.3	sub unlink {
262			my $self=shift;
263			my $file=shift;
264			my $db;
265	sashby	1.6
266	williamc	1.3	for (my $i=0; $i<=$#{$self->{linkeddbs}}; $i++ ) {
267			$db=${$self->{linkeddbs}}[$i];
268			if ( $db->file() eq $file ) {
269			$self->verbose("Removing link $file");
270			splice (@{$self->{linkeddbs}},$i,1);
271			$self->_save();
272			}
273			}
274			}
275
276	williamc	1.2	# -- Support Routines
277
278			#
279			# Search through the project list until we get a match
280			sub _findlocal {
281			my $self=shift;
282			my $name=shift;
283			my $version=shift;
284
285			my $found=-1;
286			for (my $i=0; $i<=$#{$self->{projects}}; $i++ ) {
287			if ( ( $self->{projects}[$i][0] eq $name) &&
288			( $self->{projects}[$i][1] eq $version) ) {
289			$found=$i;
290			last;
291			}
292			}
293			return $found;
294			}
295
296			sub _save {
297			my $self=shift;
298
299			use FileHandle;
300			my $fh=FileHandle->new();
301			my $filename=$self->{dbfile};
302			open ( $fh, ">$filename" );
303			# print current links
304			foreach $db ( @{$self->{linkeddbs}} ) {
305			print $fh "\!DB ".$db->file()."\n";
306			}
307			# save project info
308			my $temp;
309			foreach $elem ( @{$self->{projects}} ) {
310			$temp=join ":", @{$elem};
311			print $fh $temp."\n";
312			}
313			undef $fh;
314			}
315
316			sub _readdbfile {
317			my $self=shift;
318			my $file=shift;
319
320			use FileHandle;
321			my $fh=FileHandle->new();
322	williamc	1.3	$self->verbose("Initialising db from $file");
323	williamc	1.2	open ( $fh, "<$file" );
324
325			my @vars;
326	williamc	1.3	my $newdb;
327	williamc	1.2	while ( $map=<$fh> ) {
328			chomp $map;
329			if ( $map=~/^\!DB (.*)/ ) { # Check for other DB files
330			my $db=$1;
331			if ( -f $db ) {
332	williamc	1.3	$self->verbose("Getting Linked DB $db");
333	williamc	1.2	$newdb=Scram::ScramProjectDB->new($db);
334			push @{$self->{linkeddbs}},$newdb;
335			}
336			next;
337			}
338			@vars = split ":", $map;
339	williamc	1.3	$self->verbose("registering project $map");
340	williamc	1.2	push @{$self->{projects}}, [ @vars ];
341			}
342			undef $fh;
343			}