"Fossies" - the Fresh Open Source Software Archive

Member "absence-v2.1/cgi-bin/AbsenceDB.pm" (15 Dec 2013, 74967 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 "AbsenceDB.pm" see the Fossies "Dox" file reference documentation.

    1 #----------------------------------------------------------------------
    2 # AbsenceDB - interface to database
    3 # $Id: AbsenceDB.pm 116 2013-12-15 00:09:27Z urban $
    4 # copyright Robert Urban
    5 #----------------------------------------------------------------------
    6 
    7 #======================================================================
    8 #    This file is part of Absence.
    9 #
   10 #    Absence is free software: you can redistribute it and/or modify
   11 #    it under the terms of the GNU General Public License as published by
   12 #    the Free Software Foundation, either version 3 of the License, or
   13 #    (at your option) any later version.
   14 #
   15 #    Absence is distributed in the hope that it will be useful,
   16 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
   17 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18 #    GNU General Public License for more details.
   19 #
   20 #    You should have received a copy of the GNU General Public License
   21 #    along with Absence.  If not, see <http://www.gnu.org/licenses/>.
   22 #======================================================================
   23 
   24 # $Rev: 116 $:  Revision of last commit
   25 # $Author: urban $:  Author of last commit
   26 # $Date: 2013-12-15 01:09:27 +0100 (Sun, 15 Dec 2013) $:  Date of last commit
   27 
   28 package AbsenceDB;
   29 
   30 use FileHandle;
   31 use Carp;
   32 use Digest::MD5 qw(md5_base64);
   33 
   34 use AbsenceConfig;
   35 use AbsenceDate;
   36 use AbsenceLog;
   37 use DBI;
   38 use CGI::Session;
   39 use IPC::Open3;
   40 use Data::Dumper;
   41 
   42 #----------------------------------------------------------------------
   43 # initialization
   44 #----------------------------------------------------------------------
   45 
   46 my $DB_NAME         = AbsenceConfig::fetch('database_name');
   47 my $DB_PORT         = AbsenceConfig::fetch('database_port');
   48 my $DB_HOST         = AbsenceConfig::fetch('database_host');
   49 my $DB_USER         = AbsenceConfig::fetch('database_user');
   50 my $DB_PASS         = AbsenceConfig::fetch('database_pass');
   51 
   52 $Data::Dumper::Indent = 1;
   53 my $DEBUG           = 0;
   54 my $VERBOSE         = 1;
   55 my %META;   # container for PostgreSQL metadata about tables/fields
   56 
   57 #----------------------------------------------------------------------
   58 # connect to db first thing
   59 #----------------------------------------------------------------------
   60 $DEBUG && abslog("init: connect to DB");
   61 
   62 my $DBH = DBI->connect("dbi:Pg:dbname=$DB_NAME;host=$DB_HOST",
   63     $DB_USER, $DB_PASS, {AutoCommit => 1, RaiseError => 1});
   64 
   65 defined($DBH) || die "cannot connect to DB";
   66 
   67 my @SESSION_PARAMS  = (
   68     'driver:PostgreSQL',
   69     undef,
   70     {
   71         Handle      => $DBH,
   72         ColumnType  => 'binary',
   73     }
   74 );
   75 
   76 END {
   77     defined($DBH) && $DBH->disconnect;
   78 }
   79 
   80 #-----------------------------------------
   81 # $FULL_SLOTS is defined here *and* in
   82 # AbsenceImage.pm :(
   83 #-----------------------------------------
   84 my $FULL_SLOTS      = 4;
   85 
   86 my $MODTIME_FILE    = AbsenceConfig::fetch('modtime_db_file');
   87 my $OAP             = AbsenceConfig::fetch('objects_are_people');
   88 my $AUTH            = AbsenceConfig::fetch('authentication');
   89 my $CRED_SRC        = AbsenceConfig::fetch('credential_src');
   90 my $PW_HASH_FORMAT  = AbsenceConfig::fetch('pw_hash_format');
   91 my $SESSION_TIMEOUT = AbsenceConfig::fetch('session_timeout');
   92 my $MULTI_RES       = AbsenceConfig::fetch('multi_res');
   93 my $MAX_MULTI       = AbsenceConfig::fetch('max_multi');
   94 my $HOL_SCHEME      = AbsenceConfig::fetch('holiday_scheme');
   95 my $MANAGE_PASSWORD = AbsenceConfig::fetch('manage_password');
   96 
   97 
   98 my $VERSION         = '2.0.2';
   99 
  100 #----------------------------------------------------------------------
  101 # methods
  102 #----------------------------------------------------------------------
  103 
  104 #----------------------------------------------------------------
  105 # getPeople()
  106 #
  107 # returns an array of person_ids sorted by name
  108 # if group_id is zero, returns all people. Otherwise, returns
  109 # people in group_id
  110 #----------------------------------------------------------------
  111 
  112 sub getPeople
  113 {
  114     my $group_id = shift;
  115 
  116     my @out;
  117     my $sql;
  118 
  119     if ($group_id == 0) {
  120         $sql = qq{
  121             SELECT id
  122             FROM v_object
  123             ORDER BY LOWER(name);
  124         };
  125         return dbSelectColumn($sql, 'id');
  126     }
  127 
  128     if (!groupExists(id => $group_id)) {
  129         die "getPeople: gid [$group_id] does not exist";
  130     }
  131 
  132     $sql = qq{
  133         SELECT o.id
  134         FROM
  135             v_object AS o,
  136             v_group AS g,
  137             c_group_object AS go
  138         WHERE
  139             g.id = ? AND
  140             go.group_id = g.id AND
  141             go.object_id = o.id
  142         ORDER BY
  143             LOWER(o.name);
  144     };
  145     return dbSelectColumn($sql, 'id', $group_id);
  146 }
  147 
  148 sub groupExists
  149 {
  150     my ($field, $val) = @_;
  151 
  152     my $sql = qq{SELECT id FROM v_group WHERE $field = ?;};
  153 
  154     my $rv = $DBH->do($sql, undef, $val);
  155     ($rv eq '0E0') && return 0;
  156     return 1;
  157 }
  158 
  159 sub reservationExists
  160 {
  161     my $id = shift;
  162 
  163     my $sql = qq{SELECT id FROM v_reservation WHERE id = ?;};
  164 
  165     my $rv = $DBH->do($sql, undef, $id);
  166     ($rv eq '0E0') && return 0;
  167     return 1;
  168 }
  169 
  170 sub objectExists
  171 {
  172     my ($field, $val) = @_;
  173 
  174     my $sql = qq{SELECT id FROM v_object WHERE $field = ?;};
  175 
  176     my $rv = $DBH->do($sql, undef, $val);
  177     ($rv eq '0E0') && return 0;
  178     return 1;
  179 }
  180 
  181 sub userExists
  182 {
  183     my ($field, $val) = @_;
  184 
  185     my $sql = qq{SELECT id FROM v_user WHERE $field = ?;};
  186 
  187     my $rv = $DBH->do($sql, undef, $val);
  188     ($rv eq '0E0') && return 0;
  189     return 1;
  190 }
  191 
  192 sub inListN
  193 {
  194     my ($thing, $lref) = @_;
  195 
  196     foreach my $elem (@{$lref}) {
  197         ($elem == $thing) && return 1;
  198     }
  199 
  200     return 0;
  201 }
  202 
  203 sub getPerson
  204 {
  205     my ($pid, $field) = @_;
  206 
  207     if (!objectExists(id => $pid)) {
  208         #print "no person with ID=[$pid]\n";
  209         return undef;
  210     }
  211     
  212     my $sql;
  213 
  214     if ($field) {
  215         $sql = qq{SELECT $field FROM v_object WHERE id = ?;};
  216 
  217         my $ref = dbSelect($sql, $pid);
  218         return defined($ref) ? $ref->{$field} : undef;
  219     }
  220 
  221     $sql = qq{SELECT * FROM v_object WHERE id = ?;};
  222 
  223     return dbSelect($sql, $pid);
  224 }
  225 
  226 sub getUserForOid
  227 {
  228     my $oid = shift;
  229 
  230     my $sql = qq{
  231         SELECT *
  232         FROM v_user
  233         WHERE object_id = ?;
  234     };
  235 
  236     return dbSelect($sql, $oid);
  237 }
  238 
  239 sub getOidForUid
  240 {
  241     my $user_id = shift;
  242 
  243     my $sql = qq{
  244         SELECT  object_id
  245         FROM    v_user
  246         WHERE   id = ?;
  247     };
  248 
  249     my $res = dbSelect($sql, $user_id);
  250 
  251     return defined($res) ? $res->{object_id} : undef;
  252 }
  253 
  254 sub getPidForUser
  255 {
  256     my $user = shift;
  257 
  258     userExists(username => $user) || confess "user [$user] unknown";
  259 
  260     my $sql = qq{
  261         SELECT  object_id
  262         FROM    v_user
  263         WHERE   username = ?;
  264     };
  265 
  266     my $res = dbSelect($sql, $user);
  267 
  268     return defined($res) ? $res->{object_id} : undef;
  269 }
  270 
  271 #-------------------------------------------------------------
  272 # getReservations()
  273 #
  274 # apparently only called from resConflict, probably don't need anymore
  275 # also, inefficient, as it queries all reservations, without regard
  276 # for date
  277 #-------------------------------------------------------------
  278 sub getReservations
  279 {
  280     my $person_id = shift;
  281 
  282     my @out;
  283 
  284     $DEBUG && abslog("getReservations for id=[$person_id]");
  285 
  286     my $sql = qq{
  287         SELECT *
  288         FROM v_reservation
  289         WHERE object_id = ?;
  290     };
  291 
  292     return dbSelect($sql, $person_id);
  293 }
  294 
  295 sub getMonthReservations
  296 {
  297     my ($person_id, $month, $year) = @_;
  298 
  299     my $dim = AbsenceDate::daysInMonth($month, $year);
  300     my $month_begin = "$year-$month-1";
  301     my $month_end = "$year-$month-$dim";
  302 
  303     #$DEBUG && abslog("getMonthReservations: p_id = $person_id, m=$month, y=$year");
  304 
  305     my $sql = qq{
  306         SELECT *
  307         FROM v_reservation
  308         WHERE
  309             object_id = ? AND (
  310                 (
  311                     ( start BETWEEN ? AND ? ) OR
  312                     ( finish BETWEEN ? AND ? )
  313                 )
  314                 OR
  315                 (
  316                     ( start < ? ) AND ( finish > ? )
  317                 )
  318             );
  319     };
  320 
  321     my @bind_params = (
  322         $person_id,
  323         $month_begin, $month_end, $month_begin, $month_end,
  324         $month_begin, $month_end);
  325 
  326     my @out;
  327     foreach my $ref (dbSelect($sql, @bind_params)) {
  328         my ($sd, $ed) = getMonthBounds($ref->{start}, $ref->{finish}, $month, $year);
  329         push(@out, {
  330             res     => $ref,
  331             bounds  => {
  332                 start   => $sd,
  333                 end     => $ed,
  334              },
  335         });
  336     }
  337 
  338     @out;
  339 }
  340 
  341 sub getMonthBounds
  342 {
  343     my ($start, $end, $month, $year) = @_;
  344 
  345     my ($sd, $sm, $sy, $ed, $em, $ey);
  346 
  347     if (ref($start)) {
  348         ($sy, $sm, $sd) = ($start->{year}, $start->{month}, $start->{day});
  349         ($ey, $em, $ed) = ($end->{year}, $end->{month}, $end->{day});
  350     } else {
  351         ($sy, $sm, $sd) = ($start =~ /^(\d{4})-(\d{2})-(\d{2})$/);
  352         ($ey, $em, $ed) = ($end =~ /^(\d{4})-(\d{2})-(\d{2})$/);
  353     }
  354 
  355     my $dim = AbsenceDate::daysInMonth($month, $year);
  356 
  357     my $s = (($sm == $month) && ($sy == $year)) ? $sd : 1;
  358     my $e = (($em == $month) && ($ey == $year)) ? $ed : $dim;
  359 
  360     return ($s, $e);
  361 }
  362 
  363 sub getReservation
  364 {
  365     my $rid = shift;
  366 
  367     my $sql = qq{
  368         SELECT *
  369         FROM v_reservation
  370         WHERE id = ?;
  371     };
  372 
  373     return dbSelect($sql, $rid);
  374 }
  375 
  376 #--------------------------------------------------------------------
  377 # group stuff
  378 #--------------------------------------------------------------------
  379 
  380 sub addGroup
  381 {
  382     # ROBBO: modify callers to pass desc too
  383     my ($gid, $name, $pass, $desc) = @_;
  384 
  385     $DEBUG && abslog("addGroup: start: name=[$name], pass=[$pass]");
  386 
  387     ## check lengths
  388     #my $ret = checkLengths('c_group', {
  389     #   name        => $name,
  390     #   password    => $pass,
  391     #   description => $desc,
  392     #};
  393     #$ret && return "baddata: $ret";
  394 
  395     my $verb;
  396 
  397     my $sql;
  398 
  399     if ($gid eq 'new') {
  400         if (groupExists(name => $name)) {
  401             abslog("addGroup: dup, bailing.");
  402             return 'duplicate';
  403         }
  404         $sql = qq{
  405             INSERT INTO c_group
  406                 (name, password, description)
  407             VALUES (?,?,?);
  408         };
  409         $verb = 'insert';
  410         $gid = insertRowRetrieveSequence('c_group', $sql, $name, $pass, $desc);
  411 
  412     } else {
  413         if (!groupExists(id => $gid)) {
  414             abslog("error: attempt to modify non-existent group [$gid]");
  415             return undef;
  416         }
  417         $sql = qq{
  418             UPDATE c_group
  419             SET name = ?, password = ?, description = ?
  420             WHERE id = ?;
  421         };
  422         $verb = 'update';
  423         my $rv = $DBH->do($sql, undef, $name, $pass, $desc, $gid);
  424         defined($rv) || die "update group [$name]. error=".$DBH->errstr();
  425     }
  426 
  427     $DEBUG && abslog("addGroup: group-id = [$gid].");
  428     abslog("addGroup: $verb: name=[$name], gid=[$gid]");
  429 
  430     return wantarray ? ('ok', $gid) : 'ok';
  431 }
  432 
  433 sub deleteGroup
  434 {
  435     my $gid = shift;
  436 
  437     $DEBUG && abslog("deleteGroup: start: gid=[$gid]");
  438 
  439     my $sql = qq{SELECT * FROM v_group WHERE id = $gid;};
  440     my $gref = dbSelect($sql);
  441 
  442     if (!defined($gref)) {
  443         abslog("error: attempt to delete non-existent group [$gid]");
  444         return undef;
  445     }
  446 
  447     #---------------------------------------------------
  448     # first, check if members need to be deleted or modified
  449     #---------------------------------------------------
  450     $sql = qq{
  451         SELECT DISTINCT v_object.id
  452         FROM v_group,v_object,c_group_object
  453         WHERE c_group_object.group_id = ?
  454         AND c_group_object.object_id = v_object.id;
  455     };
  456 
  457     my $aref = $DBH->selectcol_arrayref($sql, undef, $gid);
  458     if (defined($aref)) {
  459         #---------------------------------------------------
  460         # people are still members of $gid
  461         # for each member, check if member of other groups
  462         # if yes, delete membership, if no, delete object
  463         #---------------------------------------------------
  464         foreach my $pid (@{$aref}) {
  465             # get IDs of object/group mapping for $pid
  466             removeObjectFromGroup(
  467                 -pid    => $pid,
  468                 -gid    => $gid,
  469                 #'-delete_groupless_objects',
  470             );
  471         }
  472     }
  473 
  474     #---------------------------------------------------
  475     # remove any referring rows in d_group_mod_time
  476     #---------------------------------------------------
  477     $sql = qq{ DELETE FROM d_group_mod_time WHERE group_id = ?; };
  478     $DBH->do($sql, undef, $gid);
  479 
  480     #-----------------------------------------------------------------
  481     # now get rid of the group
  482     # it might be interesting some time to implement invalidation.
  483     # for now, I just delete the row entirely.
  484     #-----------------------------------------------------------------
  485     #my $now = time();
  486     #$sql = qq{UPDATE c_group SET invalidated = int2tsz($now) WHERE id = $gid;};
  487     #-----------------------------------------------------------------
  488 
  489     $sql = qq{DELETE FROM c_group WHERE id = ?;};
  490     $DBH->do($sql, undef, $gid);
  491     
  492     $AUTH && deleteGidInAcls($gid);
  493 
  494     abslog("deleteGroup: name=[$gref->{name}], gid=[$gid]");
  495 
  496     return 'ok';
  497 }
  498 
  499 sub addGroupMappings
  500 {
  501     my ($object_id, @gids) = @_;
  502 
  503     my $sql = qq{
  504         INSERT INTO c_group_object
  505             (group_id,object_id)
  506         VALUES (?,?);
  507     };
  508     my $sth = $DBH->prepare($sql);
  509     defined($sth) || die "prepare failed on sql [$sql]";
  510 
  511     #   VALUES ($gid,$object_id);
  512     foreach my $gid (@gids) {
  513         $sth->execute($gid, $object_id)
  514             || die "sql failed: [$sql] with params gid=[$gid], object_id=[$object_id]";
  515     }
  516 }
  517 
  518 sub deleteGroupMappings
  519 {
  520     my ($object_id, @group_ids) = @_;
  521 
  522     my $sql;
  523     my @bind_params;
  524 
  525     if (!@group_ids) {
  526         $sql = qq{
  527             DELETE FROM c_group_object
  528             WHERE object_id = ?;
  529         };
  530         @bind_params = ($object_id);
  531     } else {
  532         my @questions = map '?', @group_ids;
  533         my $q = join(',', @questions);
  534         $sql = qq{
  535             DELETE FROM c_group_object
  536             WHERE object_id = ?
  537             AND group_id in ($q);
  538         };
  539         @bind_params = ($object_id, @group_ids);
  540     }
  541     $DBH->do($sql, undef, @bind_params);
  542 }
  543 
  544 #--------------------------------------------------------------------
  545 # removeObjectFromGroup()
  546 #
  547 # remove an object from a group by deleting the object-group mapping.
  548 # parameters:
  549 # -gid => $gid
  550 # -pid => $pid
  551 # -delete_groupless_objects
  552 #
  553 # $gid and $pid are mandatory
  554 #
  555 # returns: nothing
  556 #--------------------------------------------------------------------
  557 sub removeObjectFromGroup
  558 {
  559     my $delete_groupless_objects = 0;
  560     my ($pid, $gid);
  561 
  562     while(my $arg = shift) {
  563         if ($arg =~ /delete_groupless_objects/) {
  564             $delete_groupless_objects = 1
  565         } elsif ($arg eq '-pid') {
  566             $pid = shift;
  567         } elsif ($arg eq '-gid') {
  568             $gid = shift;
  569         }
  570     }
  571     defined($pid) && defined($gid) || die "removeObjectFromGroup: pid/gid not defined";
  572 
  573     my $sql = qq{
  574         SELECT *
  575         FROM c_group_object
  576         WHERE c_group_object.object_id = ?;
  577     };
  578     my @list = dbSelect($sql, $pid);
  579 
  580     my $mapping_to_delete;
  581     my @others;
  582     foreach my $mapping (@list) {
  583         if ($mapping->{group_id} == $gid) {
  584             $mapping_to_delete = $mapping;
  585         } else {
  586             push(@others, $mapping);
  587         }
  588     }
  589 
  590     # $mapping_to_delete now contains id of the mapping which
  591     # associates object $pid with group $gid.
  592     # @others possibly contains mappings for $pid to other groups
  593 
  594     #--------------------------------------------------------
  595     # delete mapping
  596     #--------------------------------------------------------
  597     if (defined($mapping_to_delete)) {
  598         $sql = qq[
  599             DELETE FROM c_group_object
  600             WHERE id = ?;
  601         ];
  602         $DBH->do($sql, undef, $mapping_to_delete->{id});
  603     }
  604 
  605     #--------------------------------------------------------
  606     # invalidate object, if desired, and if object is not member
  607     # of other groups
  608     #--------------------------------------------------------
  609     if ($delete_groupless_objects && !@others) {
  610         #invalidateObject($pid);
  611         _deleteObject($pid);
  612     }
  613 }
  614 
  615 sub bad_deleteObject
  616 {
  617     my $oid = shift;
  618     
  619     deleteReservations(object_id => $oid);
  620 
  621     my $sql = qq{ DELETE FROM c_object WHERE id = ?; };
  622     $DBH->do($sql, undef, $oid);
  623 }
  624 
  625 sub invalidateObject
  626 {
  627     my $oid = shift;
  628     
  629     invalidateReservations(object_id => $oid);
  630 
  631     my $now = time();
  632 
  633     my $sql = qq{
  634         UPDATE c_object SET invalidated = int2tsz($now) WHERE id = ?;
  635     };
  636     $DBH->do($sql, undef, $oid);
  637 }
  638 
  639 sub _deleteReservation
  640 {
  641     my $res_id = shift;
  642 
  643     my $sql = qq{
  644         DELETE FROM d_reservation WHERE id = ?;
  645     };
  646     $DBH->do($sql, undef, $res_id);
  647 }
  648 
  649 sub invalidateReservation
  650 {
  651     my $res_id = shift;
  652 
  653     my $now = time();
  654 
  655     my $sql = qq{
  656         UPDATE d_reservation SET invalidated = int2tsz($now) WHERE id = ?;
  657     };
  658     $DBH->do($sql, undef, $res_id);
  659 }
  660 
  661 sub deleteReservations
  662 {
  663     my ($field, $val) = @_;
  664 
  665     my $sql = qq{
  666         DELETE FROM d_reservation WHERE $field = ?;
  667     };
  668     $DEBUG && abslog("deleteReservations: sql=[$sql]");
  669 
  670     $DBH->do($sql, undef, $val);
  671 }
  672 
  673 sub invalidateReservations
  674 {
  675     my ($field, $val) = @_;
  676 
  677     my $now = time();
  678 
  679     my $sql;
  680 
  681     $sql = qq{
  682         UPDATE d_reservation SET invalidated = int2tsz($now) WHERE $field = ?;
  683     };
  684 
  685     $DBH->do($sql, undef, $val);
  686 }
  687 
  688 #--------------------------------------------------------------------
  689 # ACL stuff
  690 #--------------------------------------------------------------------
  691 
  692 sub convertAclToInternal
  693 {
  694     my @out;
  695     foreach (@_) {
  696         push(@out, {
  697             level   => $_->{level},
  698             target  => defined($_->{magic}) ? $_->{magic} : $_->{ref_id},
  699         });
  700     }
  701     return wantarray ? (@out) : $out[0];
  702 }
  703 
  704 sub getUserAcls
  705 {
  706     my $user_id = shift;
  707 
  708     my $sql = qq{
  709         SELECT *
  710         FROM c_access
  711         WHERE user_id = ?;
  712     };
  713 
  714     my @acls = dbSelect($sql, $user_id);
  715     @acls || return undef;
  716 
  717     # separate ACLs into group/object
  718 
  719     my (@group, @object);
  720 
  721     foreach my $acl (@acls) {
  722         if ($acl->{type} eq 'object') {
  723             push(@object, convertAclToInternal($acl));
  724         } else {
  725             push(@group, convertAclToInternal($acl));
  726         }
  727     }
  728 
  729     return { object => \@object, group => \@group };
  730 }
  731 
  732 #------------------------------------------------------
  733 # authorizeAccessToObject()
  734 #
  735 # determines whether a user, ($user_id) may write an object ($oid),
  736 # that is, create, modify, and delete reservations.  a user
  737 # may gain write privileges in one of four:
  738 # (in all access entries level must be >= 2 and user_id must equal $user_id)
  739 # 1. there is an object access entry with magic=self and pointing to
  740 #    the oid associated with the user_id
  741 # 2. there is an object access entry pointing to the oid
  742 # 3. there is a group access entry pointing to a group to which
  743 #    oid belongs
  744 # 4. there is a group access entry with magic == 'all'
  745 # 5. there is a group access entry with magic == self, and the
  746 #    object associated with $user_id belongs to a group to which
  747 #    the object $oid also belongs
  748 #------------------------------------------------------
  749 sub authorizeAccessToObject
  750 {
  751     my ($user_id, $oid, $access) = @_;
  752 
  753     my %access_map = (
  754         read    => 1,
  755         write   => 2,
  756         admin   => 4,
  757     );
  758 
  759     exists($access_map{$access}) || die "access-type [$access] uknown";
  760 
  761     my $sql = qq{
  762         SELECT *
  763         FROM
  764             c_access        AS a,
  765             c_group_object  AS map_u,
  766             c_group_object  AS map_o,
  767             v_user          AS u
  768         WHERE
  769             (a.user_id = ? AND a.level >= $access_map{$access}) AND
  770             (
  771                     (a.type             = 'object'          AND
  772                      a.magic            = 'self'            AND
  773                      u.id               = ?                 AND
  774                      u.object_id        = ?) 
  775                 OR
  776                     (a.type             = 'object'          AND
  777                      a.ref_id           = ?)
  778                 OR
  779                     (a.type             = 'group'           AND 
  780                      a.ref_id           = map_o.group_id    AND
  781                      map_o.object_id    = ?)
  782                 OR
  783                     (a.type             = 'group'           AND 
  784                      a.magic            = 'all')
  785                 OR
  786                     (a.type             = 'group'           AND
  787                      a.magic            = 'self'            AND
  788                      map_u.object_id    = u.object_id       AND
  789                      map_o.object_id    = ?                 AND
  790                      map_o.group_id     = map_u.group_id    AND
  791                      u.id               = ?)
  792             )
  793         LIMIT 1;
  794     };
  795     my @bind_params = ($user_id, $user_id, $oid, $oid, $oid, $oid, $user_id);
  796     defined(dbSelect($sql, @bind_params)) && return 1;
  797     
  798     return 0;
  799 }
  800 
  801 sub authorizeAccessToGroup
  802 {
  803     my ($user_id, $gid, $access) = @_;
  804 
  805     my %access_map = (
  806         read    => 1,
  807         write   => 2,
  808         admin   => 4,
  809     );
  810 
  811     #--------------------------------------------------------------------
  812     # the magical value 'self' is not allowed for administration of
  813     # groups.  Shut it off by looking for something impossible.
  814     #--------------------------------------------------------------------
  815     my $self = ($access eq 'admin') ? 'junk' : 'self';
  816 
  817     exists($access_map{$access}) || die "access-type [$access] uknown";
  818 
  819     my $implicit_read;
  820     if ($access eq 'read') {
  821         $implicit_read = qq{
  822             OR
  823                 (u.id           = ?          AND
  824                  map.object_id  = u.object_id)
  825         };
  826     }
  827 
  828     my $sql = qq{
  829         SELECT a.id AS id
  830         FROM
  831             c_access        AS a,
  832             c_group_object  AS map,
  833             v_user          AS u
  834         WHERE
  835             (a.user_id = ? AND a.level >= $access_map{$access}) AND
  836             (
  837                     (a.type         = 'group'       AND
  838                      a.ref_id       = ?)
  839                 OR
  840                     (a.type         = 'group'       AND
  841                      a.magic        = 'self'        AND
  842                      map.group_id   = ?             AND
  843                      map.object_id  = u.object_id   AND
  844                      u.id           = ?)
  845                 OR
  846                     (a.type         = 'group'       AND 
  847                      a.magic        = 'all')
  848                 $implicit_read
  849             );
  850     };
  851 
  852     my @bind_params = ($user_id, $gid, $gid, $user_id);
  853     $implicit_read && push(@bind_params, $user_id);
  854 
  855     defined(dbSelect($sql, @bind_params)) && return 1;
  856     
  857     return 0;
  858 }
  859 
  860 sub findReadableGroups
  861 {
  862     my $user_id = shift;
  863 
  864     #---------------------------------------------------------------
  865     # three things need to be checked:
  866     # 1. find all groups to which the object associated with
  867     #    $user_id belongs (if any)
  868     # 2. find access records that refer directly to a particular group
  869     # 3. check if the user has an access record with type=group, and
  870     #    magic=all, if so, return *all* groups
  871     #---------------------------------------------------------------
  872 
  873     my $sql = qq{
  874         SELECT map.group_id
  875         FROM
  876             c_group_object  AS map,
  877             v_user          AS u
  878         WHERE
  879             (u.id           = ? AND
  880              map.object_id  = u.object_id)
  881 
  882         UNION
  883 
  884         SELECT ref_id AS group_id
  885         FROM c_access
  886         WHERE
  887             (user_id        = ?) AND
  888             (type           = 'group') AND 
  889             (ref_id         IS NOT NULL)
  890 
  891         UNION
  892 
  893         SELECT g.id AS group_id
  894         FROM
  895             v_group g,
  896             c_access a
  897         WHERE
  898          a.user_id = ? AND a.type = 'group' AND a.magic = 'all';
  899     };
  900     my @bind_params = ($user_id, $user_id, $user_id);
  901 
  902     my $sth = $DBH->prepare($sql);
  903     $sth->execute(@bind_params) || confess "statement [$sql] failed";
  904     my $tbl_ary_ref = $sth->fetchall_arrayref([0]);
  905 
  906     my @result;
  907     foreach my $row (@{$tbl_ary_ref}) {
  908         push(@result, $row->[0]);
  909     }
  910 
  911     @result;
  912 }
  913 
  914 sub findAdministratableUsers
  915 {
  916     my ($user_id, $op) = @_;
  917 
  918     my @all_users = getUsers();
  919 
  920     ($AUTH || isSuperuser($user_id)) && return @all_users;
  921 
  922     my @admin_groups = findAdminGroups($user_id);
  923 
  924     my @administratable_users;
  925     foreach my $uid (@all_users) {
  926         my @readable = findReadableGroups($uid);
  927         if (superset(\@admin_groups, \@readable)) {
  928             push(@administratable_users, $uid);
  929         }
  930     }
  931 
  932     return @administratable_users;
  933 }
  934 
  935 sub findAdminGroups
  936 {
  937     my $user_id = shift;
  938 
  939     my $sql = qq{
  940         SELECT ref_id AS group_id
  941         FROM c_access AS a
  942         WHERE
  943             a.user_id   = ?         AND
  944             a.level     = 4         AND
  945             a.type      = 'group'   AND
  946             a.ref_id    IS NOT NULL
  947 
  948         UNION
  949 
  950         SELECT g.id AS group_id
  951         FROM
  952             v_group g,
  953             c_access a
  954         WHERE
  955             a.user_id   = ?         AND
  956             a.level     = 4         AND
  957             a.type      = 'group'   AND
  958             a.magic = 'all';
  959     };
  960     my @bind_params = ($user_id, $user_id);
  961 
  962     #$DEBUG && abslog("findAdminGroups: sql:\n\t".join("\n\t", split(/\n/,$sql)));
  963     return dbSelectColumn($sql, 'group_id', @bind_params);
  964 }
  965 
  966 sub findAdministratableObjects
  967 {
  968     my ($user_id, $op) = @_;
  969 
  970     my $su = isSuperuser($user_id);
  971 
  972     $su && return getPeople(0);
  973 
  974     # get a list of all objects in all groups administratable by $user_id
  975     my $sql = qq{
  976         SELECT DISTINCT go.object_id
  977         FROM
  978             c_access        AS a,
  979             v_object        AS o,
  980             v_group         AS g,
  981             c_group_object  AS go
  982         WHERE
  983             a.level         = 4             AND
  984             a.user_id       = ?             AND
  985             a.type          = 'group'       AND
  986             a.ref_id        = go.group_id;
  987     };
  988     my @objects = dbSelectColumn($sql, 'object_id', $user_id);
  989 
  990     my @new;
  991 
  992     #--------------------------------------------------------
  993     # to be allowed to delete an object, a group-admin must
  994     # have admin privs for all groups to which the object belongs
  995     #--------------------------------------------------------
  996     if ($op eq 'delete') {
  997         foreach my $object_id (@objects) {
  998             if (adminForAllGroups($user_id, $object_id)) {
  999                 push(@new, $object_id);
 1000             }
 1001         }
 1002         @objects = @new;
 1003     }
 1004     
 1005     @new = ();
 1006     #--------------------------------------------------------
 1007     my @super_users = getSuperusers();
 1008     foreach my $oid (@objects) {
 1009         my $o_uid = findUidForObject($oid);
 1010         if (defined($o_uid) && inListN($o_uid, \@super_users)) { next; }
 1011         push(@new, $oid);
 1012     }
 1013 
 1014     return @new;
 1015 }
 1016 
 1017 sub adminForAllGroups
 1018 {
 1019     my ($user_id, $object_id) = @_;
 1020 
 1021     # get groups for $user_id
 1022     my $sql = qq{
 1023         SELECT ref_id
 1024         FROM c_access AS a
 1025         WHERE
 1026             a.user_id   = ?         AND
 1027             a.level     = 4         AND
 1028             a.type      = 'group'   AND
 1029             a.ref_id    IS NOT NULL;
 1030     };
 1031     my @u_groups = dbSelectColumn($sql, 'ref_id', $user_id);
 1032 
 1033     my @o_groups = getObjectGroups($object_id);
 1034 
 1035     # is $user_id admin for all groups in which $object_id is member?
 1036     foreach my $o_gid (@o_groups) {
 1037         inListN($o_gid, \@u_groups) || return 0;
 1038     }
 1039     return 1;
 1040 }
 1041 
 1042 sub getSuperusers
 1043 {
 1044     my $sql = qq{
 1045         SELECT a.user_id
 1046         FROM
 1047             c_access AS a
 1048         WHERE
 1049             a.type  = 'group'   AND
 1050             a.magic = 'all';
 1051     };
 1052     return dbSelectColumn($sql, 'user_id');
 1053 }
 1054 
 1055 sub isSuperuser
 1056 {
 1057     my $user_id = shift;
 1058 
 1059     my $sql = qq{
 1060         SELECT id
 1061         FROM c_access AS a
 1062         WHERE
 1063             a.user_id   = ?         AND
 1064             a.level     = 4         AND
 1065             a.type      = 'group'   AND
 1066             a.magic     = 'all';
 1067     };
 1068     defined(dbSelect($sql, $user_id)) && return 1;
 1069     return 0;
 1070 }
 1071 
 1072 sub userHasMagicAccess
 1073 {
 1074     my ($uid, $type, $value) = @_;
 1075 
 1076     my $sql = qq{
 1077         SELECT level
 1078         FROM c_access
 1079         WHERE
 1080             user_id = ?         AND
 1081             type    = ?         AND
 1082             magic   = ?;
 1083     };
 1084 
 1085     my $ref = dbSelect($sql, $uid, $type, $value);
 1086     return defined($ref) ? $ref->{level} : undef;
 1087 }
 1088 
 1089 sub deleteGidInAcls
 1090 {
 1091     my $gid = shift;
 1092 
 1093     my $sql = qq{
 1094         DELETE FROM c_access
 1095         WHERE ref_id = ?
 1096         AND type = 'group';
 1097     };
 1098     $DBH->do($sql, undef, $gid);
 1099 }
 1100 
 1101 sub deletePidInAcls
 1102 {
 1103     my $pid = shift;
 1104 
 1105     my $sql = qq{
 1106         DELETE FROM c_access
 1107         WHERE ref_id = ?
 1108         AND type = 'object';
 1109     };
 1110     $DBH->do($sql, undef, $pid);
 1111 }
 1112 
 1113 sub deleteUserIdInAcls
 1114 {
 1115     my $uid = shift;
 1116 
 1117     my $sql = qq{
 1118         DELETE FROM c_access
 1119         WHERE user_id = ?;
 1120     };
 1121     $DBH->do($sql, undef, $uid);
 1122 }
 1123 
 1124 sub setAcls
 1125 {
 1126     my ($uid, $pacl_ref, $gacl_ref) = @_;
 1127 
 1128     # get rid of old ACLs
 1129     deleteUserIdInAcls($uid);
 1130 
 1131     my $sql = qq{
 1132         INSERT INTO c_access
 1133             (user_id, ref_id, type, magic, level)
 1134         VALUES
 1135             ($uid, ?, ?, ?, ?);
 1136     };
 1137     my $sth = $DBH->prepare($sql);
 1138     defined($sth) || die "prepare failed on sql [$sql]";
 1139 
 1140     my @params;
 1141     if (defined($pacl_ref)) {
 1142         foreach my $acl (@{ $pacl_ref }) {
 1143             if ($acl->{target} eq 'self') {
 1144                 @params = (undef, 'object', 'self', $acl->{level});
 1145             } elsif ($acl->{target} =~ /^\d+$/) {
 1146                 @params = ($acl->{target}, 'object', undef, $acl->{level});
 1147             } else {
 1148                 die "target [$acl->{target}] cannot be";
 1149             }
 1150             $sth->execute(@params);
 1151         }
 1152     }
 1153 
 1154     if (defined($gacl_ref)) {
 1155         foreach my $acl (@{ $gacl_ref }) {
 1156             if ($acl->{target} =~ /^(self|all)$/) {
 1157                 @params = (undef, 'group', $acl->{target}, $acl->{level});
 1158             } elsif ($acl->{target} =~ /^\d+$/) {
 1159                 @params = ($acl->{target}, 'group', undef, $acl->{level});
 1160             } else {
 1161                 die "target [$acl->{target}] cannot be";
 1162             }
 1163             $sth->execute(@params);
 1164         }
 1165     }
 1166 
 1167     $sth->finish;
 1168 }
 1169 
 1170 sub deleteElementN
 1171 {
 1172     my($elem, $lref) = @_;
 1173 
 1174     my $count = 0;
 1175     my $match = 0;
 1176     foreach my $tmp (@{$lref}) {
 1177         if ($tmp == $elem) {
 1178             $match = 1;
 1179             last;
 1180         }
 1181         $count++;
 1182     }
 1183 
 1184     if ($match) {
 1185         splice(@{$lref}, $count, 1);
 1186     }
 1187 }
 1188 
 1189 #--------------------------------------------------------------------
 1190 # Group stuff
 1191 #--------------------------------------------------------------------
 1192 
 1193 sub getGroups
 1194 {
 1195     my $sql = qq{
 1196         SELECT id FROM v_group;
 1197     };
 1198     my $aref = $DBH->selectcol_arrayref($sql);
 1199     return @{$aref};
 1200 }
 1201 
 1202 #-------------------------------------------------------------
 1203 # getObjectGroups() get all groups to which an object belongs
 1204 #-------------------------------------------------------------
 1205 sub getObjectGroups
 1206 {
 1207     my $oid = shift;
 1208 
 1209     my $sql = qq{
 1210         SELECT group_id
 1211         FROM c_group_object
 1212         WHERE object_id = ?;
 1213     };
 1214 
 1215     return dbSelectColumn($sql, 'group_id', $oid);
 1216 }
 1217 
 1218 sub getGroup
 1219 {
 1220     my ($gid, $field) = @_;
 1221     
 1222     if (!groupExists(id => $gid)) {
 1223         #print "no group with ID=[$gid]\n";
 1224         return undef;
 1225     }
 1226     
 1227     my $sql = qq{
 1228         SELECT *
 1229         FROM v_group
 1230         WHERE id = ?;
 1231     };
 1232     my $ref = dbSelect($sql, $gid);
 1233 
 1234     if ($field) {
 1235         exists($ref->{$field}) || die "field [$field] unknown in group";
 1236         return $ref->{$field};
 1237     }
 1238 
 1239     return $ref;
 1240 }
 1241 
 1242 sub groupCount
 1243 {
 1244     my $sql = qq{SELECT id FROM v_group;};
 1245     my @list = dbSelect($sql);
 1246     return scalar(@list);
 1247 }
 1248 
 1249 #--------------------------------------------------------------------
 1250 # user stuff
 1251 #--------------------------------------------------------------------
 1252 
 1253 sub getUser
 1254 {
 1255     my ($thing, $val, $field) = @_;
 1256 
 1257     my $sql = qq{
 1258         SELECT *
 1259         FROM v_user
 1260         WHERE $thing = ?;
 1261     };
 1262     my $ref = dbSelect($sql, $val);
 1263     defined($ref) || return undef;
 1264 
 1265     if ($field) {
 1266         exists($ref->{$field}) || die "field [$field] unknown in c_user";
 1267         return $ref->{$field};
 1268     }
 1269 
 1270     return $ref;
 1271 }
 1272 
 1273 #--------------------------------------------------------------------
 1274 # getUsers()
 1275 # 
 1276 # if first param is 'all', then returns a list of all user IDs known
 1277 # with no params, returns a list of user IDs for users not associated
 1278 # with objects
 1279 #--------------------------------------------------------------------
 1280 sub getUsers
 1281 {
 1282     my $all = shift;
 1283 
 1284     my $sql;
 1285     if ($all eq 'all') {
 1286         $sql = qq{ SELECT id FROM v_user; };
 1287     } else {
 1288         $sql = qq{
 1289             SELECT v_user.id
 1290             FROM v_user
 1291             WHERE v_user.object_id IS NULL;
 1292         };
 1293     }
 1294     my $aref = $DBH->selectcol_arrayref($sql);
 1295     defined($aref) && return (@{$aref});
 1296     return ();
 1297 }
 1298 
 1299 #-------------------------------------------------------------
 1300 # getUserGroups() get all groups to which a user's object belongs
 1301 #-------------------------------------------------------------
 1302 sub getUserGroups
 1303 {
 1304     my $uid = shift;
 1305 
 1306     my $sql = qq{
 1307         SELECT go.group_id
 1308         FROM
 1309             c_group_object  AS go,
 1310             v_user          AS u
 1311         WHERE
 1312             u.id            = ? AND
 1313             go.object_id    = u.object_id;
 1314     };
 1315 
 1316     return dbSelectColumn($sql, 'group_id', $uid);
 1317 }
 1318 
 1319 # ROBBO: check what callers of setPassword expect to pass as uid...
 1320 sub setPassword
 1321 {
 1322     my ($uid, $password) = @_;
 1323 
 1324     $DEBUG && abslog(["changePassword: start: user_id=[$uid]",
 1325         "password=[$password]"]);
 1326 
 1327     #my $ret = checkLengths('c_user', {
 1328     #   password    => $password,
 1329     #};
 1330     #$ret && return "baddata: $ret";
 1331 
 1332     if (!userExists(id => $uid)) {
 1333         return 'disappeared';
 1334     }
 1335 
 1336     my $new_pw = ($PW_HASH_FORMAT eq 'md5')
 1337         ? md5_base64($password)
 1338         : $password;
 1339 
 1340     if ($CRED_SRC eq 'absence') {
 1341         my $sql = qq{
 1342             UPDATE c_user SET password = ? WHERE id = ?;
 1343         };
 1344         $DBH->do($sql, undef, $new_pw, $uid);
 1345     } elsif ($CRED_SRC eq 'htaccess') {
 1346         # TODO
 1347         my $ret = setHtaccessPassword($uid, $password);
 1348         if ($ret) { return 'error'; }
 1349     } else {
 1350         die "unimplemented method [$CRED_SRC]";
 1351     }
 1352 
 1353     return 'ok';
 1354 }
 1355 
 1356 #--------------------------------------------------------------------
 1357 # setHtaccessPassword() is an EXAMPLE of how you could
 1358 # implement password management for HTTP authentication.
 1359 # Unless you're using SSL, using this method means you
 1360 # will be sending cleartext passwords over the network.
 1361 # If you do not want to use absence to manage your passwords
 1362 # (for example if you are using HTTP Digest authentication
 1363 # in order to avoid sending cleartext passwords over the
 1364 # network) then you should set "manage_password" in the
 1365 # configuration to "no".  You will need to come up with
 1366 # your own method of managing passwords.
 1367 #--------------------------------------------------------------------
 1368 sub setHtaccessPassword
 1369 {
 1370     my ($uid, $password) = @_;
 1371 
 1372     my $username = getUser(id => $uid, 'username');
 1373 
 1374     my $htaccess = AbsenceConfig::fetch('htaccess_path');
 1375     my @cmd = ('htpasswd', '-b', $htaccess, $username, $password);
 1376 
 1377     #dbg("running cmd: ".join(' ', @cmd);
 1378 
 1379     my ($wfh, $rfh);
 1380     my $pid = open3($wfh, $rfh, undef, @cmd);
 1381     close($wfh);
 1382     my $out;
 1383     while(<$rfh>) {
 1384         $out .= $_;
 1385     }
 1386     close($rfh);
 1387 
 1388     waitpid($pid, 0);
 1389     my $status = $? >> 8;
 1390     chomp($out);
 1391 
 1392     #dbg("output: [$out]");
 1393 
 1394     if ($status) {
 1395         abslog("setHtaccessPassword: external command failed. rc=$status, output:\n$out");
 1396     }
 1397     return $status;
 1398 }
 1399 
 1400 # ROBBO: modify callers of modifyUser() to pass uid and not username
 1401 sub modifyUser
 1402 {
 1403     my ($uid, $username, $password, $pacl, $gacl) = @_;
 1404 
 1405     $DEBUG && abslog(["modifyUser: start: user_id=[$uid]",
 1406         "password=[$password]",
 1407         "pacl=[$pacl]", "gacl=[$gacl]"]);
 1408 
 1409     if (!userExists(id => $uid)) {
 1410         return 'disappeared';
 1411     }
 1412     my $u_ref = getUser('id' => $uid);
 1413 
 1414     my @fields;
 1415     my @bind_values;
 1416 
 1417     if ($MANAGE_PASSWORD eq 'yes') {
 1418         if ($u_ref->{password} ne $password) {
 1419             if ($CRED_SRC eq 'absence') {
 1420                 push(@fields, 'password = ?');
 1421                 push(@bind_values, ($PW_HASH_FORMAT eq 'md5')
 1422                     ? md5_base64($password)
 1423                     : $password,
 1424                 );
 1425             }
 1426             elsif ($CRED_SRC eq 'htaccess') {
 1427                 my $out = setHtaccessPassword($uid, $password);
 1428             }
 1429             else {
 1430                 die "unimplemented method [$CRED_SRC]";
 1431             }
 1432         }
 1433     }
 1434 
 1435     if ($u_ref->{username} ne $username) {
 1436         userExists(username => $username) && return 'duplicate';
 1437         #abslog("changing username from [$u_ref->{username}] to [$username]");
 1438         push(@fields, 'username = ?');
 1439         push(@bind_values, $username);
 1440     }
 1441 
 1442     if (@fields) {
 1443         my $fields = join(',', @fields);
 1444         push(@bind_values, $uid);
 1445 
 1446         my $sql = qq{
 1447             UPDATE c_user
 1448             SET $fields
 1449             WHERE id = ?;
 1450         };
 1451         $DBH->do($sql, undef, @bind_values);
 1452     }
 1453 
 1454     setAcls($uid, $pacl, $gacl);
 1455 
 1456     abslog([
 1457         "modify-user: username=[$u_ref->{username}]",
 1458         "new username=$username",
 1459         'pacl='.join(',', map { "$_->{level}:$_->{target}" } @{$pacl}),
 1460         'gacl='.join(',', map { "$_->{level}:$_->{target}" } @{$gacl}),
 1461     ]);
 1462 
 1463     return 'ok';
 1464 }
 1465 
 1466 #--------------------------------------------------------------------
 1467 # addUser()
 1468 # 
 1469 # add a 'user' entity to the DB, possibly also adding pacl/gacl records
 1470 # input:
 1471 # $pacl
 1472 #   a reference to an array of hashes of the form:
 1473 #   [
 1474 #       { level => <level>, oid => <oid> },
 1475 #       { level => <level>, oid => <oid> },
 1476 #   ...
 1477 #   ]
 1478 #   where <oid> is an object-ID (integer), or the string 'self',
 1479 #   and <level> is 1, 2, or 4 for read, write, and admin, respectively
 1480 # $gacl
 1481 #   a reference to an array of scalars of the form:
 1482 #   [
 1483 #       { level => <level>, gid => <oid> },
 1484 #       { level => <level>, gid => <oid> },
 1485 #   ...
 1486 #   ]
 1487 #   where <gid> is a group-ID, 'self', or 'all' and <level> is
 1488 #   1, 2, or 4, as above
 1489 #--------------------------------------------------------------------
 1490 sub addUser
 1491 {
 1492     my ($username, $password, $pacl, $gacl) = @_;
 1493 
 1494     $DEBUG && abslog(["addUser: start: user_id=[$username]",
 1495         "password=[$password]",
 1496         'pacl=['.acl2string($pacl).']', 'gacl=['.acl2string($gacl).']']);
 1497 
 1498     #my $ret = checkLengths('c_user', {
 1499     #   username    => $username,
 1500     #   password    => $password,
 1501     #};
 1502     #$ret && return "baddata: $ret";
 1503 
 1504     if (userExists(username => $username)) {
 1505         return 'duplicate';
 1506     }
 1507 
 1508     my $uid = _addUser(
 1509         username    => $username,
 1510         pw          => $password,
 1511         pacl        => $pacl,
 1512         gacl        => $gacl,
 1513     );
 1514 
 1515     abslog([
 1516         "add-user: username=[$username]",
 1517         #"password=[$password]",
 1518         'pacl='.join(',', map { "$_->{level}:$_->{target}" } @{$pacl}),
 1519         'gacl='.join(',', map { "$_->{level}:$_->{target}" } @{$gacl}),
 1520     ]);
 1521 
 1522     return wantarray ? ('ok', $uid) : 'ok';
 1523 }
 1524 
 1525 sub acl2string
 1526 {
 1527     my $acl_list = shift;
 1528 
 1529     return join(',', map { "$_->{level}:$_->{target}" } @{$acl_list});
 1530 }
 1531 
 1532 # ROBBO: check why I used _adduser() inside of adduser()
 1533 # answer: because I need it for addPerson too...
 1534 sub _addUser
 1535 {
 1536     #my ($username, $password, $pacl_ref, $gacl_ref, $oid) = @_;
 1537     my %args = @_;
 1538 
 1539     my @fields = qw(username);
 1540     my @values = ($args{username});
 1541 
 1542     if (defined($args{oid})) {
 1543         push(@fields, 'object_id');
 1544         push(@values, $args{oid});
 1545     }
 1546 
 1547     if ($CRED_SRC eq 'absence') {
 1548         my $pw = ($PW_HASH_FORMAT eq 'md5')
 1549             ? md5_base64($args{pw})
 1550             : $args{pw};
 1551         push(@fields, 'password');
 1552         push(@values, $pw);
 1553     } elsif ($CRED_SRC ne 'htaccess') {
 1554         die "unimplemented method [$CRED_SRC]";
 1555     }
 1556 
 1557     my $fields = join(',', @fields);
 1558     my $binds = join(',', map '?', @values);
 1559 
 1560     my $sql = qq{
 1561         INSERT INTO c_user
 1562         ($fields)
 1563         VALUES ($binds);
 1564     };
 1565 
 1566     my $uid = insertRowRetrieveSequence('c_user', $sql, @values);
 1567 
 1568     # now handle pacl/gacl
 1569     setAcls($uid, $args{pacl}, $args{gacl});
 1570 
 1571     if ($MANAGE_PASSWORD eq 'yes' && $CRED_SRC eq 'htaccess') {
 1572         my $ret = setHtaccessPassword($uid, $args{pw});
 1573         $ret && die "error while setting htaccess pw: $ret";
 1574     }
 1575 
 1576     return $uid;
 1577 }
 1578 
 1579 sub deleteAccessControlForUser
 1580 {
 1581     my $user_id = shift;
 1582 
 1583     my $sql = qq{
 1584         DELETE FROM c_access
 1585         WHERE user_id = ?;
 1586     };
 1587     $DBH->do($sql, undef, $user_id);
 1588 }
 1589 
 1590 sub deleteUser
 1591 {
 1592     my $uid = shift;
 1593 
 1594     $DEBUG && abslog("delete-user: user_id=[$uid]");
 1595 
 1596     _deleteUser($uid);
 1597 
 1598     return 'ok';
 1599 }
 1600 
 1601 sub _deleteUser
 1602 {
 1603     my $uid = shift;
 1604 
 1605     #my $now = time();
 1606 
 1607     # this must happen first!
 1608     deleteUserIdInAcls($uid);
 1609 
 1610     my $sql = qq{
 1611         DELETE FROM c_user WHERE id = ?;
 1612     };
 1613     $DBH->do($sql, undef, $uid);
 1614 }
 1615 
 1616 #--------------------------------------------------------------------
 1617 # person stuff
 1618 #--------------------------------------------------------------------
 1619 sub addPerson
 1620 {
 1621     #my ($pid, $name, $username, $email, $gref, $pw, $pacl, $gacl) = @_;
 1622     my %args = @_;
 1623 
 1624     #abslog("addPerson: Dump of args:\n".Dumper(\%args)."\n--DONE--");
 1625     $DEBUG && abslog(["addPerson: start: pid=[$args{pid}], name=[$args{name}]",
 1626         "username=[$args{username}]",
 1627         "email=[$args{email}]", "groups=[@{ $args{groups} }]"]);
 1628 
 1629     my $pid = $args{pid};
 1630     my $verb;
 1631     my $old_pw;
 1632     my $sql;
 1633     my $uid;
 1634 
 1635     if ($args{country_id} == 0) { abslog("setting country_id to NULL"); $args{country_id} = undef; }
 1636     if ($args{region_id} == 0) { $args{region_id} = undef; }
 1637 
 1638     if ($pid eq 'new') {
 1639         #-------------------------------------------------
 1640         # CREATE
 1641         #-------------------------------------------------
 1642         if (objectExists(name => $args{name})) {
 1643             return 'duplicate-name';
 1644         } elsif ($AUTH && $OAP && userExists(username => $args{username})) {
 1645             return 'duplicate-uid';
 1646         }
 1647         $verb = 'add-person';
 1648 
 1649         my @fields = ('name', 'email');
 1650         my @bind_params = ($args{name}, $args{email});
 1651 
 1652         if ($HOL_SCHEME eq 'advanced') {
 1653             push(@fields, 'country_id', 'region_id');
 1654             push(@bind_params, $args{country_id}, $args{region_id});
 1655         }
 1656 
 1657         my $fields = join(',', @fields);
 1658         my $binds = join(',', map '?', @bind_params);
 1659 
 1660         $sql = qq{
 1661             INSERT INTO c_object
 1662                 ($fields)
 1663             VALUES ($binds);
 1664         };
 1665 
 1666         $DBH->begin_work;
 1667         $pid = insertRowRetrieveSequence('c_object', $sql, $args{name}, $args{email});
 1668         #$DBH->do($sql, undef, @bind_params);
 1669 
 1670         my $xact_ok = 1;
 1671         if ($OAP && $AUTH) {
 1672             # RaiseError is set, so if _addUser fails, script
 1673             # will terminate, and trasaction will not be completed
 1674             $uid = _addUser(
 1675                 username    => $args{username},
 1676                 pw          => $args{pw},
 1677                 pacl        => $args{pacl},
 1678                 gacl        => $args{gacl},
 1679                 oid         => $pid,
 1680             );
 1681         }
 1682         addGroupMappings($pid, @{ $args{groups} });
 1683         $DBH->commit;
 1684     } else {
 1685         #-------------------------------------------------
 1686         # UPDATE
 1687         #-------------------------------------------------
 1688         if (!objectExists(id => ${pid})) {
 1689             die "error: attempt to modify a non-existent person [${pid}]";
 1690         }
 1691         $verb = 'modify-person';
 1692 
 1693         #my $old_uname = getPerson($oid, 'name');
 1694         my @keys = ('name = ?', 'email = ?');
 1695         my @values = ($args{name}, $args{email});
 1696 
 1697         if ($HOL_SCHEME eq 'advanced') {
 1698             push(@keys, 'country_id = ?', 'region_id = ?');
 1699             push(@values, $args{country_id}, $args{region_id});
 1700         }
 1701         push(@values, $pid);
 1702 
 1703         $sql = qq{ UPDATE c_object SET };
 1704         $sql .= join(', ', @keys);
 1705         $sql .= qq{ WHERE id = ?; };
 1706 
 1707         $DBH->begin_work;
 1708         $DBH->do($sql, undef, @values);
 1709 
 1710         if ($OAP && $AUTH) {
 1711             $uid = findUidForObject(${pid});
 1712             if (defined($uid)) {
 1713                 my $rv = modifyUser($uid, $args{username}, $args{pw}, $args{pacl}, $args{gacl});
 1714                 if ($rv ne 'ok') {
 1715                     $DBH->rollback;
 1716                     return 'error';
 1717                 }
 1718             } else {
 1719                 if (userExists(username => $args{username})) {
 1720                     $DBH->rollback;
 1721                     return 'duplicate-username';
 1722                 }
 1723                 $uid = _addUser(
 1724                     username    => $args{username},
 1725                     pw          => $args{pw},
 1726                     pacl        => $args{pacl},
 1727                     gacl        => $args{gacl},
 1728                     oid         => ${pid},
 1729                 );
 1730             }
 1731         }
 1732         deleteGroupMappings(${pid});
 1733         addGroupMappings(${pid}, @{ $args{groups} });
 1734         $DBH->commit;
 1735     }
 1736 
 1737     abslog(["$verb: pid=[$pid]",
 1738         "name=[$args{name}]", "username=[$args{username}]",
 1739         "country-id=[$args{country_id}]", "region-id=[$args{region_id}]",
 1740         "email=[$args{email}]", "groups = [@{ $args{groups} }]"]);
 1741 
 1742     return wantarray ? ('ok', $pid, $uid) : 'ok';
 1743 }
 1744 
 1745 sub findUidForObject
 1746 {
 1747     my $oid = shift;
 1748 
 1749     my $sql = qq{
 1750         SELECT id
 1751         FROM v_user
 1752         WHERE object_id = ?;
 1753     };
 1754     my $ref = dbSelect($sql, $oid);
 1755     return defined($ref) ? $ref->{id} : undef;
 1756 }
 1757 
 1758 sub deletePerson
 1759 {
 1760     my $pid = shift;
 1761 
 1762     #abslog("deletePerson: deleting id=[$pid]");
 1763 
 1764     if (!objectExists(id => $pid)) {
 1765         abslog("deletePerson: id=[$pid] not found");
 1766         return 'bad-id';
 1767     }
 1768 
 1769     _deleteObject($pid);
 1770 
 1771     $AUTH && deletePidInAcls($pid);
 1772 
 1773     return 'ok';
 1774 }
 1775 
 1776 #----------------------------------------------------------------------
 1777 # this is the internal version.
 1778 #----------------------------------------------------------------------
 1779 sub _deleteObject
 1780 {
 1781     my $oid = shift;
 1782 
 1783     #----------------------------------------------------------
 1784     # delete all mappings for object
 1785     #----------------------------------------------------------
 1786     my $sql = qq{
 1787         DELETE FROM c_group_object
 1788         WHERE object_id = $oid;
 1789     };
 1790     $DBH->do($sql);
 1791 
 1792     #----------------------------------------------------------
 1793     # invalidate all reservations of this object
 1794     # well, actually, just delete the row.  someday I may use
 1795     # invalidation
 1796     #----------------------------------------------------------
 1797     #my $now = time();
 1798     #$sql = qq{
 1799     #   UPDATE d_reservation
 1800     #   SET invalidated = int2tsz($now)
 1801     #   WHERE object_id = $oid;
 1802     #};
 1803     $sql = qq{
 1804         DELETE FROM d_reservation
 1805         WHERE object_id = ?;
 1806     };
 1807     $DBH->do($sql, undef, $oid);
 1808 
 1809     #----------------------------------------------------------
 1810     # remember user-id for later
 1811     #----------------------------------------------------------
 1812     my $user_id = findUidForObject($oid);
 1813 
 1814     #----------------------------------------------------------
 1815     # remember name for logging
 1816     #----------------------------------------------------------
 1817     my $name = getPerson($oid, 'name');
 1818     abslog("deleting object: oid=[$oid], name=[$name]");
 1819 
 1820     #----------------------------------------------------------
 1821     # delete associated user, if necessary
 1822     # must be done *before* object is deleted
 1823     #----------------------------------------------------------
 1824     if ($OAP && $AUTH) {
 1825         if (!defined($user_id)) {
 1826             abslog("_deleteObject, deleted object [$oid], auth enabled, but no user_id found for that object");
 1827         }
 1828         _deleteUser($user_id);
 1829     }
 1830 
 1831     #----------------------------------------------------------
 1832     # delete row.  someday I may invalidate...
 1833     # 
 1834     #----------------------------------------------------------
 1835     #$sql = qq{
 1836     #   UPDATE c_object
 1837     #   SET invalidated = int2tsz($now)
 1838     #   WHERE id = $oid;
 1839     #};
 1840     #----------------------------------------------------------
 1841 
 1842     $sql = qq{
 1843         DELETE FROM c_object
 1844         WHERE id = ?;
 1845     };
 1846     $DBH->do($sql, undef, $oid);
 1847 }
 1848 
 1849 #----------------------------------------------------------------------
 1850 # addReservation()
 1851 #
 1852 # adds or modifies a reservation for a person.
 1853 # $start and $end are dates in the form
 1854 #   { day => $day, month => $month, year => $year }
 1855 #
 1856 #----------------------------------------------------------------------
 1857 
 1858 
 1859 sub addReservation
 1860 {
 1861     my ($res_id, $person_id, $start, $end, $type_id, $desc) = @_;
 1862 
 1863     my $s = "$start->{year}-$start->{month}-$start->{day}";
 1864     my $e = "$end->{year}-$end->{month}-$end->{day}";
 1865 
 1866     if ($DEBUG) {
 1867         abslog("addReservation: rid=$res_id, pid=$person_id, start=$s, end=$e, type_id=$type_id, desc=[$desc]");
 1868     }
 1869 
 1870     my $new = 0;
 1871     my $verb;
 1872     my $sql;
 1873     my ($old_s, $old_e);
 1874 
 1875     if ($res_id eq 'new') {
 1876         $new = 1;
 1877         $verb = 'add-reservation';
 1878     } else {
 1879         my $ref = getReservation($res_id);
 1880         if (!defined($ref)) {
 1881             abslog("error: attempt to modify non-existent reservation [$res_id]");
 1882             return ('disappeared');
 1883         }
 1884         # a reservation is being modified, I need the old start/end dates
 1885         $old_s = $ref->{start};
 1886         $old_e = $ref->{finish};
 1887         $verb = 'modify-reservation';
 1888         $DEBUG && abslog("old: start=$ref->{start}, finish=$ref->{finish}");
 1889     }
 1890 
 1891     #----------------------------------------------------------
 1892     # check if either starting or ending day is past end of
 1893     # corresponding month...
 1894     #----------------------------------------------------------
 1895     if (($start->{day} > AbsenceDate::daysInMonth($start->{month})) ||
 1896         ($end->{day} > AbsenceDate::daysInMonth($end->{month})))
 1897     {
 1898         return ('badday');
 1899     }
 1900 
 1901     my $sjd = AbsenceDate::julianDay($start);
 1902     my $ejd = AbsenceDate::julianDay($end);
 1903     ($sjd > $ejd) && return ('impossible');
 1904 
 1905     #my ($ret, $id) = resConflict($res_id, $person_id, $start, $end, $type_id);
 1906     my $ret = resConflict($res_id, $person_id, $start, $end, $type_id);
 1907 
 1908     #($ret eq 'bad') && return ('conflict', $id);
 1909 
 1910     if (defined($ret)) {
 1911         abslog("resConflict found conflict");
 1912         return ('conflict', $ret);
 1913     }
 1914 
 1915     abslog(
 1916         [
 1917             "$verb: res=[$res_id]",
 1918             "person-id = [$person_id]",
 1919             "start = [$s]",
 1920             "end = [$e]",
 1921             "type = [$type_id]",
 1922             "desc = [$desc]",
 1923         ]
 1924     );
 1925 
 1926     _addReservation($res_id, $person_id, $start, $end, $type_id, $desc);
 1927 
 1928     my @o_groups = getObjectGroups($person_id);
 1929 
 1930     if (!$new) {
 1931         my $s = convToAbsenceDate($old_s);
 1932         my $e = convToAbsenceDate($old_e);
 1933         updateModificationTimes(\@o_groups, $s, $e);
 1934     }
 1935     updateModificationTimes(\@o_groups, $start, $end);
 1936 
 1937     $DEBUG && abslog("addReservation: success");
 1938 
 1939     return ('ok');
 1940 }
 1941 
 1942 #----------------------------------------------------------------------
 1943 # updateModificationTimes()
 1944 #
 1945 # parameters:
 1946 #   $s, $e references to dates in the form:
 1947 #       [<day>, <month>, <year>]
 1948 #----------------------------------------------------------------------
 1949 
 1950 sub updateModificationTimes
 1951 {
 1952     # ROBBO TODO: check format of $s and $e
 1953 
 1954     my ($gref, $s, $e) = @_;
 1955 
 1956     if ($DEBUG) {
 1957         my $tmp = join(',', @{$gref});
 1958         my $start = "$s->{month}/$s->{year}";
 1959         my $end = "$e->{month}/$s->{year}";
 1960         abslog("updateModificationTimes: grps: [$tmp], s: [$start], e: [$end]");
 1961     }
 1962 
 1963     # modify in-memory hash
 1964     my $month = $s->{month};
 1965     my $year = $s->{year};
 1966 
 1967     my $end = $e->{year} * 12 + $e->{month};
 1968 
 1969     my $now = time();
 1970 
 1971     while(($year*12+$month) <= $end) {
 1972         $DEBUG && abslog("updModTime: updating y=$year, m=$month");
 1973         foreach my $gid (@{$gref}) {
 1974             updateMonthModTime($gid, $month, $year);
 1975         }
 1976         if ($month == 12) {
 1977             $year++;
 1978             $month = 1;
 1979         } else {
 1980             $month++;
 1981         }
 1982     }
 1983 }
 1984 
 1985 sub updateMonthModTime
 1986 {
 1987     my ($gid, $month, $year) = @_;
 1988 
 1989     my $now = time();
 1990 
 1991     my $update_sql = qq{
 1992         UPDATE d_group_mod_time
 1993         SET mod_time = $now
 1994         WHERE group_id = ?
 1995         AND month = ?
 1996         AND year = ?;
 1997     };
 1998     my $rv = $DBH->do($update_sql, undef, $gid, $month, $year);
 1999     defined($rv) || die "update mmt, rv=undef, sql=[$update_sql]";
 2000     if ($rv == 0) {
 2001         my $insert_sql = qq{
 2002             INSERT INTO d_group_mod_time
 2003             (group_id,month,year,mod_time)
 2004             VALUES (?,?,?,$now);
 2005         };
 2006         $rv = $DBH->do($insert_sql, undef, $gid, $month, $year);
 2007         defined($rv) || die "insert mmt, rv=undef, sql=[$insert_sql]";
 2008     }
 2009 }
 2010 
 2011 sub updateImageDimensions
 2012 {
 2013     my ($gid, $month, $year, $width, $height) = @_;
 2014 
 2015     my $update_sql = qq{
 2016         UPDATE d_group_mod_time
 2017         SET image_width = $width, image_height = $height
 2018         WHERE group_id = ?
 2019         AND month = ?
 2020         AND year = ?;
 2021     };
 2022     my $rv = $DBH->do($update_sql, undef, $gid, $month, $year);
 2023     defined($rv) || die "update mmt, rv=undef, sql=[$update_sql]";
 2024     if ($rv == 0) {
 2025         my $insert_sql = qq{
 2026             INSERT INTO d_group_mod_time
 2027             (group_id,month,year,image_width,image_height)
 2028             VALUES (?,?,?,$width,$height);
 2029         };
 2030         $rv = $DBH->do($insert_sql, undef, $gid, $month, $year);
 2031         defined($rv) || die "insert mmt, rv=undef, sql=[$insert_sql]";
 2032     }
 2033 }
 2034 
 2035 #------------------------------------------------------------------
 2036 # updateMonthModTimes()
 2037 #
 2038 # is passed the group-id and a structure of the form:
 2039 #   $ref = {
 2040 #       <year1> = {
 2041 #           <month1> = <time>,
 2042 #           <month2> = <time>,
 2043 #       },
 2044 #       <year2> = {
 2045 #           <month1> = <time>,
 2046 #           <month2> = <time>,
 2047 #       },
 2048 #   }
 2049 #------------------------------------------------------------------
 2050 sub updateMonthModTimes
 2051 {
 2052     my ($gid, $mref) = @_;
 2053 
 2054     foreach my $year (keys(%{$mref})) {
 2055         foreach my $month (keys(%{$mref->{$year}})) {
 2056             updateMonthModTime($gid, $month, $year);
 2057             $DEBUG && abslog("updating mmt for [gid=$gid,$month/$year]");
 2058         }
 2059     }
 2060 }
 2061 
 2062 sub getModificationTime
 2063 {
 2064     my ($gid, $month, $year) = @_;
 2065 
 2066     $DEBUG && abslog("getModificationTime: lookup: gid=$gid, m=$month, y=$year");
 2067 
 2068     my $sql = qq{
 2069         SELECT mod_time
 2070         FROM d_group_mod_time
 2071         WHERE group_id = ?
 2072         AND month = ?
 2073         AND year = ?;
 2074     };
 2075     my $ref = dbSelect($sql, $gid, $month, $year);
 2076 
 2077     if (defined($ref)) {
 2078         return $ref->{mod_time};
 2079     } else {
 2080         $DEBUG && abslog("getModificationTime: returning [undef]");
 2081         return undef;
 2082     }
 2083 }
 2084 
 2085 sub getImageDimensions
 2086 {
 2087     my ($gid, $month, $year) = @_;
 2088 
 2089     $DEBUG && abslog("getImageDimensions: lookup: gid=$gid, m=$month, y=$year");
 2090 
 2091     my $sql = qq{
 2092         SELECT image_width, image_height
 2093         FROM d_group_mod_time
 2094         WHERE group_id = ?
 2095         AND month = ?
 2096         AND year = ?;
 2097     };
 2098     my $ref = dbSelect($sql, $gid, $month, $year);
 2099 
 2100     if (defined($ref)) {
 2101         return ($ref->{image_width}, $ref->{image_height});
 2102     } else {
 2103         $DEBUG && abslog("getImageDimensions: returning [undef]");
 2104         return undef;
 2105     }
 2106 }
 2107 
 2108 sub deleteReservation
 2109 {
 2110     my $res_id = shift;
 2111 
 2112     my $res = getReservation($res_id);
 2113 
 2114     if (!defined($res)) {
 2115         # someone else got there first
 2116         abslog("deleteReservation: ID [$res_id] disappeared (overlapping ops)");
 2117         return 'conflict';
 2118     }
 2119 
 2120     my ($start, $end) = ($res->{start}, $res->{finish});
 2121 
 2122     my $pid = $res->{object_id};
 2123     #invalidateReservations(object_id => $res_id);
 2124     deleteReservations(id => $res_id);
 2125 
 2126     # piggy-back onto DB-lock
 2127     my @o_groups = AbsenceDB::getObjectGroups($pid);
 2128     my $s = convToAbsenceDate($res->{start});
 2129     my $e = convToAbsenceDate($res->{finish});
 2130     updateModificationTimes(\@o_groups, $s, $e);
 2131 
 2132     abslog("deleteReservation: res-id=[$res_id]");
 2133 
 2134     return 'ok';
 2135 }
 2136 
 2137 #----------------------------------------------------------------
 2138 # convToDbDate()
 2139 #
 2140 # input:
 2141 #   a reference to an array with form [ $day, $month, $year ]
 2142 #
 2143 # returns:
 2144 #   a string of form "YYYY-MM-DD"
 2145 #----------------------------------------------------------------
 2146 sub convToDbDate($)
 2147 {
 2148     #return join('-', reverse(@{ $_[0] }));
 2149     my $r = shift;
 2150     return join('-', $r->{year}, $r->{month}, $r->{day});
 2151 }
 2152 
 2153 #----------------------------------------------------------------
 2154 # convToAbsenceDate()
 2155 #
 2156 # does reverse of convToDbDate()
 2157 #----------------------------------------------------------------
 2158 sub convToAbsenceDate($)
 2159 {
 2160     my ($year, $mon, $day) = split('-', $_[0]);
 2161     #return ( $day, $mon, $year );
 2162     return { day => int($day), month => int($mon), year => $year };
 2163 }
 2164 
 2165 sub resConflict
 2166 {
 2167     my ($res_id, $pid, $start, $end, $type_id) = @_;
 2168 
 2169     #abslog("resConflict: res-id=[$res_id]");
 2170 
 2171     if (!$MULTI_RES) {
 2172         my $db_start = convToDbDate($start);
 2173         my $db_finish = convToDbDate($end);
 2174 
 2175         my @bind_params = ($pid);
 2176         my $avoid_existing_res;
 2177         if ($res_id =~ /^\d+$/) {
 2178             $avoid_existing_res = qq{(id != ?) AND};
 2179             push(@bind_params, $res_id);
 2180         }
 2181         my $sql = qq{
 2182             SELECT id
 2183                 FROM v_reservation
 2184             WHERE
 2185                 (object_id = ?) AND $avoid_existing_res (
 2186                     (start  >= ? AND start <= ?) OR
 2187                     (finish >= ? AND start <= ?) OR
 2188                     (start  <  ? AND finish > ?)
 2189             );
 2190         };
 2191         my @tmp = ($db_start, $db_finish);
 2192         push(@bind_params, @tmp, @tmp, @tmp);
 2193 
 2194         my $ref = dbSelect($sql, @bind_params);
 2195         #$DEBUG && abslog("SQL: $sql");
 2196 
 2197         return defined($ref) ? { type => 'simple', res => $ref } : undef;
 2198     }
 2199 
 2200     #------------------------------------------------------------
 2201     # multiple reservations are enabled
 2202     #------------------------------------------------------------
 2203 
 2204     my ($month, $year) = ($start->{month}, $start->{year});
 2205     my $jm_end = $end->{year} * 12 + $end->{month};
 2206     my $jm;
 2207     my $conflict;
 2208     do {
 2209         my ($sd, $ed)
 2210             = getMonthBounds($start, $end, $month, $year);
 2211         my $myres = {
 2212             res     => { id => $res_id, type_id => $type_id },
 2213             bounds  => { start => $sd, end => $ed },
 2214         };
 2215         $jm = $year * 12 + $month;
 2216         my @mres_list = getMonthReservations($pid, $month, $year);
 2217         my @orig_list = @mres_list;
 2218 
 2219         #----------------------------------------------------------
 2220         # if I am modifying a reservation, I need to remove the old
 2221         # reservation from the list to check
 2222         #----------------------------------------------------------
 2223         if ($res_id ne 'new') {
 2224             my @tmp;
 2225             foreach my $mres (@mres_list) {
 2226                 if ($mres->{res}->{id} != $res_id) {
 2227                     push(@tmp, $mres);
 2228                     #abslog("  adding id=[$mres->{res}->{id}] to list to check");
 2229                 }
 2230             }
 2231             @mres_list = @tmp;
 2232         }
 2233 
 2234         push(@mres_list, $myres);
 2235         my $layout = AbsenceImage::layoutObjectRow(\@mres_list, $month, $year);
 2236         #---------------------------------------------------------
 2237         # check if row would grow beyond allowed boundary
 2238         #---------------------------------------------------------
 2239         my $max_slot = $MAX_MULTI * $FULL_SLOTS - 1;
 2240         if ($layout->{last_slot} > $max_slot) {
 2241             # must check if result would be same without new res
 2242             my $lo2 = AbsenceImage::layoutObjectRow(\@orig_list, $month, $year);
 2243             if ($lo2->{last_slot} != $layout->{last_slot}) {
 2244                 #$conflict = { type => 'height' };
 2245                 #last;
 2246                 return {
 2247                     type    => 'no_space',
 2248                     month   => $month,
 2249                     year    => $year,
 2250                 };
 2251             }
 2252         }
 2253 
 2254         #---------------------------------------------------------
 2255         # check if there is any illegal coincidence
 2256         #---------------------------------------------------------
 2257         my $type_class = getTypeClass($type_id);
 2258 
 2259         if (defined($layout->{error})) {
 2260             foreach my $err (@{ $layout->{error} }) {
 2261                 if ($type_class eq 'block') {
 2262                     if ($err->{type} eq 'b_coincidence' &&
 2263                         ($err->{ids}->[0] eq $res_id ||
 2264                         $err->{ids}->[1] eq $res_id))
 2265                     {
 2266                         return $err;
 2267                     }
 2268                 } else {
 2269                     if ($err->{type} eq 'nb_coincidence' &&
 2270                         ($err->{ids}->[0] eq $res_id ||
 2271                         $err->{ids}->[1] eq $res_id))
 2272                     {
 2273                         return $err;
 2274                     }
 2275                 }
 2276             }
 2277         }
 2278 
 2279         if ($month == 12) {
 2280             $month = 1; $year++;
 2281         } else {
 2282             $month++;
 2283         }
 2284     } while ($jm < $jm_end);
 2285 
 2286     return undef;
 2287 }
 2288 
 2289 sub _addReservation
 2290 {
 2291     my ($res_id, $person_id, $start, $end, $type_id, $desc) = @_;
 2292 
 2293     $DEBUG && abslog("_addReservation: res_id = [$res_id].");
 2294 
 2295     my $s = convToDbDate($start);
 2296     my $e = convToDbDate($end);
 2297 
 2298     my $sql;
 2299     my @bind_params;
 2300     if ($res_id eq 'new') {
 2301         $sql = qq{
 2302             INSERT INTO d_reservation
 2303             (object_id,type_id,start,finish,description)
 2304             VALUES (?,?,?,?,?);
 2305         };
 2306         @bind_params = ($person_id,$type_id,$s,$e,$desc);
 2307     } else {
 2308         $sql = qq{
 2309             UPDATE d_reservation
 2310             SET
 2311                 start       = ?,
 2312                 finish      = ?,
 2313                 type_id     = ?,
 2314                 description = ?
 2315             WHERE id = ?;
 2316         };
 2317         @bind_params = ($s, $e, $type_id, $desc, $res_id);
 2318     }
 2319 
 2320     return $DBH->do($sql, undef, @bind_params);
 2321 }
 2322 
 2323 sub timestamp
 2324 {
 2325     my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 2326     my ($sec,$min,$hour,$mday,$mon,$year,@junk) = localtime(time);
 2327 
 2328     return sprintf("%d-%s-%d %02d:%02d",
 2329         $mday, $months[$mon], $year+1900, $hour, $min);
 2330 }
 2331 
 2332 sub dbg
 2333 {
 2334     my $msg = shift;
 2335 
 2336     $DEBUG && abslog("DEBUG: $msg");
 2337 }
 2338 
 2339 #===========================================================================
 2340 #-------------------------------------------------------------------
 2341 # dbSelect()
 2342 #
 2343 # performs a generic query using fetchrow_hashref and returns:
 2344 #
 2345 #       (array context) references to the row-hashes
 2346 #       (scalar context) reference to first row
 2347 #
 2348 #-------------------------------------------------------------------
 2349 sub dbSelectColumn
 2350 {
 2351     my ($sql, $col, @bind_params) = @_;
 2352 
 2353     my $sth;
 2354     eval {
 2355         $sth = $DBH->prepare($sql);
 2356     };
 2357     if ($@) {
 2358         confess $@;
 2359     }
 2360     defined($sth) || die "prepare failed on sql [$sql]";
 2361 
 2362     $sth->execute(@bind_params) || confess "statement [$sql] failed";
 2363 
 2364     my @result;
 2365     while(defined($ref = $sth->fetchrow_hashref)) {
 2366         exists($ref->{$col}) || die "column [$col] unknown in sql [$sql]";
 2367         push(@result, $ref->{$col});
 2368     }
 2369 
 2370     @result;
 2371 }
 2372 
 2373 sub dbSelect
 2374 {
 2375     my ($sql, @bind_params) = @_;
 2376 
 2377     my $sth;
 2378     eval {
 2379         $sth = $DBH->prepare($sql);
 2380     };
 2381     if ($@) {
 2382         confess $@;
 2383     }
 2384     defined($sth) || die "prepare failed on sql [$sql]";
 2385 
 2386     $sth->execute(@bind_params) || confess "statement [$sql] failed";
 2387 
 2388     my @result;
 2389     my $ref;
 2390     while(defined($ref = $sth->fetchrow_hashref)) {
 2391         push(@result, $ref);
 2392     }
 2393 
 2394     if (wantarray) {
 2395         return @result;
 2396     } else {
 2397         @result || return undef;
 2398         return $result[0];
 2399     }
 2400 }
 2401 
 2402 sub executeStatement
 2403 {
 2404     my ($sql, @bind_params) = shift;
 2405 
 2406     $DEBUG && abslog("   execing statement: $sql");
 2407     $FAKE && return 1;
 2408 
 2409     my $rv;
 2410     eval {
 2411         $rv = $DBH->do($sql, undef, @bind_params);
 2412     };
 2413     if ($@) {
 2414         confess "SQL statement failed: [$sql]";
 2415     }
 2416 
 2417     #if (!$rv) {
 2418     #   confess "statement [$sql] failed";
 2419     #}
 2420 
 2421     defined($rv) || return undef;
 2422     ($rv eq '0E0') && return 0;
 2423     return $rv;
 2424 }
 2425 
 2426 sub insertRowRetrieveSequence
 2427 {
 2428     my ($table, $sql, @bind_params) = @_;
 2429 
 2430     $DEBUG && abslog("   insertRowRetrieveSequence: $sql");
 2431     $FAKE && return 1;
 2432 
 2433     my ($rv, $sth);
 2434 
 2435     eval {
 2436         $sth = $DBH->prepare($sql);
 2437     };
 2438     if ($@) {
 2439         confess "SQL prepare failed: [$sql]";
 2440     }
 2441     defined($sth) || die "prepare failed on sql [$sql]";
 2442 
 2443     $sth->execute(@bind_params) || confess "statement [$sql] failed";
 2444 
 2445     $sth->finish;
 2446 
 2447     #----------------------------------------------------------
 2448     # get sequence number
 2449     #----------------------------------------------------------
 2450     my $sequence = "${table}_id_seq";
 2451     $sth = $DBH->prepare("SELECT currval('$sequence');");
 2452     $sth->execute || confess "statement [SELECT currval('$sequence');] failed";
 2453 
 2454     my $id = ($sth->fetchrow_array)[0];
 2455     defined($id) || confess "no ID returned.";
 2456     return $id;
 2457 }
 2458 
 2459 #=======================================================================
 2460 # Absence-Type stuff
 2461 #=======================================================================
 2462 # ROBBO
 2463 sub getTypes
 2464 {
 2465     my $arg = shift;
 2466 
 2467     my $sql;
 2468     if ($arg eq 'invalid') {
 2469         $sql = qq{
 2470             SELECT * FROM c_reservation_type WHERE invalidated IS NOT NULL;
 2471         };
 2472     } elsif ($arg eq 'all') {
 2473         $sql = qq{
 2474             SELECT * FROM c_reservation_type;
 2475         };
 2476     } else {
 2477         $sql = qq{
 2478             SELECT * FROM v_reservation_type;
 2479         };
 2480     }
 2481 
 2482     my @list = dbSelect($sql);
 2483 }
 2484 
 2485 sub getType
 2486 {
 2487     my $type_id = shift;
 2488 
 2489     my $sql = qq{ SELECT * FROM c_reservation_type WHERE id = ?; };
 2490     return dbSelect($sql, $type_id);
 2491 }
 2492 
 2493 sub getTypeClass
 2494 {
 2495     my $type_id = shift;
 2496 
 2497     my $ref = getType($type_id);
 2498     return ($ref->{height} eq 'block') ? 'block' : 'non_block';
 2499 }
 2500 
 2501 
 2502 sub queryTypeName
 2503 {
 2504     my ($name, $arg, $ignore) = @_;
 2505 
 2506     my $table = ($arg eq 'invalid')
 2507         ? 'c_reservation_type'
 2508         : 'v_reservation_type';
 2509 
 2510     my $sql;
 2511     my @bind_params;
 2512     if (defined($ignore)) {
 2513         $sql = qq{ SELECT id FROM $table WHERE name = ? AND id != ?; };
 2514         @bind_params = ($name, $ignore);
 2515     } else {
 2516         $sql = qq{ SELECT id FROM $table WHERE name = ?; };
 2517         @bind_params = ($name);
 2518     }
 2519 
 2520     return dbSelect($sql, @bind_params);
 2521 }
 2522 
 2523 sub modifyType
 2524 {
 2525     my $ref = shift;
 2526 
 2527     my $sql;
 2528 
 2529     $DBH->begin_work;
 2530     if ($ref->{default_type}) {
 2531         # first 
 2532         $sql = qq{
 2533             UPDATE c_reservation_type
 2534             SET default_type = FALSE
 2535             WHERE default_type = TRUE;
 2536         };
 2537         if (!defined($DBH->do($sql))) {
 2538             die "modifyType (remove default) failed";
 2539         }
 2540     }
 2541 
 2542     my @pairs;
 2543     my @bind_params;
 2544     foreach my $key (keys(%{ $ref })) {
 2545         next if ($key eq 'id');
 2546         push(@pairs, "$key = ?");
 2547         push(@bind_params, $ref->{$key});
 2548     }
 2549     my $pairs = join(',', @pairs);
 2550     $sql = qq{
 2551         UPDATE c_reservation_type
 2552         SET $pairs
 2553         WHERE id = $ref->{id};
 2554     };
 2555     if (!defined($DBH->do($sql, undef, @bind_params))) {
 2556         $DBH->rollback;
 2557         die "modifyType (modify) failed";
 2558     }
 2559     setTypeModTime();
 2560     $DBH->commit;
 2561 }
 2562 
 2563 sub addType
 2564 {
 2565     my $ref = shift;
 2566 
 2567     my (@fields, @values);
 2568 
 2569     foreach my $key (keys(%{ $ref })) {
 2570         push(@fields, $key);
 2571         push(@values, $ref->{$key});
 2572     }
 2573     my $fields = join(',', @fields);
 2574     my $binds = join(',', map '?', @values);
 2575 
 2576     my $sql = qq{
 2577         INSERT INTO c_reservation_type
 2578         ($fields)
 2579         VALUES ($binds);
 2580     };
 2581     my $tid = insertRowRetrieveSequence('c_reservation_type', $sql, @values);
 2582 
 2583     return $tid;
 2584 }
 2585 
 2586 sub deactivateType
 2587 {
 2588     my $type_id = shift;
 2589 
 2590     my $now = time();
 2591     my $sql = qq{
 2592         UPDATE c_reservation_type
 2593         SET invalidated = int2tsz($now)
 2594         WHERE id = ?;
 2595     };
 2596     $DBH->do($sql, undef, $type_id);
 2597 }
 2598 
 2599 sub reactivateType
 2600 {
 2601     my $type_id = shift;
 2602 
 2603     my $sql = qq{
 2604         UPDATE c_reservation_type
 2605         SET invalidated = NULL
 2606         WHERE id = ?;
 2607     };
 2608     $DBH->do($sql, undef, $type_id);
 2609 }
 2610 
 2611 
 2612 sub getTypeColor
 2613 {
 2614     my $type_id = shift;
 2615 
 2616     my $sql = qq{ SELECT * FROM v_reservation_type WHERE id = ?; };
 2617     my $type_ref = dbSelect($sql, $type_id);
 2618     defined($type_ref) || die "no type found with id=[$type_id]";
 2619 
 2620     return [
 2621         $type_ref->{color_red},
 2622         $type_ref->{color_green},
 2623         $type_ref->{color_blue},
 2624     ];
 2625 }
 2626 
 2627 sub getDefaultType
 2628 {
 2629     my $sql = qq{ SELECT * FROM v_reservation_type WHERE default_type = TRUE; };
 2630     my $type_ref = dbSelect($sql);
 2631     defined($type_ref) || return undef;
 2632 
 2633     return $type_ref;
 2634 }
 2635 
 2636 sub getTypeModTime
 2637 {
 2638     my $config_name = 'type-modification-time';
 2639 
 2640     return getConfigItem($config_name);
 2641 }
 2642 
 2643 sub setTypeModTime
 2644 {
 2645     my $config_name = 'type-modification-time';
 2646 
 2647     setConfigItem($config_name, time());
 2648 }
 2649 
 2650 sub resTypeCoincidenceAllowed
 2651 {
 2652     my ($type1, $type2) = @_;
 2653 
 2654     my @ids = ($type1 > $type2) ? ($type2, $type1) : ($type1, $type2);
 2655 
 2656     my $sql = qq{
 2657         SELECT id
 2658         FROM c_no_coincidence
 2659         WHERE type_id1 = ? AND type_id2 = ?;
 2660     };
 2661 
 2662     defined(dbSelect($sql, @ids)) && return 0;
 2663 
 2664     return 1;
 2665 }
 2666 
 2667 sub checkVorbidTypeCoincidence
 2668 {
 2669     my ($type1, $type2) = @_;
 2670 
 2671     my @ids = ($type1 > $type2) ? ($type2, $type1) : ($type1, $type2);
 2672 
 2673     my $sql = qq{
 2674         SELECT id
 2675         FROM c_no_coincidence
 2676         WHERE type_id1 = ? AND type_id2 = ?;
 2677     };
 2678 
 2679     return defined(dbSelect($sql, @ids)) ? 1 : 0;
 2680 }
 2681 
 2682 sub vorbidTypeCoincidence
 2683 {
 2684     my ($type1, $type2) = @_;
 2685 
 2686     my @ids = ($type1 > $type2) ? ($type2, $type1) : ($type1, $type2);
 2687 
 2688     my $sql = qq{
 2689         INSERT INTO c_no_coincidence
 2690         (type_id1, type_id2) VALUES (?,?);
 2691     };
 2692 
 2693     $DBH->do($sql, undef, @ids);
 2694 }
 2695 
 2696 sub purgeTypeCoincidenceEntries
 2697 {
 2698     my $type_id = shift;
 2699 
 2700     my $sql = qq{
 2701         DELETE FROM c_no_coincidence
 2702         WHERE type_id1 = ?
 2703         OR type_id2 = ?;
 2704     };
 2705 
 2706     $DBH->do($sql, undef, $type_id, $type_id);
 2707 }
 2708 
 2709 sub getTypeCoincidence
 2710 {
 2711     my $type_id = shift;
 2712 
 2713     my $sql = qq{
 2714         SELECT *
 2715         FROM c_no_coincidence
 2716         WHERE type_id1 = ?
 2717         OR type_id2 = ?;
 2718     };
 2719 
 2720     my @list = dbSelect($sql, $type_id, $type_id);
 2721     @list || return ();
 2722 
 2723     my @out;
 2724     foreach my $row (@list) {
 2725         push(@out, ($row->{type_id1} == $type_id)
 2726             ? $row->{type_id2}
 2727             : $row->{type_id1});
 2728     }
 2729 
 2730     return @out;
 2731 }
 2732 
 2733 
 2734 #=======================================================================
 2735 # Absence-Holiday stuff
 2736 #=======================================================================
 2737 
 2738 sub getHolidayList
 2739 {
 2740     my ($month, $year, %args) = @_;
 2741 
 2742     my $dim = AbsenceDate::daysInMonth($month, $year);
 2743     my $month_begin = "$year-$month-1";
 2744     my $month_end = "$year-$month-$dim";
 2745 
 2746     my $addit = '';
 2747     my @addit;
 2748     my @addit_binds;
 2749     
 2750     if (exists($args{region})) {
 2751         push(@addit, "region_id = ?");
 2752         push(@addit_binds, $args{region});
 2753     }
 2754     if (exists($args{country})) {
 2755         push(@addit, "country_id = ?");
 2756         push(@addit_binds, $args{country});
 2757     }
 2758     if (@addit) {
 2759         $addit = 'AND (' . join(' OR ', @addit) . ')';
 2760     }
 2761 
 2762     my $sql = qq{
 2763         SELECT * FROM c_holiday
 2764         WHERE
 2765             (day BETWEEN ? AND ?
 2766             OR day BETWEEN ? AND ?)
 2767             $addit
 2768         ORDER BY EXTRACT(DAY FROM day);
 2769     };
 2770     #abslog("%%% getHolidayList: SQL: [$sql]");
 2771 
 2772     # make sure last day in february, 0001 is 28
 2773     if ($month == 2) { $dim = 28; }
 2774 
 2775     my @bind_params = (
 2776         $month_begin, $month_end, "0001-$month-01", "0001-$month-$dim",
 2777         @addit_binds
 2778     );
 2779     my @list = dbSelect($sql, @bind_params);
 2780     my %unique;
 2781 
 2782     my @out;
 2783     #-----------------------------------------------------
 2784     # eliminate duplicate days (should not happen...) and
 2785     # format the way the pre-DB version did: a sorted array
 2786     # containing refs to
 2787     #   [ $day, $month, $year, $description ]
 2788     # (sorting is done in SQL query!)
 2789     #-----------------------------------------------------
 2790     foreach my $date (@list) {
 2791         my $dref = convToAbsenceDate($date->{day});
 2792         exists($unique{ $dref->{day} }) && next;
 2793         push(@out, [ $dref->{day}, $dref->{month}, $dref->{year}, $date->{description} ]);
 2794         $unique{ $dref->{day} } = 1;
 2795     }
 2796 
 2797     return @out;
 2798 }
 2799 
 2800 sub getRegionId
 2801 {
 2802     my $region_name = shift;
 2803 
 2804     my $sql = qq{
 2805         SELECT id
 2806         FROM c_region
 2807         WHERE LOWER(name) = LOWER(?);
 2808     };
 2809 
 2810     my $ref = dbSelect($sql, $region_name);
 2811     return defined($ref) ? $ref->{id} : undef;
 2812 }
 2813 
 2814 sub getCountryId
 2815 {
 2816     my ($field, $value) = @_;
 2817 
 2818     my $sql = qq{
 2819         SELECT id
 2820         FROM c_country
 2821         WHERE LOWER($field) = LOWER(?);
 2822     };
 2823 
 2824     my $ref = dbSelect($sql, $value);
 2825     return defined($ref) ? $ref->{id} : undef;
 2826 }
 2827 
 2828 sub getCountries
 2829 {
 2830     my $sql = qq{
 2831         SELECT id,name FROM c_country;
 2832     };
 2833 
 2834     my @list = dbSelect($sql);
 2835     return @list;
 2836 }
 2837 
 2838 sub getRegions
 2839 {
 2840     my $sql = qq{
 2841         SELECT id,name FROM v_region;
 2842     };
 2843 
 2844     my @list = dbSelect($sql);
 2845     return @list;
 2846 }
 2847 
 2848 
 2849 #=======================================================================
 2850 # config-items
 2851 #=======================================================================
 2852 
 2853 sub getConfigItem
 2854 {
 2855     my $name = shift;
 2856 
 2857     my $sql = qq{ SELECT * FROM c_config WHERE name = ?; };
 2858     my $config_item = dbSelect($sql, $name);
 2859     defined($config_item) || return undef;
 2860 
 2861     return $config_item->{content};
 2862 }
 2863 
 2864 sub setConfigItem
 2865 {
 2866     my ($name, $value) = @_;
 2867 
 2868     my $sql = qq{
 2869         UPDATE c_config SET content = ? WHERE name = ?;
 2870     };
 2871 
 2872     my $rv = $DBH->do($sql, undef, $value, $name);
 2873     if ($rv == 0) {
 2874         $sql = qq{
 2875             INSERT INTO c_config (name,content) VALUES (?,?);
 2876         };
 2877         defined($DBH->do($sql, undef, $name, $value))
 2878             || die "insert c_config, rv=undef, sql=[$sql]";
 2879     }
 2880 }
 2881 
 2882 #=======================================================================
 2883 # session functions
 2884 #=======================================================================
 2885 
 2886 sub checkSession
 2887 {
 2888 }
 2889 
 2890 sub getSession
 2891 {
 2892     my ($sid, $create) = @_;
 2893 
 2894     $SESSION_PARAMS[1] = $sid;
 2895 
 2896     my $session = CGI::Session->load(@SESSION_PARAMS)
 2897         or die CGI::Session->errstr;
 2898 
 2899     if ( $session->is_expired ) {
 2900         $DEBUG && abslog("sess expired");
 2901         $session->delete;
 2902         $session->flush;
 2903         $create || return undef;
 2904 
 2905         $session = $session->new(@SESSION_PARAMS);
 2906         $session->param(authed => 0);
 2907         $session->flush;
 2908     } elsif ( $session->is_empty ) {
 2909         $create || return undef;
 2910         $session = $session->new(@SESSION_PARAMS);
 2911         my $id = $session->id();
 2912         $DEBUG && abslog("session empty. created new ID=[$id], authed=0");
 2913         $session->param(authed => 0);
 2914         $session->flush;
 2915     } else {
 2916         my $id = $session->id();
 2917         my $authed = $session->param('authed');
 2918         $DEBUG && abslog("session still good, ID=[$id], authed=[$authed]");
 2919     }
 2920 
 2921     return $session;
 2922 }
 2923 
 2924 #=======================================================================
 2925 # old session functions
 2926 #=======================================================================
 2927 
 2928 sub old_checkSession
 2929 {
 2930     my ($user_id, $ip_addr) = @_;
 2931 
 2932     my $sql = qq{
 2933         SELECT id, tsz2int(t_stamp)
 2934         FROM d_session
 2935         WHERE user_id = ?
 2936         AND ip_addr = ?;
 2937     };
 2938 
 2939     # get record, if exists
 2940     my $ref = dbSelect($sql, $user_id, $ip_addr);
 2941     defined($ref) || return 'timeout';
 2942     
 2943     if ($SESSION_TIMEOUT == 0) { return 'ok'; }
 2944 
 2945     my $esecs = time();
 2946     $DEBUG && abslog("checkSession: now=[$esecs], db_time=[$ref->{tsz2int}]");
 2947     # check if timestamp is recent
 2948     if (($esecs - $ref->{tsz2int}) > $SESSION_TIMEOUT * 60) {
 2949         return 'timeout';
 2950     }
 2951 
 2952     # timestamp, is recent, so update it
 2953     $sql = qq{
 2954         UPDATE d_session
 2955         SET t_stamp = int2tsz($esecs)
 2956         WHERE id = $ref->{id};
 2957     };
 2958     $DBH->do($sql);
 2959 
 2960     return 'ok';
 2961 }
 2962 
 2963 sub addSession
 2964 {
 2965     my ($user_id, $ip_addr, $id) = @_;
 2966 
 2967     $DEBUG && abslog("addSession()\ntrying UPDATE");
 2968     my $esecs = time();
 2969     my @bind_params;
 2970     my $sql = qq{
 2971         UPDATE d_session
 2972         SET t_stamp = int2tsz($esecs)
 2973     };
 2974 
 2975     if (defined($id)) {
 2976         $sql .= "WHERE id = ?;";
 2977         @bind_params = ($ref->{id});
 2978     } else {
 2979         $sql .= "WHERE user_id = ? AND ip_addr = ?;";
 2980         @bind_params = ($user_id, $ip_addr);
 2981     }
 2982 
 2983     my $rv = $DBH->do($sql, undef, @bind_params);
 2984     $DEBUG && abslog("sql=[$sql], rv=[$rv]");
 2985     defined($rv) || die "update session, rv=undef, sql=[$sql]";
 2986     if ($rv == 0) {
 2987         $sql = qq{
 2988             INSERT INTO d_session
 2989             (user_id,ip_addr,t_stamp)
 2990             VALUES (?,?, int2tsz($esecs));
 2991         };
 2992         $rv = $DBH->do($sql, undef, $user_id, $ip_addr);
 2993         $DEBUG && abslog("trying INSERT. sql=[$sql]\nrv=[$rv]");
 2994         $rv || die "insert into d_session failed. user_id=$user_id, ip=$ip_addr, ts=$esecs";
 2995     }
 2996 }
 2997 
 2998 sub deleteSession
 2999 {
 3000     my ($user_id, $ip_addr, $id) = @_;
 3001 
 3002     my $sql = qq{
 3003         DELETE FROM d_session
 3004         WHERE user_id = ?
 3005         AND ip_addr = ?;
 3006     };
 3007     $DBH->do($sql, undef, $user_id, $ip_addr);
 3008 }
 3009 
 3010 #=======================================================================
 3011 # misc stuff
 3012 #=======================================================================
 3013 
 3014 sub superset
 3015 {
 3016     my ($gref1, $gref2) = @_;
 3017 
 3018     my $count = 0;
 3019     foreach my $mem (@{$gref2}) {
 3020         if (inListN($mem, $gref1)) {
 3021             $count++;
 3022         }
 3023     }
 3024 
 3025     dbg("superset: count=[$count], len(gref2) = [".@{$gref2}."]");
 3026     ($count == @{$gref2}) && return 1;
 3027     return 0;
 3028 }
 3029 
 3030 sub checkLengths
 3031 {
 3032     my ($table, $field_ref) = @_;
 3033 
 3034     my $out;
 3035     foreach my $field (%{ $field_ref }) {
 3036         my $content = $field_ref->{$field};
 3037         my $c_len = defined($content) ? length($content) : 0;
 3038         my $f_len = getFieldLength($table, $field);
 3039         defined($f_len) || next;
 3040         if ($c_len > $f_len) {
 3041             $out .= "field [$field] too long (max=$f_len).<BR>";
 3042         }
 3043     }
 3044 
 3045     return $out;
 3046 }
 3047 
 3048 #=======================================================================
 3049 # PostgreSQL specific stuff...
 3050 #=======================================================================
 3051 
 3052 sub getFieldDatatype
 3053 {
 3054     my ($table, $field) = @_;
 3055 
 3056     if (!exists($META{$table})) {
 3057         getTableMetadata($table);
 3058     }
 3059 
 3060     exists($META{$table}->{$field}) ||
 3061         confess "field [$field] not in table [$table]";
 3062 
 3063     return $META{$table}->{$field}->{type};
 3064 }
 3065 
 3066 sub getFieldLength
 3067 {
 3068     my ($table, $field) = @_;
 3069 
 3070     if (!exists($META{$table})) {
 3071         getTableMetadata($table);
 3072     }
 3073 
 3074     exists($META{$table}->{$field}) ||
 3075         die "field [$field] not in table [$table]";
 3076 
 3077     return $META{$table}->{$field}->{length};
 3078 }
 3079 
 3080 sub getTableMetadata
 3081 {
 3082     my $table = shift;
 3083 
 3084     my $sql = qq{
 3085         SELECT pg_attribute.attname,pg_attribute.atttypmod,pg_type.typname
 3086         FROM pg_class,pg_attribute,pg_type
 3087         WHERE pg_attribute.attnum > 0
 3088         AND pg_attribute.attrelid = pg_class.oid
 3089         AND pg_class.relname = '$table'
 3090         AND pg_attribute.atttypid = pg_type.oid;
 3091     };
 3092 
 3093     my @list = dbSelect($sql);
 3094     @list || die "table [$table] not found";
 3095 
 3096     my $length;
 3097     foreach my $ref (@list) {
 3098         # get length. totally non-portable.  pg_attribute.atttypmod stores
 3099         # the length (presumably) including internal length information
 3100         # of 4 bytes, which must be subtracted
 3101         $length = ($ref->{typname} eq 'varchar')
 3102             ? $length = $ref->{atttypmod} - 4
 3103             : undef;
 3104         $META{$table}->{$ref->{attname}} = {
 3105             type    => $ref->{typname},
 3106             length  => $length,
 3107         };
 3108     }
 3109 }
 3110 
 3111 1;
 3112 
 3113 __END__
 3114 
 3115 =head1 NAME
 3116 
 3117 AbsenceDB.pm - interface to absence database.
 3118 
 3119 =head1 WARNING
 3120 
 3121 this documentation isn't necessarily accurate.  If you need proper
 3122 documenation, get in touch with me, and I'll make more of an effort.
 3123 -RLU
 3124 
 3125 =head1 SYNOPSIS
 3126 
 3127   use AbsenceDB;
 3128 
 3129 
 3130 Operations on objects (people):
 3131 
 3132   @people_ids = getPeople($group_id);
 3133   
 3134   $ref        = getPerson($person_id);
 3135     or
 3136   $thing      = getPerson($person_id, 'field-name');
 3137 
 3138   $ref        = getGroup($group_id);
 3139     or
 3140   $thing      = getGroup($group_id, 'field-name');
 3141 
 3142   $result     = addPerson($person_id, $name, $username, $email,
 3143                 $group_ref, $password, $pacl, $gacl);
 3144 
 3145   $result     = deletePerson($person_id);
 3146 
 3147   $uid        = findUidForObject($oid);
 3148 
 3149 
 3150 Operations on reservations:
 3151 
 3152   @list    = getReservations($person_id);
 3153 
 3154   @list    = getMonthReservations($person_id, $month, $year);
 3155 
 3156   $res_ref = getReservation($reservation_id);
 3157 
 3158   $result  = addReservation($reservation_id, $start, $end, $type, $description);
 3159 
 3160   $result  = deleteReservation($reservation_id);
 3161 
 3162 
 3163 Operations on groups:
 3164 
 3165   $result    = addGroup($group_id, $group_name, $group_password, $description);
 3166 
 3167   $result    = deleteGroup($group_id);
 3168 
 3169   @group_ids = getGroups();
 3170 
 3171   $ref       = getGroup($group_id);
 3172     or
 3173   $thing     = getGroup($group_id, 'field-name');
 3174 
 3175   $number_of_groups = groupCount();
 3176 
 3177   $mod_time = getModificationTime($group_id, $month, $year);
 3178 
 3179   $result    = groupExists('field', 'value');
 3180 
 3181   addGroupMappings($object_id, @group_ids);
 3182   deleteGroupMappings($object_id, @group_ids);
 3183   removeObjectFromGroup(-pid => $object_id, -gid => $group_id);
 3184 
 3185 =head1 DESCRIPTION
 3186 
 3187 C<AbsenceDB.pm> is a crude interface to a database.  In theory, the
 3188 underlying database could be anything.  You have perhaps noticed that
 3189 elsewhere I refer to B<absences>, but here they are called
 3190 B<reservations>?  That came about as a result of my original intention
 3191 to keep the system generic, i.e., not necessarily only for people.
 3192 Along the way I apparently got a little confused.
 3193 
 3194 =head1 PERSON FUNCTIONS
 3195 
 3196 =over 4
 3197 
 3198 =item getPeople()
 3199 
 3200 returns a list of person_ids belonging to the specified group.
 3201 
 3202 =item getPerson()
 3203 
 3204 retrieves information about the specified person_id.  Without additional
 3205 parameters, returns a ref to a object-row from the DB.  With an optional
 3206 field-name as parameter, returns the value of that field.
 3207 
 3208 =item addPerson()
 3209 
 3210 creates a new person or modifies an existing one.  Parameters are
 3211 C<($person_id, $name, $email, $group_id)>.  If B<$person_id> equals
 3212 'new', a new person is created, otherwise B<$person_id> must
 3213 contain a valid person-id.  If an attempt is made to create a person
 3214 with the same name as an existing one, the operation fails and
 3215 the return-value is 'duplicate'.  On success returns 'ok'.
 3216 
 3217 =item deletePerson()
 3218 
 3219 guess what it does? Takes as single param a person-id.  Returns
 3220 'ok' on success, otherwise 'bad-id' if the person-id was not valid.
 3221 
 3222 
 3223 =head1 RESERVATION FUNCTIONS
 3224 
 3225 =item getReservations()
 3226 
 3227 returns a list of all reservations belonging to the specified person_id.
 3228 
 3229 =item getMonthReservations()
 3230 
 3231 finds all reservations for a given person_id in a given month and year.
 3232 returns a list of hash-refs of the form: 
 3233 
 3234   {
 3235     res    => reservation-row from DB,
 3236     bounds => {
 3237         start => start-day,
 3238         end   => end-day,
 3239     }
 3240   }
 3241     
 3242 =item getReservation()
 3243 
 3244 given a reservation-id it returns a reference to a reservation-row from
 3245 the DB, otherwise undef.
 3246 
 3247 =item addReservation()
 3248 
 3249 adds a new reservation, or modifies an existing one. Parameters
 3250 are C<($res_id, $person_id, $start, $end, $type, $desc)>. If
 3251 B<$res_id> equals 'new', a new reservation is created, otherwise
 3252 B<$res_id> must contain valid reservation-id.
 3253 
 3254 B<$start> and B<$end> must contain dates in the form "D.M.Y".
 3255 
 3256 Returns a list of two items:
 3257 
 3258 =over 4
 3259 
 3260 =item ('disappeared', '')
 3261 
 3262 someone else (presumably) deleted the absence in the meantime
 3263 
 3264 =item ('badday', '')
 3265 
 3266 the start or end day is invalid (i.e., February 30)
 3267 
 3268 =item ('impossible', '')
 3269 
 3270 the start-day is greater than the end-day.
 3271 
 3272 =item ('conflict', $res_id)
 3273 
 3274 there is a conflict with another reservation. B<$res_id> is the
 3275 reservation-id of the conflicting reservation.
 3276 
 3277 =item ('ok', '')
 3278 
 3279 success.
 3280 
 3281 =back
 3282 
 3283 =item deleteReservation()
 3284 
 3285 deletes a reservation.  Takes as single parameter a reservation-id.
 3286 
 3287 returns:
 3288 
 3289 =over 4
 3290 
 3291 =item internalerror
 3292 
 3293 The specified reservation-id does not exist.
 3294 
 3295 =item conflict
 3296 
 3297 The reservation-id disappeared suddenly.  Presumably someone else
 3298 got there before you.
 3299 
 3300 =item ok
 3301 
 3302 success.
 3303 
 3304 =back
 3305 
 3306 
 3307 =head1 GROUP FUNCTIONS
 3308 
 3309 =item addGroup()
 3310 
 3311 creates a new group or modifies an existing one.  parameters are
 3312 ($group_id, $name, $password).  If $group_id equals 'new', a new
 3313 group is created, otherwise $group_id must contain a valid group-id.
 3314 If an attempt is made to create a group with the same name as an
 3315 existing one, returns 'duplicate'.  Returns 'ok' on success.
 3316 
 3317 =item deleteGroup()
 3318 
 3319 guess what this does?  Takes as single parameter the group-id.  Returns
 3320 'ok' on success.
 3321 
 3322 =item getGroups()
 3323 
 3324 returns a list of group-ids corresponding to all existing groups.
 3325 
 3326 =item getGroup()
 3327 
 3328 retrieves information about a group.  Takes as single parameter
 3329 the group-id.  Return-value depends on context: in a scalar
 3330 context, returns group-name, in a list context returns 
 3331 a list consisting of B<($group_name, $group_password)>.
 3332 
 3333 =item getGroup()
 3334 
 3335 returns the group-id to which a person belongs.  Takes as single param
 3336 the person-id.
 3337 
 3338 =item groupCount()
 3339 
 3340 returns the number of defined groups.
 3341 
 3342 =item getModificationTime()
 3343 
 3344 retrieves modification time for a particular group for a particular
 3345 month, if one is known.  This allows C<absence.pl> to determine
 3346 if a month-image needs to be created anew.  Returns the time in
 3347 epoch-second format if available, otherwise undef.
 3348 
 3349 =back
 3350 
 3351 =head1 AUTHOR
 3352 
 3353 Robert Urban <urban@tru64.org>
 3354 
 3355 Copyright (C) 2003 Robert Urban
 3356 
 3357 =cut