"Fossies" - the Fresh Open Source Software Archive

Member "absence-v2.1/cgi-bin/foo" (20 Oct 2013, 71519 Bytes) of package /linux/www/web-absence-2.1.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

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