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();

   # -- 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.8
Committed:	Fri Dec 10 13:41:42 2004 UTC (20 years, 5 months ago) by sashby
Content type:	text/plain
Branch:	MAIN
CVS Tags:	V1_0_1, V1_0_0
Changes since 1.7:	+67 -36 lines
Log Message:	Merged V1_0 branch to HEAD
#	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.8	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();
105	williamc	1.2
106	sashby	1.8	# -- 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.8	}
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.8	else
134			{
135	williamc	1.2	print "Related Project : $name ".$self->{projects}[$index][1]."\n";
136	sashby	1.8	}
137	williamc	1.2	}
138	sashby	1.8	}
139
140			if ( $rv )
141			{
142			# -- add to our list and save
143			push @{$self->{projects}}, [ ($name,$version,$type,$url) ];
144			}
145
146			$self->_save();
147			return 0;
148			}
149	williamc	1.2
150	williamc	1.3	sub listlinks {
151			my $self=shift;
152
153			my @dbfile=();
154			foreach $db ( @{$self->{linkeddbs}} ) {
155			push @dbfile, $db->file();
156			}
157			return @dbfile;
158			}
159
160	williamc	1.2	sub list {
161			my $self=shift;
162			return @{$self->{projects}};
163			}
164
165	williamc	1.3	sub listall {
166			my $self=shift;
167			my @list=$self->list();
168	sashby	1.7
169	williamc	1.3	foreach $db ( @{$self->{linkeddbs}} ) {
170			$self->verbose("Adding list from $db");
171			push @list, $db->listall();
172			}
173	sashby	1.7
174	williamc	1.3	return @list;
175			}
176
177	sashby	1.5	sub removearea
178			{
179			###############################################################
180			# removearea(name,version) #
181			###############################################################
182			# modified : Mon May 28 11:24:29 2001 / SFA #
183			# params : #
184			# : #
185			# : #
186			# : #
187			# function : Remove project area from scramdb file. #
188			# : #
189			# : #
190			###############################################################
191			my $self=shift;
192	sashby	1.8	my $flag=shift;
193	sashby	1.5	my $name=shift;
194			my $version=shift;
195	sashby	1.6	my $vfound=0;
196			my $nfound=0;
197
198			print "\n","Going to remove $name $version from the current scram database.....","\n";
199			print "\n";
200	williamc	1.2
201	sashby	1.6	for ( my $index=0; $index<=$#{$self->{projects}}; $index++ )
202			{
203			# Look for a project with name $name:
204			if ( $self->{projects}[$index][0] eq $name )
205			{
206			$nfound=1;
207			# Check the version:
208			if ( $self->{projects}[$index][1] eq $version )
209			{
210			# We have a match for project name and version:
211			$vfound=1;
212	sashby	1.8	if ($flag == 1)
213	sashby	1.6	{
214			# Remove the project:
215			print "\n";
216			print "Removing project:\t$name\t$version","\n\n";
217			splice(@{$self->{projects}},$index,1);
218			}
219	sashby	1.8	else
220			{
221			print "Project $name Version $version exists. Remove it? (y/n): ";
222			if ( ! (<STDIN>=~/y/i ) )
223			{
224			print "\n","Aborting project removal...bye.\n\n";
225			return 1;
226			}
227			else
228			{
229			# Remove the project:
230			print "\n";
231			print "Removing project:\t$name\t$version","\n\n";
232			splice(@{$self->{projects}},$index,1);
233			}
234			}
235	sashby	1.6	}
236			}
237			}
238
239			if ( ! $nfound \|\| ! $vfound )
240			{
241			# There was a problem finding either the
242			# named project or the desired version:
243			print "ERROR: Unable to find project $name with version $version in the database.","\n\n";
244			return 1;
245			}
246
247			print "\n";
248			# Save our new array:
249			$self->_save();
250			return 0;
251	sashby	1.5	}
252	williamc	1.2
253			sub link {
254			my $self=shift;
255			my $dbfile=shift;
256
257			my $newdb=Scram::ScramProjectDB->new($dbfile);
258			push @{$self->{linkeddbs}},$newdb;
259			$self->_save();
260			}
261
262	williamc	1.3	sub unlink {
263			my $self=shift;
264			my $file=shift;
265			my $db;
266	sashby	1.6
267	williamc	1.3	for (my $i=0; $i<=$#{$self->{linkeddbs}}; $i++ ) {
268			$db=${$self->{linkeddbs}}[$i];
269			if ( $db->file() eq $file ) {
270			$self->verbose("Removing link $file");
271			splice (@{$self->{linkeddbs}},$i,1);
272			$self->_save();
273			}
274			}
275			}
276
277	williamc	1.2	# -- Support Routines
278
279			#
280			# Search through the project list until we get a match
281			sub _findlocal {
282			my $self=shift;
283			my $name=shift;
284			my $version=shift;
285
286			my $found=-1;
287			for (my $i=0; $i<=$#{$self->{projects}}; $i++ ) {
288			if ( ( $self->{projects}[$i][0] eq $name) &&
289			( $self->{projects}[$i][1] eq $version) ) {
290			$found=$i;
291			last;
292			}
293			}
294			return $found;
295			}
296
297			sub _save {
298			my $self=shift;
299
300			use FileHandle;
301			my $fh=FileHandle->new();
302			my $filename=$self->{dbfile};
303			open ( $fh, ">$filename" );
304			# print current links
305			foreach $db ( @{$self->{linkeddbs}} ) {
306			print $fh "\!DB ".$db->file()."\n";
307			}
308			# save project info
309			my $temp;
310			foreach $elem ( @{$self->{projects}} ) {
311			$temp=join ":", @{$elem};
312			print $fh $temp."\n";
313			}
314			undef $fh;
315			}
316
317			sub _readdbfile {
318			my $self=shift;
319			my $file=shift;
320
321			use FileHandle;
322			my $fh=FileHandle->new();
323	williamc	1.3	$self->verbose("Initialising db from $file");
324	williamc	1.2	open ( $fh, "<$file" );
325
326			my @vars;
327	williamc	1.3	my $newdb;
328	williamc	1.2	while ( $map=<$fh> ) {
329			chomp $map;
330			if ( $map=~/^\!DB (.*)/ ) { # Check for other DB files
331			my $db=$1;
332			if ( -f $db ) {
333	williamc	1.3	$self->verbose("Getting Linked DB $db");
334	williamc	1.2	$newdb=Scram::ScramProjectDB->new($db);
335			push @{$self->{linkeddbs}},$newdb;
336			}
337			next;
338			}
339			@vars = split ":", $map;
340	williamc	1.3	$self->verbose("registering project $map");
341	williamc	1.2	push @{$self->{projects}}, [ @vars ];
342			}
343			undef $fh;
344			}