sub lodge : Local {
my ($self, $c, $id) = @_;
my $reg = model($c, 'Registration')->find($id);
my $pr = $reg->program();
my $PR = $pr->PR();
my $SG = $pr->SG();
my $program_id = $reg->program_id();
my %reserved_cids =
map {
$_->cluster_id() => 1
}
model($c, 'ProgramCluster')->search({
program_id => $program_id,
});
my $cutoff = (tt_today($c)+$string{make_up_clean_days})->as_d8();
# for makeup list checking
#
# housed with a friend who is also registered for this program?
#
my $share_house_id = 0;
my $share_house_name = "";
my $share_first = $reg->share_first();
my $share_last = $reg->share_last();
my $share_name = $share_first? "$share_first $share_last": '';
my $message2 = "";
my $reg2 = undef;
if ($share_first) {
my (@people) = model($c, 'Person')->search({
first => $share_first,
last => $share_last,
});
# there may be more than one person matching :(
# find the one (hopefully not > 1!) that is registered
# for this program.
#
PEOPLE:
for my $person (@people) {
($reg2) = model($c, 'Registration')->search({
person_id => $person->id(),
program_id => $program_id,
});
if ($reg2) {
last PEOPLE;
}
}
if (! @people) {
$message2 = "Could not find a person named $share_name.";
}
elsif (!$reg2) {
$message2 = "$share_name has not yet registered for "
. $reg->program->name . ".";
}
elsif ($reg2->cancelled()) {
$message2 = "$share_name has cancelled.";
}
elsif (! $reg2->house_id()) {
$message2 = "$share_name has not yet been housed.";
}
elsif ($reg2->h_type() ne $reg->h_type()) {
$message2 = "$share_name is housed in a '"
. $reg2->h_type_disp
. "' not a '"
. $reg->h_type_disp
. "'."
;
}
elsif ($reg2->person->sex() ne $reg->person->sex()
&& $reg2->h_type() =~ m{triple|dormitory|economy}i
) {
# if they're of opposite genders there is a
# further condition that they can't be in
# economy, dorm, or triple - because there may
# very well be strangers in there.
# If three (or more) people (not all of the same gender)
# wish to share a triple/dormitory/economy it can be
# FORCED for the unhoused person of a different gender
# than the person already housed.
#
$message2 = "Since "
. $reg->person->first()
. " and "
. $reg2->person->first()
. " are not of the same gender they cannot share<br>"
. $reg2->h_type()
. " housing in "
. $reg2->house->name()
. "."
. " This can be forced, if you wish."
;
}
else {
# okay! we will permit them to share.
#
$share_house_name = $reg2->house->name;
$share_house_id = $reg2->house_id;
$message2 = "Share $share_house_name"
." with $share_name?";
}
#
# if the person hasn't yet registered for this program
# look for them in the online files.
#
if ($message2 =~ m{Could not find|has not yet reg}) {
my $found = 0;
ONLINE:
for my $f (<$rst/online/*>) {
open my $in, "<", $f
or die "cannot open $f: $!\n";
# x_fname, x_lname - could be anywhere in the file
my ($found_first, $found_last) = (0, 0);
while (<$in>) {
if (m{x_fname => $share_first}i) {
$found_first = 1;
}
elsif (m{x_lname => $share_last}i) {
$found_last = 1;
}
}
close $in;
if ($found_first && $found_last) {
$message2 = "$share_name <b>has</b> registered"
. " online but has not yet been imported.";
$found = 1;
last ONLINE;
}
}
if (! $found) {
#
# make sure the confirmation note has a notice
# about their friend who has not yet registered.
#
if ($reg->confnote() !~ m{$share_name}) {
my $cn = ptrim($reg->confnote());
if ($cn) {
$cn .= "<p></p>";
}
$reg->update({
confnote => $cn
. "<p>$share_name still needs"
. " to register for this program!</p>",
});
}
}
}
}
my $sdate = $reg->date_start;
my $edate1 = (date($reg->date_end) - 1)->as_d8();
my $summer = ! wintertime($reg->date_start());
my $h_type = $reg->h_type;
my $bath = ($h_type =~ m{bath} )? 'yes': '';
my $tcabin = ($h_type =~ m{cabin} )? 'yes': '';
my $tent = ($h_type =~ m{tent} )? 'yes': '';
my $center = ($h_type =~ m{center} )? 'yes': '';
my $ht_cottage = $h_type !~ m{cottage} ? 0
:$h_type =~ m{cottage1}? 1
:$h_type =~ m{cottage2}? 2
: 3 # whole cottage
;
my $psex = $reg->person->sex;
my $max = type_max($h_type);
my $low_max = $max == 7? 4
:$max == 20? 8
: $max;
my $cabin = $reg->cabin_room() && $reg->cabin_room() eq 'cabin';
my @kids = ($reg->kids() && $reg->kids() =~ m{\d})? (cur => { '>', 0 })
: ();
my @h_opts = ();
my $n = 0;
my $selected = 0;
#
# which clusters are NOT available?
#
my %or_cids;
if ($PR || $SG) {
%or_cids = PR_other_reserved_cids($c, $reg->date_start(),
$reg->date_end() );
}
else {
%or_cids = other_reserved_cids($c, $pr);
}
#
# which clusters (and in what order) have
# been designated for this program?
#
CLUSTER:
for my $cl (@clusters) {
my $cl_id = $cl->id();
next CLUSTER if exists $or_cids{$cl_id};
#
# Can we eliminate this entire cluster
# due to the type of houses/sites in it?
#
# using the _name_ of the cluster
# is not the best idea but hey ...
# one _could_ put a tent and a room in the same cluster, right?
#
my $cl_name = $cl->name();
my $cl_tent = $cl_name =~ m{tent|terrace}i
&& $cl_name !~ m{structure}i;
my $cl_center_tent = $cl_name =~ m{center \s+ tent}xmsi;
my $cl_cottage = $cl_name =~ m{RAM}; # Only RAM is a cottage, yes?
if (($tent && !$cl_tent) ||
(!$tent && $cl_tent) ||
(!$ht_cottage && $cl_cottage) ||
($ht_cottage && !$cl_cottage) ||
(!$tent && $cl_tent) ||
($summer && (!$center && $cl_center_tent ||
$center && !$cl_center_tent ))
) {
next CLUSTER;
}
my $pr_resident = $pr->category->name() ne 'Normal';
HOUSE:
for my $h (@{$houses_in_cluster{$cl_id}}) {
# is the max of the house inconsistent with $max?
# or the bath status
# or the cabin status
#
# or the house resident status != program category status
#
# quads are okay when looking for a dorm
# and this takes some fancy footwork.
#
my $h_id = $h->id;
if (($h->max < $low_max)
|| ($h->bath && !$bath)
|| (!$h->bath && $bath)
|| ( $h->cabin && !$tcabin)
|| (!$h->cabin && $tcabin)
# cottage?
|| ($h->cottage != $ht_cottage) # house cottage is 0, 1, 2, or 3
#
|| (!$pr_resident && $h->resident())
# 9/4 Brajesh requests that all houses offered
# to Residential enrollees.
# || ($pr_resident && !$h->resident())
) {
next HOUSE;
}
my ($codes, $code_sum) = ("", 0);
#
# now we get current data from the database store.
#
# just search Config once???
# get all the records, then do the complex
# boolean below...
#
# AND why not just get ALL the config
# records for all the houses in the cluster?
# you're going to get them all anyway
# so why not get them all at once?
#
# well, the first search below eliminates
# the already fully occupied or gender inappropriate ones.
# and this is done within the database - reduces
# the data transfer.
# I _could_ have an 'in => []'
# and specify all the houses in the cluster
#
# is this house truly available for this
# request from sdate to edate1?
# look for ways in which it is NOT:
# - space
# - gender
# - room size
# - kids and cur > 0
#
my @cf = model($c, 'Config')->search({
house_id => $h_id,
the_date => { 'between' => [ $sdate, $edate1 ] },
-or => [
\'cur >= curmax', # all full up
-and => [ # can't mix genders
sex => { '!=', $psex }, # or put someone unsuspecting
sex => { '!=', 'U' }, # in an X room
sex => { '!=', 'B' }, #
],
curmax => { '<', $low_max }, # too small
-and => [ # can't resize - someone there
curmax => { '>', $max },
cur => { '>', 0 },
],
@kids, # kids => cur > 0
],
});
if (@cf) { # nope
next HOUSE;
}
# we have a good house.
# no problematic config records were found.
#
# what are the attributes of the configuration records?
#
# O - occupied (but there is space for more)
# F - a foreign program is already occupying this house
# R - resize is needed
#
# another attribute of the house may be that
# it still needs to be cleaned. only put this
# when the room is needed in 2 days or less.
#
# N - needs cleaning
#
my ($O, $F, $P) = (0, 0, 1);
for my $cf (model($c, 'Config')->search({
house_id => $h_id,
the_date => { 'between' => [ $sdate, $edate1 ] },
})
) {
if (!$O && $cf->cur() > 0) {
$O = 1;
if (!$F && $cf->program_id() != $program_id) {
$F = 1;
}
}
if ($P && $cf->curmax() > $max) {
$P = 0;
}
}
if ($O) {
$codes .= 'O';
$code_sum += $string{house_sum_occupied};
}
if ($F) {
$codes .= 'F';
$code_sum += $string{house_sum_foreign}; # discourage this!
# will be < 0.
}
if ($P) {
$code_sum += $string{house_sum_perfect_fit};
}
else {
$codes .= 'R'; # resize needed - not as good...
}
if ($reserved_cids{$cl_id}) {
$codes .= 'r';
$code_sum += $string{house_sum_reserved};
}
if ($h->cabin()) {
$codes .= 'C';
if ($cabin) {
$code_sum += $string{house_sum_cabin};
}
}
if ($h->cat_abode()) {
$codes .= 'c';
}
# check makeup list for $h_id on $sdate
#
if ($sdate <= $cutoff) {
my ($makeup) = model($c, 'MakeUp')->search({
house_id => $h_id,
});
if ($makeup) {
$codes .= 'N';
$code_sum += $string{house_sum_clean}; # negative
}
}
$codes = " - $codes" if $codes;
# put this house in an option array to be sorted according
# to priority. put the kind of house (resized,
# occupied, ...) in <option>
#
my $opt = "<option value="
. $h_id
. (($h_id == $share_house_id)? " selected"
: "")
. ">"
. $h->name()
. $codes
. "</option>\n"
;
push @h_opts, [ $opt, $code_sum, $h->priority(), $h->name() ];
++$n;
if ($h_id == $share_house_id) {
$selected = 1;
}
} # end of houses in this cluster
} # end of CLUSTER
#
# does the program have any Blocks that would
# be acceptable sized rooms?
# NOTE - this is only if the registrant is not arriving early
# or leaving late - because the blocks just span the program dates.
#
if (! $reg->early() && ! $reg->late()) {
my @blocks = $pr->blocks();
BLOCK:
for my $b (@blocks) {
my $h = $b->house();
my $h_id = $h->id();
if ($h->max < $low_max
|| ($h->bath && !$bath)
|| (!$h->bath && $bath)
) {
next BLOCK;
}
# tent?
if ($h->max >= $low_max) {
my $codes = ' - B';
my $code_sum = 1000;
if ($h->max > $max) {
$codes .= 'R';
$code_sum -= 5;
}
if ($h->cabin()) {
$codes .= 'C';
if ($cabin) {
$code_sum += $string{house_sum_cabin};
}
else {
$code_sum -= $string{house_sum_cabin};
}
}
# the value of the option is in two parts:
# house_id and block_id - separated by a dash.
my $opt = "<option value="
. "$h_id-" . $b->id
. (($h_id == $share_house_id)? " selected"
: "")
. ">"
. $h->name()
. $codes
. "</option>\n"
;
push @h_opts, [ $opt, $code_sum , $h->priority(), $h->name() ];
}
}
}
#
# and now the big sort:
#
if ($pr->category->name() ne 'Normal') {
@h_opts = map {
$_->[0]
}
sort {
$a->[3] cmp $b->[3] # by name
}
@h_opts;
}
else {
@h_opts = map {
$_->[0]
}
sort {
$b->[1] <=> $a->[1] || # 1st by code_sum - descending
$a->[2] <=> $b->[2] || # 2nd by priority - ascending
$a->[3] cmp $b->[3] # by name
}
@h_opts;
}
if ($cabin && $h_opts[0] !~ m{-.*C}) {
# they want a cabin and the first choice is not a cabin
# get any cabins to the top and preserve the order
my @rooms = ();
my @cabins = ();
for my $o (@h_opts) {
if ($o =~ m{-.*C}) {
push @cabins, $o;
}
else {
push @rooms, $o;
}
}
@h_opts = (@cabins, @rooms);
}
#
# enforce the max_lodge_opts (if non-zero)
# just truncate those beyond the stipulated max.
#
my $maxopts = $string{max_lodge_opts};
if ($maxopts && @h_opts > $maxopts) {
$#h_opts = $maxopts;
}
if ($share_house_id && ! $selected) {
# two people want to share a house.
# one of them is already housed.
# the room is not in the list because of the gender mismatch
# or a tent with nominally only one space
# or because the room is already full.
# yikes!
#
my @cf = model($c, 'Config')->search({
house_id => $share_house_id,
the_date => { 'between' => [ $sdate, $edate1 ] },
-or => [
\'cur >= curmax'
# could not put by itself! a one item or clause is needed?
],
});
if ($reg->h_type() !~ m{tent} && @cf) {
$message2 .= " - Yes, that would be nice but that room is already FULL!?";
}
else {
unshift @h_opts,
"<option value="
. $share_house_id
. " selected>"
. $share_house_name
. " - S"
. "</option>\n"
;
$selected = 1;
}
}
if (@h_opts && ! $selected) {
# no house is otherwise selected
# insert a select into the first one.
$h_opts[0] =~ s{>}{ selected>};
}
# include kids and housing prefs
if ($reg->kids()) {
if (my @ages = $reg->kids() =~ m{(\d+)}g) {
stash($c, kids => " with child" . ((@ages > 1)? "ren":""));
}
}
stash($c, house_prefs => "Housing choices: "
. _htrans($reg->pref1())
. ", "
. _htrans($reg->pref2())
);
my $cn = $reg->confnote();
# copied - can we consolidate???
# probably???
my $h_type_opts = "";
Global->init($c); # get %string ready.
my $cur_htype = $reg->h_type;
HTYPE:
for my $htname (housing_types(1)) {
next HTYPE if $htname eq "single_bath" && ! $pr->sbath;
next HTYPE if $htname eq "single" && ! $pr->single;
next HTYPE if $htname eq "economy" && ! $pr->economy;
next HTYPE if $htname eq "commuting" && ! $pr->commuting;
next HTYPE if $pr->housecost->$htname == 0; # wow!
next HTYPE if $htname eq 'center_tent' && !$summer;
my $selected = ($htname eq $cur_htype)? " selected": "";
my $htdesc = $string{$htname};
$htdesc =~ s{\(.*\)}{}; # registrar doesn't need this
$htdesc =~ s{Mount Madonna }{}; # ... Center Tent
$h_type_opts .= "<option value=$htname$selected>$htdesc\n";
}
# hacky :( how else please?
# these two would never be selected (or else we would
# not be lodging them...
#
$h_type_opts .= "<option value=unknown"
. ($cur_htype eq "unknown"? " selected"
: "" )
. ">Unknown\n";
$h_type_opts .= "<option value=not_needed"
. ($cur_htype eq "not_needed"? " selected"
: "" )
. ">Not Needed\n";
$h_type = _htrans($h_type);
my $p_sdate = $pr->sdate();
my $nmonths = date($pr->edate())->month()
- date($sdate)->month()
+ 1;
$sdate = date($sdate);
$edate1 = date($edate1);
my $n_nights = $edate1 - $sdate + 1;
my $pl = $n_nights == 1? "": "s";
stash($c,
reg => $reg,
n_nights => $n_nights . " night$pl",
sdate => $sdate,
edate => $reg->date_end_obj,
note => $cn,
note_lines => lines($cn) + 3,
message2 => $message2,
h_type => $h_type,
cal_param => "$p_sdate/$nmonths",
h_type_opts => $h_type_opts,
house_opts => join('', @h_opts),
total_opts => scalar(@h_opts),
seen_opts => $string{seen_lodge_opts},
disp_h_type => (($h_type =~ m{^[aeiou]})? "an": "a") . " '\u$h_type'",
daily_pic_date => ($pr->category->name() eq "Normal"? "indoors"
: "resident")
. "/"
. $reg->date_start(),
cluster_date => $reg->date_start(),
template => "registration/lodge.tt2",
);
}