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   return unless defined $string and $string;
  139   my %hash = $string =~ /(.*?)(?<!\\)=(.*?)(?:(?<!\\)&|$)/g;
  140   $hash{$_} =~ s/\\(.)/$1/g foreach (keys %hash); # unescape anything
  141   return %hash;
  142 }
  143 
  144 sub encode(@) {
  145   my %hash = @_;
  146   my $string;
  147   foreach (keys %hash) {
  148     $hash{$_} = "" unless defined $hash{$_}; # promote undef to ""
  149     $hash{$_} =~ s/(=|&)/\\$1/g; # escape & and =
  150     $string .= "$_=$hash{$_}&";
  151   }
  152   chop $string; # remove final '&' from string for old code :p
  153   return $string;
  154 }
  155 
  156 # -----
  157 
  158 # the classlist_DBglue.pl library from the WeBWorK 1.x series uses four
  159 # character hash keys -- we want to use more descriptive field names, so
  160 # we do some conversion here.
  161 #
  162 # This is a little dangerous, since we hardcode User's schema, but I don't
  163 # think it'll be a problem -- hopefully future backends will use the new
  164 # field names and the old ones will wither away.
  165 
  166 sub hash2user($%) {
  167   my $userID = shift;
  168   my %hash = @_;
  169   my $user = WeBWorK::User->new(id => $userID);
  170   $user->first_name    ( $hash{stfn} ) if defined $hash{stfn};
  171   $user->last_name     ( $hash{stln} ) if defined $hash{stln};
  172   $user->email_address ( $hash{stea} ) if defined $hash{stea};
  173   $user->student_id    ( $hash{stid} ) if defined $hash{stid};
  174   $user->status        ( $hash{stst} ) if defined $hash{stst};
  175   $user->section       ( $hash{clsn} ) if defined $hash{clsn};
  176   $user->recitation    ( $hash{clrc} ) if defined $hash{clrc};
  177   $user->comment       ( $hash{comt} ) if defined $hash{comt};
  178   return $user;
  179 }
  180 
  181 sub user2hash($) {
  182   my $user = shift;
  183   my %hash;
  184   $hash{stfn} = $user->first_name    if defined $user->first_name;
  185   $hash{stln} = $user->last_name     if defined $user->last_name;
  186   $hash{stea} = $user->email_address if defined $user->email_address;
  187   $hash{stid} = $user->student_id    if defined $user->student_id;
  188   $hash{stst} = $user->status        if defined $user->status;
  189   $hash{clsn} = $user->section       if defined $user->section;
  190   $hash{clrc} = $user->recitation    if defined $user->recitation;
  191   $hash{comt} = $user->comment       if defined $user->comment;
  192   return %hash;
  193 }
  194 
  195 1;