View of /trunk/webwork-modperl/lib/WeBWorK/DB/Classlist.pm

    1 ################################################################################
    2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project
    3 # $Id$
    4 ################################################################################
    5 
    6 package WeBWorK::DB::Classlist;
    7 
    8 =head1 NAME
    9 
   10 WeBWorK::DB::Classlist - interface with the WeBWorK classlist database.
   11 
   12 =cut
   13 
   14 use strict;
   15 use warnings;
   16 use WeBWorK::User;
   17 use WeBWorK::Utils qw(dbDecode dbEncode);
   18 
   19 # there should be a `use' line for each database type
   20 use WeBWorK::DB::GDBM;
   21 
   22 # new($courseEnv)
   23 # $courseEnv - an instance of CourseEnvironment
   24 sub new($$) {
   25   my $invocant = shift;
   26   my $class = ref($invocant) || $invocant;
   27   my $courseEnv = shift;
   28   my $dbModule = fullyQualifiedPackageName($courseEnv->{dbInfo}->{cldb_type});
   29   my $self = {
   30     classlist_file => $courseEnv->{dbInfo}->{cldb_file},
   31   };
   32   $self->{classlist_db} = $dbModule->new($self->{classlist_file});
   33   bless $self, $class;
   34   return $self;
   35 }
   36 
   37 sub fullyQualifiedPackageName($) {
   38   my $n = shift;
   39   my $package = __PACKAGE__;
   40   $package =~ s/([^:]*)$/$n/;
   41   return $package;
   42 }
   43 
   44 # -----
   45 
   46 # getUsers() - returns a list of user IDs present in the database
   47 sub getUsers($) {
   48   my $self = shift;
   49   return unless $self->{classlist_db}->connect("ro");
   50   my @result = keys %{$self->{classlist_db}->hashRef};
   51   $self->{classlist_db}->disconnect;
   52   @result = grep !/^>>/, @result; # remove keys which start with ">>"
   53   return @result;
   54 }
   55 
   56 # -----
   57 
   58 # getUser($userID) - returns a WeBWorK::User object if $userID exists
   59 #                    or an undefined value if not.
   60 # $userID - the ID of the user requested
   61 sub getUser($$) {
   62   my $self = shift;
   63   my $userID = shift;
   64   if ($userID =~ /^>>/) {
   65     warn "Attempt to use the special key $userID as a user!";
   66     return;
   67   }
   68   return unless $self->{classlist_db}->connect("ro");
   69   my $result = $self->{classlist_db}->hashRef->{$userID};
   70   $self->{classlist_db}->disconnect;
   71   return unless defined $result;
   72   return hash2user($userID, dbDecode($result));
   73 }
   74 
   75 # setUser($user) - if a user with the same user ID as $user exists, that user
   76 #                  is replaced. if not, a new user is added. A true value is
   77 #                  returned in success, an undefined value on failure.
   78 # $user - an instance of WeBWorK::User containing user data
   79 sub setUser($$) {
   80   my $self = shift;
   81   my $user = shift;
   82   if ($user->id =~ /^>>/) {
   83     warn "Attempt to use the special key \"", $user->id, "\" as a user ID!";
   84     return;
   85   }
   86   die "Can't add/modify user ", $user->id, ": classlist database locked" if $self->locked;
   87   return unless $self->{classlist_db}->connect("rw");
   88   $self->{classlist_db}->hashRef->{$user->id} = dbEncode(user2hash($user));
   89   $self->{classlist_db}->disconnect;
   90   return 1;
   91 }
   92 
   93 # deleteUser($userID) - removed a user with the specified user ID. Returns
   94 #                       a true value on success, an undefined one on failure.
   95 # $userID - the ID of the user to delete
   96 sub deleteUser($$) {
   97   my $self = shift;
   98   my $userID = shift;
   99   if ($userID =~ /^>>/) {
  100     warn "Attempt to use the special key \"$userID\" as a user ID!";
  101     return;
  102   }
  103   die "Can't delete user $userID: classlist database locked" if $self->locked;
  104   return unless $self->{classlist_db}->connect("rw");
  105   delete $self->{classlist_db}->hashRef->{$userID};
  106   $self->{classlist_db}->disconnect;
  107   return 1;
  108 }
  109 
  110 # -----
  111 
  112 # lock() - locks the database associated with this classlist object. when
  113 #          a database is locked, it cannot be modified except to unlock it.
  114 sub lock($) {
  115   my $self = shift;
  116   return unless $self->{classlist_db}->connect("rw");
  117   $self->{classlist_db}->hashRef->{">>lock_status"} = "locked";
  118   $self->{classlist_db}->disconnect;
  119   return 1;
  120 }
  121 
  122 # unlock() - unlocks the database associated with this classlist object.
  123 sub unlock($) {
  124   my $self = shift;
  125   return unless $self->{classlist_db}->connect("rw");
  126   # the old code sets this to "unlocked", but I going to delete it instead
  127   delete $self->{classlist_db}->hashRef->{">>lock_status"};
  128   $self->{classlist_db}->disconnect;
  129   return 1;
  130 }
  131 
  132 # locked() - returns true if the database is locked, false if it is not.
  133 sub locked($) {
  134   my $self = shift;
  135   return unless $self->{classlist_db}->connect("ro");
  136   my $result = $self->{classlist_db}->hashRef->{">>lock_status"};
  137   $self->{classlist_db}->disconnect;
  138   return defined $result and $result eq "locked";
  139 }
  140 
  141 # -----
  142 
  143 # the classlist_DBglue.pl library from the WeBWorK 1.x series uses four
  144 # character hash keys -- we want to use more descriptive field names, so
  145 # we do some conversion here.
  146 #
  147 # This is a little dangerous, since we hardcode User's schema, but I don't
  148 # think it'll be a problem -- hopefully future backends will use the new
  149 # field names and the old ones will wither away.
  150 
  151 sub hash2user($%) {
  152   my $userID = shift;
  153   my %hash = @_;
  154   my $user = WeBWorK::User->new(id => $userID);
  155   $user->first_name    ( $hash{stfn} ) if defined $hash{stfn};
  156   $user->last_name     ( $hash{stln} ) if defined $hash{stln};
  157   $user->email_address ( $hash{stea} ) if defined $hash{stea};
  158   $user->student_id    ( $hash{stid} ) if defined $hash{stid};
  159   $user->status        ( $hash{stst} ) if defined $hash{stst};
  160   $user->section       ( $hash{clsn} ) if defined $hash{clsn};
  161   $user->recitation    ( $hash{clrc} ) if defined $hash{clrc};
  162   $user->comment       ( $hash{comt} ) if defined $hash{comt};
  163   return $user;
  164 }
  165 
  166 sub user2hash($) {
  167   my $user = shift;
  168   my %hash;
  169   $hash{stfn} = $user->first_name    if defined $user->first_name;
  170   $hash{stln} = $user->last_name     if defined $user->last_name;
  171   $hash{stea} = $user->email_address if defined $user->email_address;
  172   $hash{stid} = $user->student_id    if defined $user->student_id;
  173   $hash{stst} = $user->status        if defined $user->status;
  174   $hash{clsn} = $user->section       if defined $user->section;
  175   $hash{clrc} = $user->recitation    if defined $user->recitation;
  176   $hash{comt} = $user->comment       if defined $user->comment;
  177   return %hash;
  178 }
  179 
  180 1;