File Coverage

blib/lib/Set/Files.pm

Criterion	Covered	Total	%
statement	392	621	63.1
branch	176	310	56.7
condition	64	111	57.6
subroutine	20	24	83.3
pod	14	14	100.0
total	666	1080	61.6

package Set::Files;
# Copyright (c) 2001-2010 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

# TODO
#    file locking (on a per-set basis)
#    create a set (set owner if root, otherwise use current user)

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

require 5.000;
use strict;
use warnings;
use Carp;
use IO::File;

use vars qw($VERSION);
$VERSION = "1.06";

########################################################################
# METHODS
########################################################################

my @Cache = qw(type owner dir opts ele);

# The Set::Files object:
#
#   { SET => { type  => { TYPE => 1, ... },
#              owner => USER,
#              dir   => DIR,
#              ele   => { ELE  => TRUE, ... },
#              opts  => { VAR  => VAL, ... },
#
#              incl  => { SET  => 1, ... },
#              excl  => { SET  => 1, ... },
#              omit  => { ELE  => 1, ... }
#            }
#   }
#
# The ELE => TRUE value is either 1 (if the element is explicitely
# included in the file) or 2 (if the element comes from an included
# file).

sub new {
   my($class,%opts) = @_;

   my $self = _Init(%opts);
   bless $self, $class;

   return $self;
}

sub list_sets {
   my($self,$type) = @_;
   if ($type) {
      my(@ret);
      foreach my $set (keys %{ $$self{"set"} }) {
         push(@ret,$set)  if ($$self{"set"}{$set}{"type"}{$type});
      }
      return sort @ret;
   } else {
      return sort keys %{ $$self{"set"} };
   }
}

sub owner {
   my($self,$set) = @_;
   if ($set) {
      if (exists $$self{"set"}{$set}) {
         return $$self{"set"}{$set}{"owner"};
      } else {
         carp "ERROR: Invalid set: $set\n";
         return undef;
      }

   } else {
      my %tmp;
      foreach my $set (keys %{ $$self{"set"} }) {
         $tmp{ $$self{"set"}{$set}{"owner"} } = 1;
      }
      return sort keys %tmp;
   }
}

sub owned_by {
   my($self,$uid,$type) = @_;
   if (! defined $uid) {
      carp "ERROR: Must specify a UID for 'owned_by' info.\n";
      return undef;
   }

   my(@ret);
   foreach my $set (keys %{ $$self{"set"} }) {
      push(@ret,$set)  if ($$self{"set"}{$set}{"owner"} == $uid  &&
                           (! $type  ||
                            exists $$self{"set"}{$set}{"type"}{$type}));
   }
   return sort @ret;
}

sub members {
   my($self,$set) = @_;
   if (! $set) {
      carp "ERROR: Must specify a set for 'members' info.\n";
      return undef;
   }
   if (! exists $$self{"set"}{$set}) {
      carp "ERROR: Invalid set: $set\n";
      return undef;
   }
   return sort keys %{ $$self{"set"}{$set}{"ele"} };
}

sub is_member {
   my($self,$set,$ele) = @_;
   if (! $set) {
      carp "ERROR: Must specify a set for 'is_member' info.\n";
      return undef;
   }
   if (! exists $$self{"set"}{$set}) {
      carp "ERROR: Invalid set: $set\n";
      return undef;
   }
   if (! defined $ele) {
      carp "ERROR: Must specify an element for 'is_member' info.\n";
      return undef;
   }
   return 1  if (exists $$self{"set"}{$set}{"ele"}{$ele});
   return 0;
}

sub list_types {
   my($self,$set) = @_;
   if ($set) {
      if (exists $$self{"set"}{$set}) {
         return sort keys %{ $$self{"set"}{$set}{"type"} };
      } else {
         carp "ERROR: Invalid set: $set\n";
         return undef;
      }

   } else {
      my %tmp;
      foreach my $set (keys %{ $$self{"set"} }) {
         foreach my $type (keys %{ $$self{"set"}{$set}{"type"} }) {
            $tmp{$type} = 1;
         }
      }
      return sort keys %tmp;
   }
}

sub dir {
   my($self,$set) = @_;
   if ($set) {
      if (exists $$self{"set"}{$set}) {
         return $$self{"set"}{$set}{"dir"};
      } else {
         carp "ERROR: Invalid set: $set\n";
         return undef;
      }

   } else {
      my %tmp;
      foreach my $set (keys %{ $$self{"set"} }) {
         $tmp{ $$self{"set"}{$set}{"dir"} } = 1;
      }
      return sort keys %tmp;
   }
}

sub opts {
   my($self,$set,$opt) = @_;
   if (! $set) {
      carp "ERROR: Must specify a set for 'opts' info.\n";
      return undef;
   }
   if (! exists $$self{"set"}{$set}) {
      carp "ERROR: Invalid set: $set\n";
      return undef;
   }

   if ($opt) {
      if (exists $$self{"set"}{$set}{"opts"}{$opt}) {
         return $$self{"set"}{$set}{"opts"}{$opt};
      } else {
         return 0;
      }
   } else {
      return %{ $$self{"set"}{$set}{"opts"} };
   }
}

sub delete {
   my($self,$set,$nobackup) = @_;
   if (! $set) {
      carp "ERROR: Set must be specified.\n";
      return;
   }
   if (! exists $$self{"set"}{$set}) {
      carp "ERROR: Invalid set: $set.\n";
      return;
   }

   my $dir = $$self{"set"}{$set}{"dir"};

   if (! -w $dir) {
      carp "ERROR: the delete method requires write access\n";
      return;
   }

   if (! -f "$dir/$set") {
      carp "ERROR: Set file nonexistant: $dir/$set\n";
      return;
   }

   if ($nobackup) {
      unlink "$dir/$set"  ||
        carp "ERROR: Unable to remove set file: $dir/$set\n";
   } else {
      rename "$dir/$set","$dir/.set_files.$set"  ||
        carp "ERROR: Unable to backup set file: $dir/$set\n";
   }
}

sub cache {
   my($self) = @_;
   if ($$self{"read"} ne "files") {
      carp "ERROR: unable to cache information: read from cache or file\n";
      return;
   }

   my($file) = $$self{"cache"} . "/.set_files.cache";
   my($out)  = new IO::File;

   if (! $out->open("$file.new",O_CREAT|O_WRONLY,0644)) {
      croak "ERROR: unable to create cache: $file.new: $!\n";
   }

   foreach my $set (sort keys %{ $$self{"set"} }) {
      print $out $set,"\n";
      foreach my $key (@Cache) {
         next  if (! exists $$self{"set"}{$set}{$key});

         if (ref $$self{"set"}{$set}{$key} eq "HASH") {
            print $out ".sf.hash\n";
            print $out $key,"\n";
            foreach my $k (sort keys %{ $$self{"set"}{$set}{$key} }) {
               print $out $k,"\n";
               print $out $$self{"set"}{$set}{$key}{$k},"\n";
            }
            print $out ".sf.end\n";
            next;
         }

         if (ref $$self{"set"}{$set}{$key} eq "ARRAY") {
            print $out ".sf.array\n";
            print $out $key,"\n";
            foreach my $k (@{ $$self{"set"}{$set}{$key} }) {
               print $out $k,"\n";
            }
            print $out ".sf.end\n";
            next;
         }

         print $out ".sf.scalar\n";
         print $out $key,"\n";
         print $out $$self{"set"}{$set}{$key},"\n";
      }
      print $out "\n";
   }
   $out->close;

   rename "$file.new",$file  ||
     croak "ERROR: unable to commit cache: $file: $!\n";
}

sub add {
   my($self,$set,$force,$commit,@ele) = @_;
   if ($$self{"read"} ne "files") {
      carp "ERROR: unable to add elements: read from cache\n";
      return;
   }

   if (! $set) {
      carp "ERROR: Must specify a set for adding elements.\n";
      return undef;
   }
   if (! exists $$self{"set"}{$set}) {
      carp "ERROR: Invalid set: $set\n";
      return undef;
   }
   if (! @ele) {
      carp "ERROR: No elements present for adding.\n";
      return undef;
   }

   my(@add);
   foreach my $ele (@ele) {
      if (! exists $$self{"set"}{$set}{"ele"}{$ele}  ||
          ($$self{"set"}{$set}{"ele"}{$ele} == 2  &&  $force)) {
         $$self{"set"}{$set}{"ele"}{$ele} = 1;
         delete $$self{"set"}{$set}{"omit0"}{$ele};
         push(@add,$ele);
      }
   }
   return 0  if (! @add);

   commit($self,$set)  if ($commit);
   return $#add+1;
}

sub remove {
   my($self,$set,$force,$commit,@ele) = @_;
   if ($$self{"read"} ne "files") {
      carp "ERROR: unable to remove elements: read from cache\n";
      return;
   }

   if (! $set) {
      carp "ERROR: Must specify a set for removing elements.\n";
      return undef;
   }
   if (! exists $$self{"set"}{$set}) {
      carp "ERROR: Invalid set: $set\n";
      return undef;
   }
   if (! @ele) {
      carp "ERROR: No elements present for removing.\n";
      return undef;
   }

   my(@rem);
   foreach my $ele (@ele) {
      if (exists $$self{"set"}{$set}{"ele"}{$ele}  ||
          ( (! exists $$self{"set"}{$set}{"omit0"}  ||
             ! exists $$self{"set"}{$set}{"omit0"}{$ele})  &&  $force )) {
         delete $$self{"set"}{$set}{"ele"}{$ele};
         $$self{"set"}{$set}{"omit0"}{$ele} = 1;
         push(@rem,$ele);
      }
   }
   return 0  if (! @rem);

   commit($self,$set)  if ($commit);
   return $#rem+1;
}

sub commit {
   my($self,@set) = @_;
   if (! @set) {
      carp "ERROR: Set must be specified.\n";
      return;
   }
   if ($$self{"read"} ne "file"  &&
       $$self{"read"} ne "files") {
      carp "ERROR: unable to commit changes: read from cache\n";
      return;
   }

   foreach my $set (@set) {
      if (! exists $$self{"set"}{$set}) {
         carp "ERROR: Invalid set: $set.\n";
         next;
      }

      # get dir and find out where to write new stuff

      my $dir = $$self{"set"}{$set}{"dir"};
      my $scr;
      my $wri;
      if (-w $dir) {
         $wri = 1;
         $scr = $dir;
      } else {
         $wri = 0;
         $scr = $$self{"scratch"};
      }

      # write the new file

      my $template  = $$self{"cache"} . "/.set_files.template";
      my $file      = "$scr/.set_files.$set.new";
      my $out       = new IO::File;
      my $in        = new IO::File;

      my @temp;
      if (-f $template) {
         if (! $in->open($template)) {
            carp "ERROR: Unable to open template: $file: $!\n";
         } else {
            @temp = <$in>;
            $in->close;
         }
      }

      if (! $out->open($file,O_CREAT|O_WRONLY,0644)) {
         carp "ERROR: Unable to write file: $file: $!\n";
         next;
      }
      foreach my $line (@temp) {
         print $out $line;
      }

      my $t = $$self{"tagchars"};

      foreach my $inc (sort keys %{ $$self{"set"}{$set}{"incl0"} }) {
         print $out $t,"INCLUDE $inc\n";
      }
      foreach my $exc (sort keys %{ $$self{"set"}{$set}{"excl0"} }) {
         print $out $t,"EXCLUDE $exc\n";
      }
      foreach my $omit (sort keys %{ $$self{"set"}{$set}{"omit0"} }) {
         print $out $t,"OMIT    $omit\n";
      }
      foreach my $type (sort keys %{ $$self{"set"}{$set}{"type0"} }) {
         print $out $t,"TYPE    $type\n";
      }
      foreach my $type (sort keys %{ $$self{"set"}{$set}{"notype0"} }) {
         print $out $t,"NOTYPE  $type\n";
      }
      foreach my $opt (sort keys %{ $$self{"set"}{$set}{"opts"} }) {
         my $val = $$self{"set"}{$set}{"opts"}{$opt};
         print $out $t,"OPTION  $opt = $val\n";
      }
      foreach my $ele (sort keys %{ $$self{"set"}{$set}{"ele"} }) {
         next  if ($$self{"set"}{$set}{"ele"}{$ele} == 2);
         print $out "$ele\n";
      }

      $out->close;

      # back up the old one

      if ($wri) {
         rename "$dir/$set","$dir/.set_files.$set"  ||  do {
            carp "ERROR: Unable to back up file: $dir/$set: $!\n";
            next;
         };
      } else {
         my @in;
         if (! $in->open("$dir/$set")) {
            carp "ERROR: Unable to read file: $dir/$set: $!\n";
            next;
         }
         @in = <$in>;
         $in->close;
         if (! $out->open("$scr/.set_files.$set",O_CREAT|O_WRONLY,0644)) {
            carp "ERROR: Unable to write file: $scr/.set_files.$set: $!\n";
            next;
         }
         foreach my $line (@in) {
            print $out $line;
         }
         $out->close;
      }

      # move the new one into place

      if ($wri) {
         rename "$dir/.set_files.$set.new","$dir/$set"  ||  do {
            carp "ERROR: Unable to commit file: $dir/$set: $!\n";
            next;
         };
      } else {
         my @in;
         if (! $in->open("$scr/.set_files.$set.new")) {
            carp "ERROR: Unable to read file: $scr/.set_files.$set.new: $!\n";
            next;
         }
         @in = <$in>;
         $in->close;
         if (! $out->open("$dir/$set",O_CREAT|O_WRONLY,0644)) {
            carp "ERROR: Unable to write file: $dir/$set: $!\n";
            next;
         }
         foreach my $line (@in) {
            print $out $line;
         }
         $out->close;
      }
   }
}

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

sub _Init {
   my(%opts)=@_;
   my(%self) = ();

   ###########################
   # Initialization

   # path

   my(@dir,@tmp);
   if (exists $opts{"path"}) {
      my $dir = $opts{"path"};
      if (ref($dir) eq "ARRAY") {
         @tmp = @$dir;
      } elsif (ref($dir)) {
         croak "ERROR: Invalid path value\n";
      } else {
         @tmp = split(":",$dir);
      }
   } else {
      @tmp = (".");
   }

   foreach my $dir (@tmp) {
      if (-d $dir) {
         push(@dir,$dir);
      } else {
         carp "WARNING: invalid directory: $dir\n";
      }
   }

   if (! @dir) {
      croak "ERROR: no valid path elements\n";
   }

   # cache

   my($cache,$cache_opt);
   if (exists $opts{"cache"}) {
      $cache       = $opts{"cache"};
      $cache_opt   = 1;
   } else {
      $cache       = $dir[0];
      $cache_opt   = 0;
   }
   $self{"cache"} = $cache;

   if (! -d $cache) {
      croak "ERROR: invalid cache directory: $cache\n";
   }

   # scratch

   my($scratch);
   if (exists $opts{"scratch"}) {
      $scratch       = $opts{"scratch"};
   } else {
      $scratch       = (-d '/tmp' ? '/tmp' : '.');
   }
   $self{"scratch"} = $scratch;

   if (! -d $scratch  ||
       ! -w $scratch) {
      croak "ERROR: invalid scratch directory: $scratch\n";
   }

   # invalid_quiet

   my($invalid_quiet);
   if (exists $opts{"invalid_quiet"}) {
      $invalid_quiet = 1;
   } else {
      $invalid_quiet = 0;
   }

   # read

   my($read);
   if (exists $opts{"read"}) {
      $read = $opts{"read"};
      if ($read ne "cache"  &&
          $read ne "files"  &&
          $read ne "file") {
         croak "ERROR: Invalid read option: $read\n";
      }
   } else {
      if ($cache_opt) {
         $read="cache";
      } else {
         $read="files";
      }
   }
   $self{"read"} = $read;

   # set

   my($set);
   if (exists $opts{"set"}) {
      $set = $opts{"set"};
   } else {
      $set = "";
   }

   if ($read eq "file"  &&  ! $set) {
      croak "ERROR: Read file requires a set\n";
   }
   if ($set  &&  $read ne "file") {
      carp "WARNING: Set option ignored when not reading a single file\n";
      return;
   }

   # LOCK

   my($lock);
   if (exists $opts{"lock"}) {
      $lock = ($opts{"lock"} ? 1 : 0);
   } else {
      $lock = 0;
   }

   if ($lock) {
   }

   ###########################
   # Read Cache

   if ($read eq "cache") {
      my $file = "$cache/.set_files.cache";
      if (-f $file) {
         my $in = new IO::File;
         $in->open($file)  ||
           croak "ERROR: unable to read cache: $file: $!\n";
         my @in = <$in>;
         $in->close;
         chomp(@in);
         while (@in) {
            my $set = shift(@in);
            while ($in[0]) {
               my $tmp = shift(@in);
               my $key = shift(@in);
               if ($tmp eq ".sf.hash") {
                  while ($in[0] ne ".sf.end") {
                     my $k = shift(@in);
                     $self{"set"}{$set}{$key}{$k} = shift(@in);
                  }
                  shift(@in);

               } elsif ($tmp eq ".sf.array") {
                  my @tmp;
                  while ($in[0] ne ".sf.end") {
                     push(@tmp,shift(@in));
                  }
                  $self{"set"}{$set}{$key} = [ @tmp ];
                  shift(@in);

               } elsif ($tmp eq ".sf.scalar") {
                  $self{"set"}{$set}{$key} = shift(@in);
               }
            }
            shift(@in);
         }

      } else {
         $read = "files";
      }
   }

   ###########################
   # Read Files

   if ($read eq "files"  ||
       $read eq "file") {

      # valid_file

      my($valid_file,$valid_file_re,$valid_file_nre);
      if (exists $opts{"valid_file"}) {
         my $tmp = $opts{"valid_file"};
         if (ref($tmp) eq "CODE") {
            $valid_file     = $tmp;
            $valid_file_re  = "";
            $valid_file_nre = "";
         } elsif (ref($tmp)) {
            croak "ERROR: Invalid valid_file value\n";
         } elsif ($tmp =~ s,^!,,) {
            $valid_file     = "";
            $valid_file_re  = "";
            $valid_file_nre = $tmp;
         } else {
            $valid_file     = "";
            $valid_file_re  = $tmp;
            $valid_file_nre = "";
         }
      } else {
         $valid_file     = "";
         $valid_file_re  = "";
         $valid_file_nre = "";
      }

      my %dir;
      foreach my $dir (@dir) {
         if (! opendir(DIR,$dir)) {
            carp "ERROR: Can't read directory: $dir: $!\n";
            next;
         }
         my(@f) = readdir(DIR);
         closedir(DIR);
         foreach my $f (@f) {
            next  if ($f eq "."  ||
                      $f eq ".." ||
                      $f =~ /^.set_files/ ||
                      ! -f "$dir/$f");
            if (($valid_file_nre  &&  $f =~ /$valid_file_nre/)  ||
                ($valid_file_re   &&  $f !~ /$valid_file_re/)  ||
                ($valid_file      &&  ! &$valid_file($dir,$f))) {
               warn "WARNING: File fails validity test: $f\n"
                 if (! $invalid_quiet);
               next;
            }
            if (exists $dir{$f}) {
               carp "WARNING: File redefined: $f\n";
            } else {
               $dir{$f} = $dir;
            }
         }
      }

      # types

      my(@types);
      if (exists $opts{"types"}) {
         my $type = $opts{"types"};
         if (ref($type) eq "ARRAY") {
            @types = @$type;
         } elsif (ref($type)) {
            croak "ERROR: Invalid types value\n";
         } else {
            @types = ($type);
         }
      } else {
         @types = ("_");
      }

      # default_types

      my(@def_types);
      if (exists $opts{"default_types"}) {
         my $type = $opts{"default_types"};
         if (ref($type) eq "ARRAY") {
            @def_types = @$type;
         } elsif (ref($type)) {
            croak "ERROR: Invalid default_types value\n";
         } elsif ($type eq "all") {
            @def_types = (@types);
         } elsif ($type eq "none") {
            @def_types = ();
         } else {
            @def_types = ($type);
         }
      } else {
         @def_types = @types;
      }

      my %tmp = map { $_,1 } @types;
      my @tmp;
      foreach my $type (@def_types) {
         if (! exists $tmp{$type}) {
            carp "WARNING: Invalid default_types value: $type\n";
         } else {
            push(@tmp,$type);
         }
      }
      @def_types = @tmp;

      # comment

      my($comment);
      if (exists $opts{"comment"}) {
         $comment = $opts{"comment"};
      } else {
         $comment = "#.*";
      }
      $self{"comment"} = $comment;

      # tagchars

      my($tagchars);
      if (exists $opts{"tagchars"}) {
         $tagchars = $opts{"tagchars"};
      } else {
         $tagchars = '@';
      }
      $self{"tagchars"} = $tagchars;

      # valid_ele

      my($valid_ele,$valid_ele_re,$valid_ele_nre);
      if (exists $opts{"valid_ele"}) {
         my $tmp = $opts{"valid_ele"};
         if (ref($tmp) eq "CODE") {
            $valid_ele     = $tmp;
            $valid_ele_re  = "";
            $valid_ele_nre = "";
         } elsif (ref($tmp)) {
            croak "ERROR: Invalid valid_ele value\n";
         } elsif ($tmp =~ s,^!,,) {
            $valid_ele     = "";
            $valid_ele_re  = "";
            $valid_ele_nre = $tmp;
         } else {
            $valid_ele     = "";
            $valid_ele_re  = $tmp;
            $valid_ele_nre = "";
         }
      } else {
         $valid_ele     = "";
         $valid_ele_re  = "";
         $valid_ele_nre = "";
      }

      # Read File

      if ($read eq "file") {
         my(@set) = ($set);;
         while (@set) {
            $set = shift(@set);
            next  if (exists $self{"set"}{$set});

            if (! exists $dir{$set}) {
               croak "ERROR: invalid set to read: $set\n";
            }

            $self{"set"}{$set} = _ReadSet($set,$dir{$set},\@types,\@def_types,
                                          $comment,$tagchars,
                                          $valid_ele,$valid_ele_re,$valid_ele_nre,
                                          $invalid_quiet);
            push (@set,keys %{ $self{"set"}{$set}{"incl"} })
              if (exists $self{"set"}{$set}{"incl"});
            push (@set,keys %{ $self{"set"}{$set}{"excl"} })
              if (exists $self{"set"}{$set}{"excl"});
         }
      }

      # Read Files

      if ($read eq "files") {
         foreach my $set (keys %dir) {
            $self{"set"}{$set} = _ReadSet($set,$dir{$set},\@types,\@def_types,
                                          $comment,$tagchars,
                                          $valid_ele,$valid_ele_re,$valid_ele_nre,
                                          $invalid_quiet);
         }
      }

      # Includes and Excludes

      foreach my $set (keys %{ $self{"set"} }) {
         if (exists $self{"set"}{$set}{"incl"}) {
            foreach my $inc (keys %{ $self{"set"}{$set}{"incl"} }) {
               if (! exists $self{"set"}{$inc}) {
                  carp "WARNING: Invalid include [ $inc ] in set: $set\n";
                  delete $self{"set"}{$set}{"incl"}{$inc};
                  delete $self{"set"}{$set}{"incl"}
                    if (! keys %{ $self{"set"}{$set}{"incl"} });
               }
            }
         }

         if (exists $self{"set"}{$set}{"excl"}) {
            foreach my $exc (keys %{ $self{"set"}{$set}{"excl"} }) {
               if (! exists $self{"set"}{$exc}) {
                  carp "WARNING: Invalid exclude [ $exc ] in set: $set\n";
                  delete $self{"set"}{$set}{"excl"}{$exc};
                  delete $self{"set"}{$set}{"excl"}
                    if (! keys %{ $self{"set"}{$set}{"excl"} });
               }
            }
         }
      }

      while (1) {
         my $flag1 = _ExpandInclude($self{"set"});
         my $flag2 = _ExpandExclude($self{"set"});
         last  if (! $flag1  &&  ! $flag2);
      }

      foreach my $set (keys %{ $self{"set"} }) {
         if (exists $self{"set"}{$set}{"excl"}  ||
             exists $self{"set"}{$set}{"incl"}) {
            carp "ERROR: Unresolved (circular) dependancy: $set\n";
         } elsif (exists $self{"set"}{$set}{"omit"}) {
            foreach my $ele (keys %{ $self{"set"}{$set}{"omit"} }) {
               delete $self{"set"}{$set}{"ele"}{$ele};
            }
            delete $self{"set"}{$set}{"omit"};
         }
      }

      if (! keys %{ $self{"set"} }) {
         croak "ERROR: No set data read.\n";
      }
   }

   return \%self;
}

sub _ReadSet {
   my($set,$dir,$types,$def_types,$comment,$tagchars,
      $valid_ele,$valid_ele_re,$valid_ele_nre,$invalid_quiet) = @_;
   my %set;

   $set{"dir"} = $dir;

   my $in = new IO::File;
   if (! $in->open("$dir/$set")) {
      croak "ERROR: Unable to open file: $dir/$set: $!\n";
   }
   my $uid = ( stat("$dir/$set") )[4];
   $set{"owner"} = $uid;
   _ReadSetFile($set,$in,\%set,$types,$def_types,$comment,
                $tagchars,$valid_ele,$valid_ele_re,$valid_ele_nre,
                $invalid_quiet);
   $in->close;
   return \%set;
}

sub _ReadSetFile {
   my($set,$in,$self,$types,$def_types,$comment,$tagchars,
      $valid_ele,$valid_ele_re,$valid_ele_nre,$invalid_quiet)=@_;
   my %types = map { $_,1 } @$types;
   my %def_types = map { $_,1 } @$def_types;
   $$self{"type"} = { %def_types };
   my(@in) = <$in>;
   chomp(@in);
   foreach my $line (@in) {
      $line =~ s,$comment,,;
      $line =~ s,^\s+,,;
      $line =~ s,\s+$,,;
      next  if (! $line);

      if ($line =~ s,^$tagchars,,) {
         $line =~ s,^\s+,,;
         if ($line =~ /^include\s+(.+)/i) {
            my $tmp = $1;
            my @tmp = split(/,/,$tmp);
            foreach my $tmp (@tmp) {
               $$self{"incl"}{$tmp} = 1;
               $$self{"incl0"}{$tmp} = 1;
            }

         } elsif ($line =~ /^exclude\s+(.+)/i) {
            my $tmp = $1;
            my @tmp = split(/,/,$tmp);
            foreach my $tmp (@tmp) {
               $$self{"excl"}{$tmp} = 1;
               $$self{"excl0"}{$tmp} = 1;
            }

         } elsif ($line =~ /^type\s+(.+)/i) {
            my $tmp = $1;
            my @tmp = split(/,/,$tmp);
            foreach my $tmp (@tmp) {
               if (exists $types{$tmp}) {
                  $$self{"type"}{$tmp} = 1;
                  $$self{"type0"}{$tmp} = 1;
               } else {
                  carp "ERROR: Invalid set type: $set [ $tmp ]\n";
               }
            }

         } elsif ($line =~ /^notype\s+(.+)/i) {
            my $tmp = $1;
            my @tmp = split(/,/,$tmp);
            foreach my $tmp (@tmp) {
               if (exists $types{$tmp}) {
                  delete $$self{"type"}{$tmp};
                  $$self{"notype0"}{$tmp} = 1;
               } else {
                  carp "ERROR: Invalid set type: $set [ $tmp ]\n";
               }
            }

         } elsif ($line =~ /^omit\s+(.+)/i) {
            $$self{"omit"}{$1} = 1;
            $$self{"omit0"}{$1} = 1;

         } elsif ($line =~ /^option\s+(.+?)\s*=\s*(.*)/i) {
            my($var,$val)=($1,$2);
            $val=0  if (! $val);
            $$self{"opts"}{$var} = $val;

         } elsif ($line =~ /^option\s+(.+)/i) {
            $$self{"opts"}{$1} = 1;

         } else {
            carp "ERROR: Invalid tag line: $set: $line\n";
         }

      } else {
         if (($valid_ele_nre  &&  $line =~ /$valid_ele_nre/)  ||
             ($valid_ele_re   &&  $line !~ /$valid_ele_re/)  ||
             ($valid_ele      &&  ! &$valid_ele($set,$line))) {
            warn "WARNING: Element fails validity test: $line\n"
              if (! $invalid_quiet);
            next;
         }
         $$self{"ele"}{$line} = 1;
      }
   }
}

sub _ExpandInclude {
   my($self)=@_;
   my $prog = 0;                # overall progress

   my %inc;
   my %exc;
   foreach my $set (keys %$self) {
      $inc{$set} = 1  if (exists $$self{$set}{"incl"});
      $exc{$set} = 1  if (exists $$self{$set}{"excl"});
   }

   while (1) {
      last  if (! keys %inc);
      my $progress = 0;         # progress this iteration

      foreach my $set (keys %inc) {
         foreach my $inc (keys %{ $$self{$set}{"incl"} }) {
            next  if (exists $inc{$inc}  ||
                      exists $exc{$inc});
            $prog = $progress = 1;

            foreach my $ele (keys %{ $$self{$inc}{"ele"} }) {
               $$self{$set}{"ele"}{$ele} = 2
                 if (! exists $$self{$set}{"ele"}{$ele});
            }

            delete $inc{$set};
            delete $$self{$set}{"incl"}{$inc};
            delete $$self{$set}{"incl"}  if (! keys %{ $$self{$set}{"incl"} });
         }
      }
      next  if ($progress);
      last;
   }
   return $prog;
}

sub _ExpandExclude {
   my($self)=@_;
   my $prog = 0;

   my %inc;
   my %exc;
   foreach my $set (keys %$self) {
      $inc{$set} = 1  if (exists $$self{$set}{"incl"});
      $exc{$set} = 1  if (exists $$self{$set}{"excl"});
   }

   while (1) {
      last  if (! keys %exc);
      my $progress = 0;         # progress this iteration

      foreach my $set (keys %exc) {
         next  if (exists $inc{$set}); # only exclude after all includes
         foreach my $exc (keys %{ $$self{$set}{"excl"} }) {
            next  if (exists $inc{$exc}  ||
                      exists $exc{$exc});
            $prog = $progress = 1;

            foreach my $ele (keys %{ $$self{$exc}{"ele"} }) {
               # We don't want to exclude elements that are explicitly included
               # in the set file.
               delete $$self{$set}{"ele"}{$ele}
                 if (exists $$self{$set}{"ele"}{$ele}  &&
                     $$self{$set}{"ele"}{$ele} == 2);
            }

            delete $exc{$set};
            delete $$self{$set}{"excl"}{$exc};
            delete $$self{$set}{"excl"}  if (! keys %{ $$self{$set}{"excl"} });
         }
      }
      next  if ($progress);
      last;
   }
   return $prog;
}

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

1;
# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 3
# cperl-continued-statement-offset: 2
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
# cperl-label-offset: -2
# End: