Parent Directory
| 
Revision Log
Revision 360 - (view) (download) (as text)
| 1 : | sh002i | 358 | ################################################################################ |
| 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 : | sh002i | 359 | use WeBWorK::User; |
| 11 : | sh002i | 358 | |
| 12 : | # there should be a `use' line for each database type | ||
| 13 : | use WeBWorK::DB::GDBM; | ||
| 14 : | |||
| 15 : | sh002i | 360 | # new($courseEnv) |
| 16 : | # $courseEnv - an instance of CourseEnvironment | ||
| 17 : | sh002i | 358 | 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 : | sh002i | 360 | # getUsers() - returns a list of user IDs present in the database |
| 40 : | sh002i | 358 | 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 : | sh002i | 360 | # 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 : | sh002i | 358 | 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 : | sh002i | 360 | # 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 : | sh002i | 358 | 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 : | sh002i | 360 | return unless $self->{classlist_db}->connect("rw"); |
| 81 : | sh002i | 358 | $self->{classlist_db}->hashRef->{$user->id} = encode(user2hash($user)); |
| 82 : | $self->{classlist_db}->disconnect; | ||
| 83 : | sh002i | 360 | return 1; |
| 84 : | sh002i | 358 | } |
| 85 : | |||
| 86 : | sh002i | 360 | # 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 : | sh002i | 358 | 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 : | sh002i | 360 | return 1; |
| 101 : | sh002i | 358 | } |
| 102 : | |||
| 103 : | # ----- | ||
| 104 : | |||
| 105 : | sh002i | 360 | # lock() - locks the database associated with this classlist object. when |
| 106 : | # a database is locked, it cannot be modified except to unlock it. | ||
| 107 : | sh002i | 358 | 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 : | sh002i | 360 | return 1; |
| 113 : | sh002i | 358 | } |
| 114 : | |||
| 115 : | sh002i | 360 | # unlock() - unlocks the database associated with this classlist object. |
| 116 : | sh002i | 358 | sub unlock($) { |
| 117 : | my $self = shift; | ||
| 118 : | return unless $self->{classlist_db}->connect("rw"); | ||
| 119 : | sh002i | 360 | # the old code sets this to "unlocked", but I going to delete it instead |
| 120 : | sh002i | 358 | delete $self->{classlist_db}->hashRef->{">>lock_status"}; |
| 121 : | $self->{classlist_db}->disconnect; | ||
| 122 : | sh002i | 360 | return 1; |
| 123 : | sh002i | 358 | } |
| 124 : | |||
| 125 : | sh002i | 360 | # locked() - returns true if the database is locked, false if it is not. |
| 126 : | sh002i | 358 | 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 : | sh002i | 359 | my $user = WeBWorK::User->new(id => $userID); |
| 168 : | sh002i | 358 | $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; |
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |