[system] / trunk / webwork2 / lib / WeBWorK / DB / Classlist.pm Repository:
ViewVC logotype

Annotation of /trunk/webwork2/lib/WeBWorK/DB/Classlist.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 359 - (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 :     # 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 : sh002i 359 my $user = WeBWorK::User->new(id => $userID);
150 : sh002i 358 $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;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9