"Fossies" - the Fresh Open Source Software Archive

Member "absence-v2.1/cgi-bin/old/AbsenceFlatFileDB.pm" (21 Aug 2008, 40335 Bytes) of package /linux/www/web-absence-2.1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "AbsenceFlatFileDB.pm" see the Fossies "Dox" file reference documentation.

    1 #----------------------------------------------------------------------
    2 # AbsenceDB - interface to 'database'
    3 #----------------------------------------------------------------------
    4 
    5 package AbsenceDB;
    6 
    7 use FileHandle;
    8 use Fcntl ':flock'; # import LOCK_* constants
    9 use Carp;
   10 use Digest::MD5 qw(md5_base64);
   11 
   12 use AbsenceConfig;
   13 use AbsenceDate;
   14 use AbsenceLog;
   15 
   16 #----------------------------------------------------------------------
   17 # initialization
   18 #----------------------------------------------------------------------
   19 
   20 my $DB_PATH         = AbsenceConfig::fetch('database_path');
   21 my $MODTIME_FILE    = AbsenceConfig::fetch('modtime_db_file');
   22 my $OAP             = AbsenceConfig::fetch('objects_are_people');
   23 my $AUTH            = AbsenceConfig::fetch('authentication');
   24 my $CRED_SRC        = AbsenceConfig::fetch('credential_src');
   25 my $PW_HASH_FORMAT  = AbsenceConfig::fetch('pw_hash_format');
   26 
   27 my %PERSON_KEYS = (
   28     name        => '',
   29     id          => '',
   30     user_id     => '',
   31     email       => '',
   32     group       => '',      # reference to list of GIDs
   33 );
   34 my @RES_KEYS        = qw(id person_id start end type desc misc);
   35 my %RESERVATION_KEYS = (
   36     id          => '',      # unique number
   37     person_id   => '',      # unique number
   38     start       => '',      # date. array-ref in form [d,m,y]
   39     end         => '',      # date. array-ref in form [d,m,y]
   40     type        => '',      # single word "vacation", "busy", "travel"
   41     desc        => '',      # arbitrary text
   42     misc        => '',      # more arbitrary text
   43 );
   44 my %GROUP_KEYS = (
   45     id          => '',
   46     name        => '',
   47     pass        => '',
   48 );
   49 my %USER_KEYS = (
   50     user_id     => '',
   51     password    => '',
   52     pacl        => '',
   53     gacl        => '',
   54 );
   55 my %PEOPLE          = ();
   56 my %USERS           = ();
   57 my %RESERVATIONS    = ();
   58 my %GROUPS          = ();
   59 my $GROUP_COUNT     = 0;
   60 my $FH              = '';
   61 my $INIT_RUN        = 0;
   62 my $DEBUG           = 0;
   63 my $MT_LOADED       = 0;
   64 my $VERSION         = '1.5';
   65 
   66 #----------------------------------------------------------------------
   67 # methods
   68 #----------------------------------------------------------------------
   69 
   70 # returns an array of person_ids sorted by name
   71 sub getPeople
   72 {
   73     my $group_id = shift;
   74 
   75     my @out;
   76 
   77     if (!$INIT_RUN) { init(); }
   78 
   79     if ($group_id == 0) {
   80         return sort {$PEOPLE{$a}->{name} cmp $PEOPLE{$b}->{name}} keys(%PEOPLE);
   81     }
   82 
   83     if (!exists($GROUPS{$group_id})) {
   84         die "getPeople: gid [$group_id] does not exist";
   85     }
   86 
   87     foreach my $pid (keys(%PEOPLE)) {
   88         #if ($PEOPLE{$pid}->{group} == $group_id) {
   89         if (inListN($group_id, $PEOPLE{$pid}->{group})) {
   90             push(@out, $pid);
   91         }
   92     }
   93 
   94     #@out = sort {$PEOPLE{$a}->{name} cmp $PEOPLE{$b}->{name}} keys(%PEOPLE);
   95 
   96     return sort {$PEOPLE{$a}->{name} cmp $PEOPLE{$b}->{name}} @out;
   97 }
   98 
   99 sub groupExists
  100 {
  101     my $gid = shift;
  102 
  103     if (!$INIT_RUN) { init(); }
  104 
  105     exists($GROUPS{$gid}) && return 1;
  106 
  107     return 0;
  108 }
  109 
  110 sub inListN
  111 {
  112     my ($thing, $lref) = @_;
  113 
  114     foreach my $elem (@{$lref}) {
  115         ($elem == $thing) && return 1;
  116     }
  117 
  118     return 0;
  119 }
  120 
  121 sub getPerson
  122 {
  123     my ($pid, $field) = @_;
  124 
  125     if (!$INIT_RUN) { init(); }
  126 
  127     if (!exists($PEOPLE{$pid})) {
  128         #print "no person with ID=[$pid]\n";
  129         return undef;
  130     }
  131     
  132     if ($field) {
  133         return (exists($PEOPLE{$pid}->{$field})) ? $PEOPLE{$pid}->{$field} : undef;
  134     }
  135 
  136     return $PEOPLE{$pid};
  137 }
  138 
  139 sub getPidForUser
  140 {
  141     my $user = shift;
  142 
  143     exists($USERS{$user}) || confess "user [$user] unknown";
  144 
  145     foreach my $pid (keys(%PEOPLE)) {
  146         if ($PEOPLE{$pid}->{user_id} eq $user) {
  147             return $pid;
  148         }
  149     }
  150 
  151     return undef;
  152 }
  153 
  154 sub getReservations
  155 {
  156     my $person_id = shift;
  157 
  158     if (!$INIT_RUN) { init(); }
  159     my @out;
  160 
  161     $DEBUG && abslog("getReservations for id=[$person_id]");
  162 
  163     foreach my $res_id (keys(%RESERVATIONS)) {
  164         $DEBUG && abslog("  res_id = [$res_id]");
  165         if ($person_id == $RESERVATIONS{$res_id}->{person_id}) {
  166             $DEBUG && abslog("  saving...");
  167             push(@out, $res_id);
  168         }
  169     }
  170 
  171     @out;
  172 }
  173 
  174 sub getMonthReservations
  175 {
  176     my ($person_id, $month, $year) = @_;
  177 
  178     if (!$INIT_RUN) { init(); }
  179     my @out;
  180 
  181     #$DEBUG && abslog("getMonthReservations: p_id = $person_id, m=$month, y=$year");
  182     foreach my $res_id (keys(%RESERVATIONS)) {
  183         if ($person_id != $RESERVATIONS{$res_id}->{person_id}) { next; }
  184         my ($id, $sd, $sm, $sy, $ed, $em, $ey, $desc);
  185         my $s = $RESERVATIONS{$res_id}->{start};
  186         my $e = $RESERVATIONS{$res_id}->{end};
  187         ($sd, $sm, $sy) = @$s;
  188         ($ed, $em, $ey) = @$e;
  189         my $bot = $sm + ($sy - 2000) * 12;
  190         my $top = $em + ($ey - 2000) * 12;
  191 
  192         my $this = $month + ($year - 2000) * 12;
  193         if (($this >= $bot) && ($this <= $top)) {
  194             $s = (($sm == $month) && ($sy == $year)) ? $sd : 1;
  195             $e = (($em == $month) && ($ey == $year))
  196                 ? $ed
  197                 : AbsenceDate::daysInMonth($month, $year);
  198             push(@out, [
  199                 #$RESERVATIONS{$res_id}->{id},
  200                 $res_id,
  201                 $s, $e,
  202                 $RESERVATIONS{$res_id}->{type},
  203                 $RESERVATIONS{$res_id}->{desc},
  204             ]);
  205         }
  206     }
  207 
  208     @out;
  209 }
  210 
  211 sub _getMonthReservations
  212 {
  213     my ($person_id, $month, $year) = @_;
  214 
  215     if (!$INIT_RUN) { init(); }
  216     my @out;
  217 
  218     $DEBUG && abslog("getMonthReservations: p_id = $person_id, m=$month, y=$year");
  219     foreach my $res (keys(%RESERVATIONS)) {
  220         if ($person_id != $RESERVATIONS{$res}->{person_id}) { next; }
  221         #my ($id, $sd, $sm, $sy, $ed, $em, $ey, $desc) = @$absence;
  222         my ($id, $sd, $sm, $sy, $ed, $em, $ey, $desc);
  223         my $s = $RESERVATIONS{$res}->{start};
  224         my $e = $RESERVATIONS{$res}->{end};
  225         #($sd, $sm, $sy) = split(/\./, $s);
  226         #($ed, $em, $ey) = split(/\./, $e);
  227         ($sd, $sm, $sy) = @$s;
  228         ($ed, $em, $ey) = @$e;
  229         if (($sm == $month) && ($sy == $year)) {
  230             # if absence starts in month and question...
  231             if ($em == $month) {
  232                 # ... and also end in same month
  233                 push(@out, [$RESERVATIONS{$res}->{id}, $sd, $ed, $RESERVATIONS{$res}->{type}, $RESERVATIONS{$res}->{desc}]);
  234             } else {
  235                 # ... or ends in some other month
  236                 push(@out, [$RESERVATIONS{$res}->{id}, $sd, AbsenceDate::daysInMonth($month), $RESERVATIONS{$res}->{type}, $RESERVATIONS{$res}->{desc}]);
  237             }
  238         } elsif (($em == $month) && ($ey == $year)) {
  239             # if absence starts in previous month but ends in current month
  240                 push(@out, [$RESERVATIONS{$res}->{id}, 1, $ed, $RESERVATIONS{$res}->{type}, $RESERVATIONS{$res}->{desc}]);
  241         }
  242     }
  243 
  244     @out;
  245 }
  246 
  247 sub getReservation
  248 {
  249     my $rid = shift;
  250 
  251     if (!$INIT_RUN) { init(); }
  252     if (!exists($RESERVATIONS{$rid})) {
  253         #print "no reservation with ID=[$rid]\n";
  254         return undef;
  255     }
  256     return $RESERVATIONS{$rid};
  257 }
  258 
  259 sub nextPersonId
  260 {
  261     #if (!$INIT_RUN) { init(); }
  262     my $highest = 0;
  263     foreach my $pid (keys(%PEOPLE)) {
  264         if ($pid > $highest) {
  265             $highest = $pid;
  266         }
  267     }
  268 
  269     ++$highest;
  270 }
  271 
  272 sub nextGroupId
  273 {
  274     #if (!$INIT_RUN) { init(); }
  275     my $highest = 0;
  276     foreach my $id (keys(%GROUPS)) {
  277         if ($id > $highest) {
  278             $highest = $id;
  279         }
  280     }
  281 
  282     ++$highest;
  283 }
  284 
  285 sub nextReservationId
  286 {
  287     my $highest = 0;
  288     foreach my $id (keys(%RESERVATIONS)) {
  289         if ($id > $highest) {
  290             $highest = $id;
  291         }
  292     }
  293 
  294     ++$highest;
  295 }
  296 
  297 #--------------------------------------------------------------------
  298 # group stuff
  299 #--------------------------------------------------------------------
  300 
  301 sub addGroup
  302 {
  303     my ($gid, $name, $pass) = @_;
  304 
  305     $INIT_RUN = 1;  # hack
  306 
  307     $DEBUG && abslog("addGroup: start: name=[$name], pass=[$pass]");
  308 
  309     openFile();
  310     lockFile();
  311     readFile();
  312 
  313     my $group_id;
  314     my $verb;
  315 
  316     if ($gid eq 'new') {
  317         foreach my $group (getGroups()) {
  318             if ($name eq $GROUPS{$group}->{name}) {
  319                 unlockFile();
  320                 closeFile();
  321                 abslog("addGroup: dup, bailing.");
  322                 return 'duplicate';
  323             }
  324         }
  325         $group_id = nextGroupId();
  326         $verb = 'add-group';
  327     } else {
  328         $group_id = $gid;
  329         if (!exists($GROUPS{$group_id})) {
  330             #die "error: attempt to modify non-existent group [$group_id]";
  331             abslog("error: attempt to modify non-existent group [$group_id]");
  332             return undef;
  333         }
  334         $verb = 'modify-group';
  335     }
  336 
  337     $GROUPS{$group_id} = {
  338         id      => $group_id,
  339         name    => $name,
  340         pass    => $pass,
  341     };
  342     writeFile();
  343     unlockFile();
  344     closeFile();
  345 
  346     $DEBUG && abslog("addGroup: group-id = [$group_id].");
  347     abslog("$verb: name=[$name], gid=[$group_id]");
  348 
  349     return 'ok';
  350 }
  351 
  352 sub deleteGroup
  353 {
  354     my $group_id = shift;
  355 
  356     $INIT_RUN = 1;  # hack
  357 
  358     $DEBUG && abslog("deleteGroup: start: gid=[$group_id]");
  359 
  360     openFile();
  361     lockFile();
  362     readFile();
  363 
  364     if (!exists($GROUPS{$group_id})) {
  365         abslog("deleteGroup: gid [$group_id] does not exist");
  366         unlockFile();
  367         closeFile();
  368         return undef;
  369     }
  370 
  371     # first, check if members need to be deleted or modified
  372     foreach my $pid (keys(%PEOPLE)) {
  373         #if ($PEOPLE{$pid}->{group} == $group_id) {
  374         if (inListN($group_id, $PEOPLE{$pid}->{group})) {
  375             if (personOnlyInThisGroup($pid, $group_id)) {
  376                 #delete($PEOPLE{$pid});
  377                 _deletePerson($pid);
  378             } else {
  379                 deleteElementN($group_id, $PEOPLE{$pid}->{group});
  380             }
  381         }
  382     }
  383 
  384     # save name for logging
  385     my $name = $GROUPS{$group_id}->{name};
  386 
  387     # now get rid of the group
  388     delete($GROUPS{$group_id});
  389     
  390     $AUTH && deleteGidInAcls($group_id);
  391 
  392     writeFile();
  393     unlockFile();
  394     closeFile();
  395 
  396     abslog("deleteGroup: gid=[$group_id], name=[$name]");
  397 
  398     return 'ok';
  399 }
  400 
  401 sub deleteGidInAcls
  402 {
  403     my $gid = shift;
  404 
  405     foreach my $uid (keys(%USERS)) {
  406         my $ref = [];
  407         foreach my $rule (@{$USERS{$uid}->{gacl}}) {
  408             my ($grp) = ($rule =~ /^[war]:(.*)$/);
  409             if ($grp != $gid) {
  410                 push(@{$ref}, $rule);
  411             } else {
  412                 $DEBUG && abslog("deleteGidInAcls: del: uid=$uid, rule=[$rule]");
  413             }
  414         }
  415         $USERS{$uid}->{gacl} = $ref;
  416         undef($ref);
  417     }
  418 }
  419 
  420 sub deletePidInAcls
  421 {
  422     my $pid = shift;
  423 
  424     foreach my $uid (keys(%USERS)) {
  425         my $ref = [];
  426         foreach my $rule (@{$USERS{$uid}->{pacl}}) {
  427             my ($p) = ($rule =~ /^w:(.*)$/);
  428             if ($p != $pid) {
  429                 push(@{$ref}, $rule);
  430             } else {
  431                 $DEBUG && abslog("deletePidInAcls: del: uid=$uid, rule=[$rule]");
  432             }
  433         }
  434         $USERS{$uid}->{pacl} = $ref;
  435         undef($ref);
  436     }
  437 }
  438 
  439 sub deleteElementN
  440 {
  441     my($elem, $lref) = @_;
  442 
  443     my $count = 0;
  444     my $match = 0;
  445     foreach my $tmp (@{$lref}) {
  446         if ($tmp == $elem) {
  447             $match = 1;
  448             last;
  449         }
  450         $count++;
  451     }
  452 
  453     if ($match) {
  454         splice(@{$lref}, $count, 1);
  455     }
  456 }
  457 
  458 sub personOnlyInThisGroup
  459 {
  460     my ($pid, $gid) = @_;
  461 
  462     my @new;
  463     my $only_this = 1;
  464 
  465     foreach my $grp (@{$PEOPLE{$pid}->{group}}) {
  466         ($grp == $gid) && next;
  467         $only_this = 0;
  468     }
  469 
  470     $only_this;
  471 }
  472 
  473 sub getGroups
  474 {
  475     if (!$INIT_RUN) { init(); }
  476 
  477     return (keys(%GROUPS));
  478 
  479     #my @out;
  480     #foreach my $group_id (keys(%GROUPS)) {
  481     #   push(@out, $group_id);
  482     #}
  483     #
  484     #@out;
  485 }
  486 
  487 sub getGroup
  488 {
  489     my ($gid, $field) = @_;
  490     
  491     if (!$INIT_RUN) { init(); }
  492 
  493     if (!exists($GROUPS{$gid})) {
  494         #print "no group with ID=[$gid]\n";
  495         return undef;
  496     }
  497     
  498     if ($field) {
  499         return (exists($GROUPS{$gid}->{$field})) ? $GROUPS{$gid}->{$field} : undef;
  500     }
  501 
  502     return $GROUPS{$gid};
  503 
  504     #return wantarray
  505     #   ? ($GROUPS{$gid}->{name}, $GROUPS{$gid}->{pass})
  506     #   : $GROUPS{$gid}->{name};
  507 }
  508 
  509 sub getGroup_defunct
  510 {
  511     my $pid = shift;
  512 
  513     if (!$INIT_RUN) { init(); }
  514 
  515     exists($PEOPLE{$pid}) || die "getGroup: pid=[$pid] does not exist";
  516 
  517     return $PEOPLE{$pid}->{group};
  518 }
  519 
  520 sub groupCount
  521 {
  522     $GROUP_COUNT;
  523 }
  524 
  525 #--------------------------------------------------------------------
  526 # user stuff
  527 #--------------------------------------------------------------------
  528 
  529 sub getUser
  530 {
  531     my ($uid, $field) = @_;
  532 
  533     if (!$INIT_RUN) { init(); }
  534 
  535     if (!exists($USERS{$uid})) {
  536         #print "no user with ID=[$uid]\n";
  537         return undef;
  538     }
  539     
  540     if ($field) {
  541         return (exists($USERS{$uid}->{$field})) ? $USERS{$uid}->{$field} : undef;
  542     }
  543 
  544     return $USERS{$uid};
  545 }
  546 
  547 sub getUsers
  548 {
  549     my $all = shift;
  550 
  551     if (!$INIT_RUN) { init(); }
  552 
  553     ($all eq 'all') && return (keys(%USERS));
  554 
  555     #-------------------------------------------------------
  556     # first make list of all uids associated with people
  557     #-------------------------------------------------------
  558     my %people_uids;
  559     foreach my $pid (keys(%PEOPLE)) {
  560         my $uid = $PEOPLE{$pid}->{user_id};
  561         if (length($uid)) {
  562             $people_uids{$uid} = 1;
  563         }
  564     }
  565 
  566     my @out;
  567     foreach my $uid (keys(%USERS)) {
  568         if (!exists($people_uids{$uid})) {
  569             push(@out, $uid);
  570         }
  571     }
  572 
  573     @out;
  574 }
  575 
  576 sub setPassword
  577 {
  578     my ($uid, $password) = @_;
  579 
  580     $INIT_RUN = 1;  # hack
  581 
  582     $DEBUG && abslog(["changePassword: start: user_id=[$uid]",
  583         "password=[$password]"]);
  584 
  585     openFile();
  586     lockFile();
  587     readFile();
  588 
  589     if (!exists($USERS{$uid})) {
  590         unlockFile();
  591         closeFile();
  592         return 'disappeared';
  593     }
  594 
  595     my $new_pw = ($PW_HASH_FORMAT eq 'md5')
  596         ? md5_base64($password)
  597         : $password;
  598 
  599     if ($CRED_SRC eq 'absence') {
  600         $USERS{$uid}->{password} = $new_pw;
  601     } elsif ($CRED_SRC eq 'htaccess') {
  602         # TODO
  603         my $ret = setHtaccessPassword($uid, $password);
  604         unlockFile();
  605         closeFile();
  606         if ($ret) { return 'error'; }
  607         return 'ok';
  608     } else {
  609         die "unimplemented method [$CRED_SRC]";
  610     }
  611 
  612     writeFile();
  613     unlockFile();
  614     closeFile();
  615 
  616     return 'ok';
  617 }
  618 
  619 #--------------------------------------------------------------------
  620 # setHtaccessPassword() is an EXAMPLE of how you could
  621 # implement password management for HTTP authentication.
  622 # Unless you're using SSL, using this method means you
  623 # will be sending cleartext passwords over the network.
  624 # If you do not want to use absence to manage your passwords
  625 # (for example if you are using HTTP Digest authentication
  626 # in order to avoid sending cleartext passwords over the
  627 # network) then you should set "manage_password" in the
  628 # configuration to "no".  You will need to come up with
  629 # your own method of managing passwords.
  630 #--------------------------------------------------------------------
  631 sub setHtaccessPassword
  632 {
  633     my ($uid, $password) = @_;
  634 
  635     my $htaccess = AbsenceConfig::fetch('htaccess_path');
  636     my $cmd = "cd /tmp; htpasswd -b $htaccess $uid $password";
  637     #dbg("running cmd: $cmd");
  638     my $out = `$cmd 2>&1`;
  639     my $status = $?;
  640     chomp($out);
  641     #dbg("output: [$out]");
  642 
  643     #$out;
  644     return $status;
  645 }
  646 
  647 sub modifyUser
  648 {
  649     my ($uid, $password, $pacl, $gacl) = @_;
  650 
  651     $INIT_RUN = 1;  # hack
  652     $DEBUG && abslog(["modifyUser: start: user_id=[$uid]",
  653         "password=[$password]",
  654         "pacl=[$pacl]", "gacl=[$gacl]"]);
  655 
  656     openFile();
  657     lockFile();
  658     readFile();
  659 
  660     if (!exists($USERS{$uid})) {
  661         unlockFile();
  662         closeFile();
  663         return 'disappeared';
  664     }
  665     my $old_pw = $USERS{$uid}->{password};
  666     my $new_pw = (($old_pw ne $password) && ($PW_HASH_FORMAT eq 'md5'))
  667         ? md5_base64($password)
  668         : $password;
  669 
  670     if ($CRED_SRC eq 'absence') {
  671         $USERS{$uid} = {
  672             user_id     => $uid,
  673             password    => $new_pw,
  674             pacl        => $pacl,
  675             gacl        => $gacl,
  676         };
  677     } elsif ($CRED_SRC eq 'htaccess') {
  678         $USERS{$uid} = {
  679             user_id     => $uid,
  680             pacl        => $pacl,
  681             gacl        => $gacl,
  682         };
  683         # modify user in some ".htpasswd" file
  684         my $out = setHtaccessPassword($uid, $password);
  685     } else {
  686         die "unimplemented method [$CRED_SRC]";
  687     }
  688 
  689     writeFile();
  690     unlockFile();
  691     closeFile();
  692 
  693     return 'ok';
  694 }
  695 
  696 sub addUser
  697 {
  698     my ($uid, $password, $pacl, $gacl) = @_;
  699 
  700     $INIT_RUN = 1;  # hack
  701     $DEBUG && abslog(["addUser: start: user_id=[$uid]",
  702         "password=[$password]",
  703         "pacl=[$pacl]", "gacl=[$gacl]"]);
  704 
  705     openFile();
  706     lockFile();
  707     readFile();
  708 
  709     if (exists($USERS{$uid})) {
  710         unlockFile();
  711         closeFile();
  712         return 'duplicate';
  713     }
  714 
  715     _addUser($uid, $password, $pacl, $gacl);
  716 
  717     writeFile();
  718     unlockFile();
  719     closeFile();
  720 
  721     abslog([
  722         "add-user: uid=[$uid]",
  723         "password=[$password]",
  724         'pacl=['.join(',',@{$pacl}).']',
  725         'gacl=['.join(',',@{$gacl}).']',
  726     ]);
  727 
  728     return 'ok';
  729 }
  730 
  731 sub _addUser
  732 {
  733     my ($uid, $password, $pacl, $gacl) = @_;
  734 
  735     if ($CRED_SRC eq 'absence') {
  736         my $pw = ($PW_HASH_FORMAT eq 'md5')
  737             ? md5_base64($password)
  738             : $password;
  739         $USERS{$uid} = {
  740             user_id     => $uid,
  741             password    => $pw,
  742             pacl        => $pacl,
  743             gacl        => $gacl,
  744         };
  745     } elsif ($CRED_SRC eq 'htaccess') {
  746         $USERS{$uid} = {
  747             user_id     => $uid,
  748             pacl        => $pacl,
  749             gacl        => $gacl,
  750         };
  751         my $ret = setHtaccessPassword($uid, $password);
  752         $ret && die "error while setting htaccess pw: $ret";
  753     } else {
  754         die "unimplemented method [$CRED_SRC]";
  755     }
  756 }
  757 
  758 sub deleteUser
  759 {
  760     my $uid = shift;
  761 
  762     $INIT_RUN = 1;  # hack
  763     $DEBUG && abslog("delete-user: user_id=[$uid]");
  764 
  765     openFile();
  766     lockFile();
  767     readFile();
  768 
  769     _deleteUser($uid);
  770 
  771     writeFile();
  772     unlockFile();
  773     closeFile();
  774     return 'ok';
  775 }
  776 
  777 sub _deleteUser
  778 {
  779     my $uid = shift;
  780     delete($USERS{$uid});
  781 }
  782 
  783 sub getAcl
  784 {
  785     my $user = shift;
  786     
  787     if (!$INIT_RUN) { init(); }
  788 
  789     #exists($USERS{$user}) || confess "getAcl(): user [$user] unknown";
  790     exists($USERS{$user}) || return undef;
  791 
  792     my $ref;
  793     $ref->{p} = $USERS{$user}->{pacl};
  794     $ref->{g} = $USERS{$user}->{gacl};
  795 
  796     $ref;
  797 }
  798 
  799 #--------------------------------------------------------------------
  800 # person stuff
  801 #--------------------------------------------------------------------
  802 sub addPerson
  803 {
  804     my ($pid, $name, $user_id, $email, $gref, $pw, $pacl, $gacl) = @_;
  805 
  806     $INIT_RUN = 1;  # hack
  807 
  808     $DEBUG && abslog(["addPerson: start: pid=[$pid], name=[$name]",
  809         "user_id=[$user_id]",
  810         "email=[$email]", "groups=[@{$gref}]"]);
  811 
  812     openFile();
  813     lockFile();
  814     readFile();
  815 
  816     my $person_id;
  817     my $verb;
  818     my $old_pw;
  819 
  820     if ($pid eq 'new') {
  821         foreach my $pid (getPeople()) {
  822             if ($name eq $PEOPLE{$pid}->{name}) {
  823                 unlockFile();
  824                 closeFile();
  825                 return 'duplicate-name';
  826             }
  827             if ($AUTH) {
  828                 if ($OAP && ($user_id eq $PEOPLE{$pid}->{user_id})) {
  829                     unlockFile();
  830                     closeFile();
  831                     return 'duplicate-uid';
  832                 }
  833             }
  834         }
  835         $person_id = nextPersonId();
  836         $verb = 'add-person';
  837     } else {
  838         $person_id = $pid;
  839         if (!exists($PEOPLE{$person_id})) {
  840             die "error: attempt to modify a non-existent person [$person_id]";
  841         }
  842         $verb = 'modify-person';
  843 
  844         if ($OAP && $AUTH) {
  845             my $old_id = $PEOPLE{$pid}->{user_id};
  846             if ($user_id ne $old_id) {
  847                 if (exists($USERS{$user_id})) {
  848                     unlockFile();
  849                     closeFile();
  850                     return 'duplicate-uid';
  851                 }
  852                 $old_pw = $USERS{$old_id}->{password};
  853                 delete($USERS{$old_id});
  854             }
  855         }
  856     }
  857 
  858     $PEOPLE{$person_id} = {
  859         id      => $person_id,
  860         name    => $name,
  861         user_id => $user_id,
  862         email   => $email,
  863         group   => $gref,
  864     };
  865 
  866     ($OAP && $AUTH) && _addUser($user_id, $pw, $pacl, $gacl);
  867 
  868     writeFile();
  869     unlockFile();
  870     closeFile();
  871 
  872     abslog(["$verb: pid=[$person_id]", "name=[$name]", "user_id=[$user_id]",
  873         "email=[$email]", "groups = [@{$gref}]"]);
  874 
  875     return 'ok';
  876 }
  877 
  878 sub deletePerson
  879 {
  880     my $pid = shift;
  881 
  882     #abslog("deletePerson: deleting id=[$pid]");
  883 
  884     openFile();
  885     lockFile();
  886     readFile();
  887 
  888     if (!exists($PEOPLE{$pid})) {
  889         abslog("deletePerson: id=[$pid] not found");
  890         unlockFile();
  891         closeFile();
  892         return 'bad-id';
  893     }
  894 
  895     _deletePerson($pid);
  896 
  897     $AUTH && deletePidInAcls($pid);
  898 
  899     writeFile();
  900     unlockFile();
  901     closeFile();
  902 
  903     return 'ok';
  904 }
  905 
  906 #----------------------------------------------------------------------
  907 # this is the internal version.  It *MUST* be called after the
  908 # DB-file has been locked.
  909 #----------------------------------------------------------------------
  910 sub _deletePerson
  911 {
  912     my $pid = shift;
  913 
  914     # remove all reservations of this person
  915     foreach my $res_id (keys(%RESERVATIONS)) {
  916         if ($RESERVATIONS{$res_id}->{person_id} == $pid) {
  917             abslog("_deletePerson: deleting res=[$res_id]");
  918             delete($RESERVATIONS{$res_id});
  919         }
  920     }
  921 
  922     abslog("deleting person: pid=[$pid], name=[$PEOPLE{$pid}->{name}]");
  923     if ($OAP && $AUTH) {
  924         my $user_id = $PEOPLE{$pid}->{user_id};
  925         _deleteUser($user_id);
  926     }
  927     delete($PEOPLE{$pid});
  928 }
  929 
  930 #----------------------------------------------------------------------
  931 # addReservation()
  932 #
  933 # adds or modifies a reservation for a person.
  934 # $start and $end are dates in the form dd.mm.yyyy
  935 #----------------------------------------------------------------------
  936 
  937 sub addReservation
  938 {
  939     my ($res_id, $person_id, $start, $end, $type, $desc) = @_;
  940 
  941     my $s = [split(/\./, $start)];
  942     my $e = [split(/\./, $end)];
  943 
  944     $DEBUG && abslog("addReservation: rid=$res_id, pid=$person_id, start=$start, end=$end, type=$type, desc=[$desc]");
  945 
  946     $INIT_RUN = 1;  # hack
  947     openFile();
  948     lockFile();
  949     readFile();
  950 
  951     my $new = 0;
  952     my $verb;
  953 
  954     if ($res_id eq 'new') {
  955         $new = 1;
  956         $res_id = nextReservationId();
  957         $DEBUG && abslog("addReservation: new res-id=[$res_id]");
  958         $verb = 'add-reservation';
  959     } else {
  960         if (!exists($RESERVATIONS{$res_id})) {
  961             #die "error: attempt to modify non-existent reservation [$res_id]";
  962             abslog("error: attempt to modify non-existent reservation [$res_id]");
  963             unlockFile();
  964             closeFile();
  965             return ('disappeared');
  966         }
  967         # a reservation is being modified, I need the old start/end dates
  968         $old_s = $RESERVATIONS{$res_id}->{start};
  969         $old_e = $RESERVATIONS{$res_id}->{end};
  970         $verb = 'modify-reservation';
  971     }
  972 
  973     if (($s->[0] > AbsenceDate::daysInMonth($s->[1])) ||
  974         ($e->[0] > AbsenceDate::daysInMonth($e->[1])))
  975     {
  976         unlockFile();
  977         closeFile();
  978         return ('badday');
  979     }
  980 
  981     my $sjd = AbsenceDate::julianDay(@$s);
  982     my $ejd = AbsenceDate::julianDay(@$e);
  983     if ($sjd > $ejd) {
  984         #abslog("addReservation: impossible");
  985         unlockFile();
  986         closeFile();
  987         return ('impossible');
  988     }
  989 
  990     my $ret = resConflict($res_id, $person_id, $s, $e);
  991 
  992     if (defined($ret)) {
  993         #abslog("addReservation: conflict");
  994         unlockFile();
  995         closeFile();
  996         return ('conflict', $ret);
  997     }
  998 
  999     abslog(
 1000         [
 1001             "$verb: res=[$res_id]",
 1002             "person-id = [$person_id]",
 1003             "start = [$start]",
 1004             "end = [$end]",
 1005             "type = [$type]",
 1006             "desc = [$desc]",
 1007         ]
 1008     );
 1009 
 1010     _addReservation($res_id, $person_id, $s, $e, $type, $desc);
 1011 
 1012     my $gref = getPerson($person_id, 'group');
 1013 
 1014     if (!$new) {
 1015         updateModificationTimes($gref, $old_s, $old_e);
 1016     }
 1017     updateModificationTimes($gref, $s, $e);
 1018 
 1019     $DEBUG && abslog("addReservation: success");
 1020     writeFile();
 1021     unlockFile();
 1022     closeFile();
 1023 
 1024     return ('ok');
 1025 }
 1026 
 1027 #----------------------------------------------------------------------
 1028 # updateModificationTimes()
 1029 #
 1030 # parameters:
 1031 #   $s, $e references to dates in the form:
 1032 #       [<day>, <month>, <year>]
 1033 #----------------------------------------------------------------------
 1034 
 1035 sub updateModificationTimes
 1036 {
 1037     # ROBBO TODO
 1038 
 1039     my ($gref, $s, $e) = @_;
 1040 
 1041     if ($DEBUG) {
 1042         my $tmp = join(',', @{$gref});
 1043         my $start = "$s->[0]/$s->[1]/$s->[2]";
 1044         my $end = "$e->[0]/$e->[1]/$e->[2]";
 1045         abslog("updateModificationTimes: grps: [$tmp], s: [$start], e: [$end]");
 1046     }
 1047 
 1048     #my $openstr = (-e $MODTIME_FILE) ? "+<$MODTIME_FILE" : ">$MODTIME_FILE";
 1049     #my $fh = FileHandle->new($openstr);
 1050     #defined($fh) || die "open on $MODTIME_FILE failed";
 1051 
 1052     my $fh = openMmtFile();
 1053 
 1054     # first read values
 1055     readModificationTimes($fh);
 1056 
 1057     # modify in-memory hash
 1058     my $month = $s->[1];
 1059     my $year = $s->[2];
 1060 
 1061     my $end = $e->[2] * 12 + $e->[1];
 1062 
 1063     while(($year*12+$month) <= $end) {
 1064         $DEBUG && abslog("updModTime: updating y=$year, m=$month");
 1065         foreach my $gid (@{$gref}) {
 1066             $MT{$gid}->{$year}->{$month} = time();
 1067         }
 1068         if ($month == 12) {
 1069             $year++;
 1070             $month = 1;
 1071         } else {
 1072             $month++;
 1073         }
 1074     }
 1075     writeMmtFile($fh);
 1076 }
 1077 
 1078 sub openMmtFile
 1079 {
 1080     my $openstr = (-e $MODTIME_FILE) ? "+<$MODTIME_FILE" : ">$MODTIME_FILE";
 1081     my $fh = FileHandle->new($openstr);
 1082     defined($fh) || die "open on $MODTIME_FILE failed";
 1083 
 1084     $fh;
 1085 }
 1086 
 1087 sub writeMmtFile
 1088 {
 1089     my $fh = shift;
 1090 
 1091     # rewind file-pointer
 1092     seek($fh, 0, 0) || die "seek";
 1093     truncate($fh, 0) || die "truncate";
 1094 
 1095     # ... and write new contents
 1096     foreach $gid (keys(%MT)) {
 1097         foreach $year (keys(%{$MT{$gid}})) {
 1098             foreach $month (keys(%{$MT{$gid}->{$year}})) {
 1099                 print $fh "${gid}-$month/$year:$MT{$gid}->{$year}->{$month}\n";
 1100             }
 1101         }
 1102     }
 1103 
 1104     $fh->close;
 1105     $MT_LOADED      = 1;
 1106 }
 1107 
 1108 sub updateMonthModTimes
 1109 {
 1110     my ($gid, $mref) = @_;
 1111 
 1112     # must DB-lock to protect month-mod-time file
 1113     openFile();
 1114     lockFile();
 1115 
 1116     my $fh = openMmtFile();
 1117 
 1118     #my $now = time();
 1119 
 1120     $MT_LOADED || readModificationTimes($fh);
 1121     foreach my $year (keys(%{$mref})) {
 1122         foreach my $month (keys(%{$mref->{$year}})) {
 1123             $MT{$gid}->{$year}->{$month} = $mref->{$year}->{$month};
 1124             $DEBUG && abslog("updating mmt for [$gid-$month/$year]");
 1125         }
 1126     }
 1127 
 1128     writeMmtFile($fh);
 1129 
 1130     unlockFile();
 1131     closeFile();
 1132 }
 1133 
 1134 sub readModificationTimes
 1135 {
 1136     my $fh = shift;
 1137 
 1138     my $do_close = 0;
 1139 
 1140     my $openstr;
 1141 
 1142     $DEBUG && abslog("reading month mod times...");
 1143 
 1144     if (!defined($fh)) {
 1145         if (!-e $MODTIME_FILE) { $MT_LOADED = 1; return; }
 1146         $fh = FileHandle->new("<$MODTIME_FILE");
 1147         defined($fh) || die "open on $MODTIME_FILE failed";
 1148         $do_close = 1;
 1149     }
 1150 
 1151     while(<$fh>) {
 1152         chomp;
 1153         $DEBUG && abslog("MMT> $_");
 1154         if (m!^(\d+)-(\d+)/(\d+):(\d+)$!) {
 1155             my ($gid, $month, $year, $time) = ($1, $2, $3, $4);
 1156             $MT{$gid}->{$year}->{$month} = $time;
 1157         } else {
 1158             abslog("mmt: failed to parse [$_]");
 1159         }
 1160     }
 1161 
 1162     if ($do_close) {
 1163         $fh->close;
 1164     }
 1165     $MT_LOADED      = 1;
 1166 }
 1167 
 1168 sub getModificationTime
 1169 {
 1170     my ($gid, $month, $year) = @_;
 1171 
 1172     $DEBUG && abslog("getModificationTime: lookup: gid=$gid, m=$month, y=$year");
 1173 
 1174     if (!$MT_LOADED) {
 1175         readModificationTimes(undef);
 1176     }
 1177     if (exists($MT{$gid}->{$year}) && exists($MT{$gid}->{$year}->{$month})) {
 1178         $DEBUG && abslog("getModificationTime: returning [$MT{$gid}->{$year}->{$month}]");
 1179         return $MT{$gid}->{$year}->{$month};
 1180     }
 1181 
 1182     $DEBUG && abslog("getModificationTime: returning [undef]");
 1183     return undef;
 1184 }
 1185 
 1186 sub deleteReservation
 1187 {
 1188     my $res_id = shift;
 1189 
 1190     #if (!$INIT_RUN) { init(); }
 1191     $INIT_RUN = 1;  # hack
 1192 
 1193     # check if there is such a reservation
 1194     #if (!exists($RESERVATIONS{$res_id})) {
 1195     #   abslog("deleteReservation: ID not found");
 1196     #   return 'internalerror';
 1197     #}
 1198 
 1199     openFile();
 1200     lockFile();
 1201     readFile();
 1202 
 1203     if (!exists($RESERVATIONS{$res_id})) {
 1204         # someone else got there first
 1205         abslog("deleteReservation: ID [$res_id] disappeared (overlapping ops)");
 1206         unlockFile();
 1207         closeFile();
 1208         return 'conflict';
 1209     }
 1210 
 1211     my ($start, $end) =
 1212         ($RESERVATIONS{$res_id}->{start}, $RESERVATIONS{$res_id}->{end});
 1213 
 1214     my $pid = $RESERVATIONS{$res_id}->{person_id};
 1215     delete($RESERVATIONS{$res_id});
 1216 
 1217     # piggy-back onto DB-lock
 1218     my $gref = getPerson($pid, 'group');
 1219     updateModificationTimes($gref, $start, $end);
 1220 
 1221     writeFile();
 1222     unlockFile();
 1223     closeFile();
 1224 
 1225     abslog("deleteReservation: res-id=[$res_id]");
 1226 
 1227     return 'ok';
 1228 }
 1229 
 1230 sub resConflict
 1231 {
 1232     my ($res_id, $person_id, $start, $end) = @_;
 1233     
 1234     my $sjd = AbsenceDate::julianDay(@$start);
 1235     my $ejd = AbsenceDate::julianDay(@$end);
 1236 
 1237     $DEBUG && abslog("resConflict: sjd = $sjd, ejd = $ejd");
 1238 
 1239     foreach my $rid (getReservations($person_id)) {
 1240         $DEBUG && abslog("loop: [$rid] $RESERVATIONS{$rid}->{sjd}, $RESERVATIONS{$rid}->{ejd}");
 1241         if ($res_id == $rid) { next; }  # avoid checking the same res
 1242         my ($rs,$re) = ($RESERVATIONS{$rid}->{sjd}, $RESERVATIONS{$rid}->{ejd});
 1243 
 1244         if ((($rs >= $sjd) && ($rs <= $ejd)) ||
 1245             (($re >= $sjd) && ($re <= $ejd)))
 1246         {
 1247             return $rid;
 1248         }
 1249     }
 1250 
 1251     return undef;
 1252 }
 1253 
 1254 sub _addReservation
 1255 {
 1256     my ($res_id, $person_id, $start, $end, $type, $desc) = @_;
 1257 
 1258     #my $next_id = nextReservationId();
 1259     $DEBUG && abslog("_addReservation: res_id = [$res_id].");
 1260 
 1261     $RESERVATIONS{$res_id} = {
 1262         id          => $res_id,
 1263         person_id   => $person_id,
 1264         start       => $start,
 1265         end         => $end,
 1266         type        => $type,
 1267         desc        => $desc
 1268     };
 1269 }
 1270 
 1271 sub init
 1272 {
 1273     $DEBUG && abslog("init: read DB");
 1274     openFile();
 1275     readFile();
 1276     closeFile();
 1277 
 1278     $INIT_RUN = 1;
 1279 }
 1280 
 1281 sub openFile
 1282 {
 1283     $DEBUG && abslog("opening DB");
 1284     my $openstr = (-e $DB_PATH) ? "+<$DB_PATH" : ">$DB_PATH";
 1285     $FH = FileHandle->new($openstr);
 1286     defined($FH) || die "open on $DB_PATH failed: $!";
 1287 }
 1288 
 1289 sub closeFile
 1290 {
 1291     $DEBUG && abslog("closing file.");
 1292     $FH->close;
 1293 }
 1294 
 1295 sub unlockFile
 1296 {
 1297     $DEBUG && abslog("unlocking DB");
 1298     flock($FH, LOCK_UN) || die "flock lock_un on $DB_PATH ($!)";
 1299 }
 1300 
 1301 sub lockFile
 1302 {
 1303     $DEBUG && abslog("locking DB");
 1304     flock($FH, LOCK_EX) || die "flock lock_ex on $DB_PATH ($!)";
 1305 }
 1306 
 1307 sub writeFile
 1308 {
 1309     $DEBUG && abslog("seek to beginning of DB");
 1310 
 1311     backupDB();
 1312 
 1313     $DEBUG && abslog("write file.");
 1314     seek($FH, 0, 0) || confess "seek";
 1315     truncate($FH, 0) || croak "truncate";
 1316 
 1317     $DEBUG && abslog("start writing DB");
 1318 
 1319     # write groups first
 1320     print $FH "GROUPS:\n";
 1321     foreach my $group_id (keys(%GROUPS)) {
 1322         print $FH "START\n";
 1323         foreach my $key (keys(%{$GROUPS{$group_id}})) {
 1324             print $FH "\t$key: $GROUPS{$group_id}->{$key}\n";
 1325         }
 1326         print $FH "END\n";
 1327     }
 1328 
 1329     # write users
 1330     # do this even if authentication is not turned on, in case
 1331     # authentication is temporarily turned off.
 1332     print $FH "USERS:\n";
 1333     foreach my $user_id (keys(%USERS)) {
 1334         print $FH "START\n";
 1335         foreach my $key (keys(%{$USERS{$user_id}})) {
 1336             if ($key =~ /acl$/) {
 1337                 print $FH "\t$key: ".join(',',@{$USERS{$user_id}->{$key}})."\n";
 1338             } else {
 1339                 print $FH "\t$key: $USERS{$user_id}->{$key}\n";
 1340             }
 1341         }
 1342         print $FH "END\n";
 1343     }
 1344 
 1345     # write people
 1346     print $FH "PEOPLE:\n";
 1347     foreach my $person_id (keys(%PEOPLE)) {
 1348         print $FH "START\n";
 1349         foreach my $key (keys(%{$PEOPLE{$person_id}})) {
 1350             if ($key eq 'group') {
 1351                 print $FH "\t$key: ",
 1352                     join(',', @{$PEOPLE{$person_id}->{$key}}),
 1353                     "\n";
 1354             } else {
 1355                 print $FH "\t$key: $PEOPLE{$person_id}->{$key}\n";
 1356             }
 1357         }
 1358         print $FH "END\n";
 1359     }
 1360 
 1361     my $val;
 1362     print $FH "\nRESERVATIONS:\n";
 1363     foreach my $res_id (keys(%RESERVATIONS)) {
 1364         print $FH "START\n";
 1365         foreach my $key (@RES_KEYS) {
 1366             if (exists($RESERVATIONS{$res_id}->{$key})) {
 1367                 if ($key =~ /^(start|end)$/) {
 1368                     $val = join('.', @{$RESERVATIONS{$res_id}->{$key}});
 1369                     print $FH "\t$key: $val\n";
 1370                 } else {
 1371                     print $FH "\t$key: $RESERVATIONS{$res_id}->{$key}\n";
 1372                 }
 1373             }
 1374         }
 1375         print $FH "END\n";
 1376     }
 1377     $DEBUG && abslog("done writing DB");
 1378 }
 1379 
 1380 sub readFile
 1381 {
 1382     my $mode = '';
 1383     my $in_block = 0;
 1384     my ($key, $val);
 1385     my $curr;
 1386 
 1387     $DEBUG && abslog("read file.");
 1388     seek($FH, 0, 0) || die "seek";
 1389 
 1390     $DEBUG && abslog("reading DB");
 1391 
 1392     %GROUPS         = ();
 1393     %PEOPLE         = ();
 1394     %RESERVATIONS   = ();
 1395     %USERS          = ();
 1396 
 1397     while(<$FH>) {
 1398         chomp;
 1399         ($DEBUG > 2) && print "LINE: $_\n";
 1400         if (/^\s*#/) { next; }      # skip WS
 1401         if (/^PEOPLE:/) {
 1402             $mode = 'people';
 1403             next;
 1404         } elsif (/^RESERVATIONS:/) {
 1405             $mode = 'reservations';
 1406             ($DEBUG > 2) && print "found RESERVATIONS:\n";
 1407             next;
 1408         } elsif (/^GROUPS:/) {
 1409             $mode = 'groups';
 1410             ($DEBUG > 2) && print "found GROUPS:\n";
 1411             next;
 1412         } elsif (/^USERS:/) {
 1413             $mode = 'users';
 1414             ($DEBUG > 2) && print "found USERS:\n";
 1415             next;
 1416         }
 1417     
 1418         if ($mode eq 'people') {
 1419             if ($in_block) {
 1420                 if (/^END/) {
 1421                     $in_block = 0;
 1422                     if (!exists($curr->{id})) {
 1423                         die "no id found for person [$curr->{name}]";
 1424                     }
 1425                     if (exists($PEOPLE{$curr->{id}})) {
 1426                         die "person ID [$curr->{id}] occurs twice";
 1427                     }
 1428                     if (!exists($curr->{group})) {
 1429                         $curr->{group} = [1];
 1430                     }
 1431                     $PEOPLE{$curr->{id}} = $curr;
 1432                     undef $curr;
 1433                     next;
 1434                 }
 1435                 if (/^\s*(\S+):\s*(\S+(\s+\S+)*)\s*$/) {
 1436                     ($key, $val) = ($1, $2);
 1437                     if (exists($PERSON_KEYS{$key})) {
 1438                         if ($key eq 'group') {
 1439                             $curr->{$key} = [split(/,/, $val)];
 1440                         } else {
 1441                             $curr->{$key} = $val;
 1442                         }
 1443                     }
 1444                 }
 1445             } elsif (/^START/) {
 1446                 $in_block = 1;
 1447             }
 1448         } elsif ($mode eq 'reservations') {
 1449             if ($in_block) {
 1450                 if (/^END/) {
 1451                     $in_block = 0;
 1452                     ($DEBUG > 2) && print "END: id = $curr->{id}\n";
 1453                     if (!exists($curr->{id})) {
 1454                         die "no id found for reservation [$curr->{start}]";
 1455                     }
 1456                     if (exists($RESERVATIONS{$curr->{id}})) {
 1457                         die "reservation ID [$curr->{id}] occurs twice";
 1458                     }
 1459                     $curr->{sjd} = AbsenceDate::julianDay(@{$curr->{start}});
 1460                     $curr->{ejd} = AbsenceDate::julianDay(@{$curr->{end}});
 1461                     $RESERVATIONS{$curr->{id}} = $curr;
 1462                     undef $curr;
 1463                     next;
 1464                 }
 1465                 if (/^\s*(\S+):\s*(\S+(\s+\S+)*)\s*$/) {
 1466                     ($key, $val) = ($1, $2);
 1467                     ($DEBUG > 2) && print "key = [$key], val = [$val]\n";
 1468                     if (exists($RESERVATION_KEYS{$key})) {
 1469                         ($DEBUG > 2) && print "setting \$curr->{$key} = [$val]\n";
 1470                         if ($key =~ /^(start|end)$/) {
 1471                             $curr->{$key} = [split(/\./,$val)];
 1472                         } else {
 1473                             $curr->{$key} = $val;
 1474                         }
 1475                     }
 1476                 }
 1477             } elsif (/^START/) {
 1478                 $in_block = 1;
 1479                 next;
 1480             }
 1481         } elsif ($mode eq 'groups') {
 1482             if ($in_block) {
 1483                 if (/^END/) {
 1484                     $in_block = 0;
 1485                     ($DEBUG > 2) && print "END: id = $curr->{id}\n";
 1486                     if (!exists($curr->{id})) {
 1487                         die "no id found for group [$curr->{name}]";
 1488                     }
 1489                     if (exists($GROUPS{$curr->{id}})) {
 1490                         die "group ID [$curr->{id}] occurs twice";
 1491                     }
 1492                     $GROUPS{$curr->{id}} = $curr;
 1493                     $GROUP_COUNT++;
 1494                     undef $curr;
 1495                     next;
 1496                 }
 1497                 if (/^\s*(\S+):\s*(\S+(\s+\S+)*)\s*$/) {
 1498                     ($key, $val) = ($1, $2);
 1499                     ($DEBUG > 2) && print "key = [$key], val = [$val]\n";
 1500                     if (exists($GROUP_KEYS{$key})) {
 1501                         ($DEBUG > 2) && print "setting \$curr->{$key} = [$val]\n";
 1502                         $curr->{$key} = $val;
 1503                     }
 1504                 }
 1505             } elsif (/^START/) {
 1506                 $in_block = 1;
 1507                 next;
 1508             }
 1509         } elsif ($mode eq 'users') {
 1510             if ($in_block) {
 1511                 if (/^END/) {
 1512                     $in_block = 0;
 1513                     ($DEBUG > 2) && print "END: id = $curr->{user_id}\n";
 1514                     if (!exists($curr->{user_id})) {
 1515                         die "no id found for user [$curr->{user_id}]";
 1516                     }
 1517                     if (exists($USERS{$curr->{user_id}})) {
 1518                         die "user ID [$curr->{user_id}] occurs twice";
 1519                     }
 1520                     $USERS{$curr->{user_id}} = $curr;
 1521                     #$USER_COUNT++;
 1522                     undef $curr;
 1523                     next;
 1524                 }
 1525                 if (/^\s*(\S+):\s*(\S+(\s+\S+)*)\s*$/) {
 1526                     ($key, $val) = ($1, $2);
 1527                     ($DEBUG > 2) && print "key = [$key], val = [$val]\n";
 1528                     if ($key =~ /acl$/) {
 1529                         $val = [split(/,/, $val)];
 1530                     }
 1531                     if (exists($USER_KEYS{$key})) {
 1532                         ($DEBUG > 2) && print "setting \$curr->{$key} = [$val]\n";
 1533                         $curr->{$key} = $val;
 1534                     }
 1535                 }
 1536             } elsif (/^START/) {
 1537                 $in_block = 1;
 1538                 next;
 1539             }
 1540         }
 1541     }
 1542     if (!%GROUPS) {
 1543         %GROUPS = ( 1 => { id => 1, name => 'default' } );
 1544     }
 1545 }
 1546 
 1547 sub timestamp
 1548 {
 1549     my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 1550     my ($sec,$min,$hour,$mday,$mon,$year,@junk) = localtime(time);
 1551 
 1552     return sprintf("%d-%s-%d %02d:%02d",
 1553         $mday, $months[$mon], $year+1900, $hour, $min);
 1554 }
 1555 
 1556 sub backupDB
 1557 {
 1558     # if current DB has been mulched, i.e., has zero length, don't backup
 1559     my $size = (stat($DB_PATH))[7];
 1560     if ($size == 0) { return; }
 1561 
 1562     my $i = AbsenceConfig::fetch('backup_copies');
 1563     $DEBUG && abslog("backupDB: i=[$i]");
 1564 
 1565     my $backup_dir = AbsenceConfig::fetch('backup_dir');
 1566     my $db_file = AbsenceConfig::fetch('database_file');
 1567 
 1568 
 1569     my ($j, $old, $new);
 1570 
 1571     # first rotate old copies
 1572     while($i > 1) {
 1573         $j = $i - 1;
 1574         #$old = "${DB_PATH}.sav$j";
 1575         #$new = "${DB_PATH}.sav$i";
 1576         $old = "$backup_dir/${db_file}.sav$j";
 1577         $new = "$backup_dir/${db_file}.sav$i";
 1578 
 1579         $DEBUG && abslog("backupDB: looking for [$old]");
 1580         if (-e $old) {
 1581             rename($old, $new) || abslog("rename failed: $old --> $new");
 1582         }
 1583         $i--;
 1584     }
 1585 
 1586     # new copy the database
 1587     #$new = "${DB_PATH}.sav1";
 1588     $new = "$backup_dir/${db_file}.sav1";
 1589     my $ret;
 1590     $ret = system("cp $DB_PATH $new");
 1591     if ($ret) {
 1592         $ret = $ret >> 8;
 1593         abslog("'copy $DB_PATH $new' failed: $ret\nerror=$!");
 1594         dirList();
 1595     }
 1596 }
 1597 
 1598 sub dirList
 1599 {
 1600     my $data_dir = AbsenceConfig::fetch('data_dir_abs');
 1601     abslog("directory listing of [$data_dir]:");
 1602     my $dh;
 1603     abslog('-nots',
 1604         sprintf('%4s %-25s %2s %4s %4s %8s %s',
 1605             'MODE', 'NAME', 'LN', 'UID', 'GID', 'SIZE', 'MTIME'
 1606         )
 1607     );
 1608     opendir($dh, $data_dir) || die "opendir: $!";
 1609     my @list;
 1610     while(my $entry = readdir($dh)) {
 1611         next if ($entry =~ /^\.\.?$/);
 1612         push(@list, $entry);
 1613     }
 1614     closedir($dh);
 1615     foreach my $entry (sort @list) {
 1616         listFile($data_dir, $entry);
 1617     }
 1618 }
 1619 
 1620 sub listFile
 1621 {
 1622     my ($dir, $file) = @_;
 1623     my $path = "$dir/$file";
 1624 
 1625     my ($mode, $nlink, $uid, $gid, $size, $atime, $mtime, $ctime)
 1626         = (stat($path))[2..5, 7..10];
 1627     abslog('-nots',
 1628         sprintf('%4o %-25s %2s %4s %4s %8s %s', 
 1629             $mode & 07777,
 1630             $file,
 1631             $nlink,
 1632             $uid,
 1633             $gid,
 1634             $size,
 1635             scalar(localtime($mtime))
 1636         )
 1637     );
 1638 }
 1639 
 1640 sub dbg
 1641 {
 1642     my $msg = shift;
 1643 
 1644     $DEBUG && abslog("DEBUG: $msg");
 1645 }
 1646 
 1647 1;
 1648 
 1649 __END__
 1650 
 1651 =head1 NAME
 1652 
 1653 AbsenceDB.pm - interface to absence database.
 1654 
 1655 =head1 SYNOPSIS
 1656 
 1657   use AbsenceDB;
 1658 
 1659 
 1660 Operations on people:
 1661 
 1662   @people_ids = getPeople($group_id);
 1663   
 1664   $name = getPerson($person_id);
 1665     or
 1666   ($name, $email, $group_id) = getPerson($person_id);
 1667 
 1668   $group_id = getGroup($person_id);
 1669 
 1670   $result = addPerson($person_id, $name, $email, $group_id);
 1671 
 1672   $result = deletePerson($person_id);
 1673 
 1674 
 1675 Operations on reservations:
 1676 
 1677   @reservations = getReservations($person_id);
 1678 
 1679   @reservations = getMonthReservations($person_id, $month, $year);
 1680 
 1681   $reservation_structure = getReservation($reservation_id);
 1682 
 1683   $result = addReservation($reservation_id, $start, $end, $type, $description);
 1684 
 1685   $result = deleteReservation($reservation_id);
 1686 
 1687 
 1688 Operations on groups:
 1689 
 1690   $result = addGroup($group_id, $group_name, $group_password);
 1691 
 1692   $result = deleteGroup($group_id);
 1693 
 1694   @groups = getGroups();
 1695 
 1696   $group_name = getGroup($group_id);
 1697     or
 1698   ($group_name, $group_password) = getGroup($group_id);
 1699 
 1700   $number_of_groups = groupCount();
 1701 
 1702   $mod_time = getModificationTime($group_id, $month, $year);
 1703 
 1704 =head1 DESCRIPTION
 1705 
 1706 C<AbsenceDB.pm> is a crude interface to a database.  In theory, the
 1707 underlying database could be anything.  You have perhaps noticed that
 1708 elsewhere I refer to B<absences>, but here they are called
 1709 B<reservations>?  That came about as a result of my original intention
 1710 to keep the system generic, i.e., not necessarily only for people.
 1711 Along the way I apparently got a little confused.
 1712 
 1713 =head1 PERSON FUNCTIONS
 1714 
 1715 =over 4
 1716 
 1717 =item getPeople()
 1718 
 1719 returns a list of person_ids belonging to the specified group.
 1720 
 1721 =item getPerson()
 1722 
 1723 retrieves information about the specified person_id.  In a scalar
 1724 context returns the name, in a list context returns (name, email).
 1725 
 1726 =item addPerson()
 1727 
 1728 creates a new person or modifies an existing one.  Parameters are
 1729 C<($person_id, $name, $email, $group_id)>.  If B<$person_id> equals
 1730 'new', a new person is created, otherwise B<$person_id> must
 1731 contain a valid person-id.  If an attempt is made to create a person
 1732 with the same name as an existing one, the operation fails and
 1733 the return-value is 'duplicate'.  On success returns 'ok'.
 1734 
 1735 =item deletePerson()
 1736 
 1737 guess what it does? Takes as single param a person-id.  Returns
 1738 'ok' on success, otherwise 'bad-id' if the person-id was not valid.
 1739 
 1740 
 1741 =head1 RESERVATION FUNCTIONS
 1742 
 1743 =item getReservations()
 1744 
 1745 returns a list of all reservations belonging to the specified person_id.
 1746 
 1747 =item getMonthReservations()
 1748 
 1749 finds all reservations for a given person_id in a given month and year.
 1750 returns a list of array-refs containing reservation-info in the
 1751 form C<[$reservation_id, $start, $end, $type, $description]>.  C<$start>
 1752 and C<$end> are array-refs of the form C<[$day, $month, $year]>.
 1753 
 1754 Alternatetively the data-structure could be represented so:
 1755 
 1756   [
 1757     $reservation_id,
 1758     [
 1759       $start_day,
 1760       $start_month,
 1761       $start_year,
 1762     ],
 1763     [
 1764       $end_day,
 1765       $end_month,
 1766       $end_year,
 1767     ],
 1768     $type,
 1769     $description,
 1770   ]
 1771     
 1772 =item getReservation()
 1773 
 1774 given a reservation-id it returns a reference to an array in the
 1775 same format as B<getMonthReservations()> if the reservation-id is
 1776 valid, otherwise returns nothing.
 1777 
 1778 =item addReservation()
 1779 
 1780 adds a new reservation, or modifies an existing one. Parameters
 1781 are C<($res_id, $person_id, $start, $end, $type, $desc)>. If
 1782 B<$res_id> equals 'new', a new reservation is created, otherwise
 1783 B<$res_id> must contain valid reservation-id.
 1784 
 1785 B<$start> and B<$end> must contain dates in the form "D.M.Y".
 1786 
 1787 Returns a list of two items:
 1788 
 1789 =over 4
 1790 
 1791 =item ('disappeared', '')
 1792 
 1793 someone else (presumably) deleted the absence in the meantime
 1794 
 1795 =item ('badday', '')
 1796 
 1797 the start or end day is invalid (i.e., February 30)
 1798 
 1799 =item ('impossible', '')
 1800 
 1801 the start-day is greater than the end-day.
 1802 
 1803 =item ('conflict', $res_id)
 1804 
 1805 there is a conflict with another reservation. B<$res_id> is the
 1806 reservation-id of the conflicting reservation.
 1807 
 1808 =item ('ok', '')
 1809 
 1810 success.
 1811 
 1812 =back
 1813 
 1814 =item deleteReservation()
 1815 
 1816 deletes a reservation.  Takes as single parameter a reservation-id.
 1817 
 1818 returns:
 1819 
 1820 =over 4
 1821 
 1822 =item internalerror
 1823 
 1824 The specified reservation-id does not exist.
 1825 
 1826 =item conflict
 1827 
 1828 The reservation-id disappeared suddenly.  Presumably someone else
 1829 got there before you.
 1830 
 1831 =item ok
 1832 
 1833 success.
 1834 
 1835 =back
 1836 
 1837 
 1838 =head1 GROUP FUNCTIONS
 1839 
 1840 =item addGroup()
 1841 
 1842 creates a new group or modifies an existing one.  parameters are
 1843 ($group_id, $name, $password).  If $group_id equals 'new', a new
 1844 group is created, otherwise $group_id must contain a valid group-id.
 1845 If an attempt is made to create a group with the same name as an
 1846 existing one, returns 'duplicate'.  Returns 'ok' on success.
 1847 
 1848 =item deleteGroup()
 1849 
 1850 guess what this does?  Takes as single parameter the group-id.  Returns
 1851 'ok' on success.
 1852 
 1853 =item getGroups()
 1854 
 1855 returns a list of group-ids corresponding to all existing groups.
 1856 
 1857 =item getGroup()
 1858 
 1859 retrieves information about a group.  Takes as single parameter
 1860 the group-id.  Return-value depends on context: in a scalar
 1861 context, returns group-name, in a list context returns 
 1862 a list consisting of B<($group_name, $group_password)>.
 1863 
 1864 =item getGroup()
 1865 
 1866 returns the group-id to which a person belongs.  Takes as single param
 1867 the person-id.
 1868 
 1869 =item groupCount()
 1870 
 1871 returns the number of defined groups.
 1872 
 1873 =item getModificationTime()
 1874 
 1875 retrieves modification time for a particular group for a particular
 1876 month, if one is known.  This allows C<absence.pl> to determine
 1877 if a month-image needs to be created anew.  Returns the time in
 1878 epoch-second format if available, otherwise undef.
 1879 
 1880 =back
 1881 
 1882 =head1 AUTHOR
 1883 
 1884 Robert Urban <urban@tru64.org>
 1885 
 1886 Copyright (C) 2003 Robert Urban
 1887 
 1888 =cut