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