View of /trunk/webwork2/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::DB::User;
   11 
   12 # there should be a `use' line for each database type
   13 use WeBWorK::DB::GDBM;
   14 
   15 # new($invocant, $courseEnv)
   16 # $invocant implicitly set by caller
   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 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 sub getUser($$) {
   52   my $self = shift;
   53   my $userID = shift;
   54   if ($userID =~ /^>>/) {
   55     warn "Attempt to use the special key $userID as a user!";
   56     return;
   57   }
   58   return unless $self->{classlist_db}->connect("ro");
   59   my $result = $self->{classlist_db}->hashRef->{$userID};
   60   $self->{classlist_db}->disconnect;
   61   return unless defined $result;
   62   return hash2user($userID, decode($result));
   63 }
   64 
   65 sub setUser($$) {
   66   my $self = shift;
   67   my $user = shift;
   68   if ($user->id =~ /^>>/) {
   69     warn "Attempt to use the special key \"", $user->id, "\" as a user ID!";
   70     return;
   71   }
   72   die "Can't add/modify user ", $user->id, ": classlist database locked" if $self->locked;
   73   $self->{classlist_db}->connect("rw");
   74   $self->{classlist_db}->hashRef->{$user->id} = encode(user2hash($user));
   75   $self->{classlist_db}->disconnect;
   76 }
   77 
   78 sub deleteUser($$) {
   79   my $self = shift;
   80   my $userID = shift;
   81   if ($userID =~ /^>>/) {
   82     warn "Attempt to use the special key \"$userID\" as a user ID!";
   83     return;
   84   }
   85   die "Can't delete user $userID: classlist database locked" if $self->locked;
   86   return unless $self->{classlist_db}->connect("rw");
   87   delete $self->{classlist_db}->hashRef->{$userID};
   88   $self->{classlist_db}->disconnect;
   89 }
   90 
   91 # -----
   92 
   93 sub lock($) {
   94   my $self = shift;
   95   return unless $self->{classlist_db}->connect("rw");
   96   $self->{classlist_db}->hashRef->{">>lock_status"} = "locked";
   97   $self->{classlist_db}->disconnect;
   98 }
   99 
  100 sub unlock($) {
  101   my $self = shift;
  102   return unless $self->{classlist_db}->connect("rw");
  103   # the old code sets this to "unlocked", but I'm going to remove it.
  104   delete $self->{classlist_db}->hashRef->{">>lock_status"};
  105   $self->{classlist_db}->disconnect;
  106 }
  107 
  108 sub locked($) {
  109   my $self = shift;
  110   return unless $self->{classlist_db}->connect("ro");
  111   my $result = $self->{classlist_db}->hashRef->{">>lock_status"};
  112   $self->{classlist_db}->disconnect;
  113   return defined $result and $result eq "locked";
  114 }
  115 
  116 # -----
  117 
  118 sub decode($) {
  119   my $string = shift;
  120   my %hash = $string =~ /(.*?)(?<!\\)=(.*?)(?:(?<!\\)&|$)/g;
  121   $hash{$_} =~ s/\\(.)/$1/ foreach (keys %hash); # unescape anything
  122   return %hash;
  123 }
  124 
  125 sub encode(@) {
  126   my %hash = @_;
  127   my $string;
  128   foreach (keys %hash) {
  129     $hash{$_} =~ s/(=|&)/\\$1/; # escape & and =
  130     $string .= "$_=$hash{$_}&";
  131   }
  132   chop $string; # remove final '&' from string for old code :p
  133   return $string;
  134 }
  135 
  136 # -----
  137 
  138 # the classlist_DBglue.pl library from the WeBWorK 1.x series uses four
  139 # character hash keys -- we want to use more descriptive field names, so
  140 # we do some conversion here.
  141 #
  142 # This is a little dangerous, since we hardcode User's schema, but I don't
  143 # think it'll be a problem -- hopefully future backends will use the new
  144 # field names and the old ones will wither away.
  145 
  146 sub hash2user($%) {
  147   my $userID = shift;
  148   my %hash = @_;
  149   my $user = WeBWorK::DB::User->new(id => $userID);
  150   $user->first_name    ( $hash{stfn} ) if defined $hash{stfn};
  151   $user->last_name     ( $hash{stln} ) if defined $hash{stln};
  152   $user->email_address ( $hash{stea} ) if defined $hash{stea};
  153   $user->student_id    ( $hash{stid} ) if defined $hash{stid};
  154   $user->status        ( $hash{stst} ) if defined $hash{stst};
  155   $user->section       ( $hash{clsn} ) if defined $hash{clsn};
  156   $user->recitation    ( $hash{clrc} ) if defined $hash{clrc};
  157   $user->comment       ( $hash{comt} ) if defined $hash{comt};
  158   return $user;
  159 }
  160 
  161 sub user2hash($) {
  162   my $user = shift;
  163   my %hash;
  164   $hash{stfn} = $user->first_name    if defined $user->first_name;
  165   $hash{stln} = $user->last_name     if defined $user->last_name;
  166   $hash{stea} = $user->email_address if defined $user->email_address;
  167   $hash{stid} = $user->student_id    if defined $user->student_id;
  168   $hash{stst} = $user->status        if defined $user->status;
  169   $hash{clsn} = $user->section       if defined $user->section;
  170   $hash{clrc} = $user->recitation    if defined $user->recitation;
  171   $hash{comt} = $user->comment       if defined $user->comment;
  172   return %hash;
  173 }
  174 
  175 1;