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

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