############################################################ # # uber_pooclub.pl # # Provides client with poll handling pages # # daily - set a daily event # # ############################################################ require "uber/pooclub_oblongs.pl"; require "uber/pooclub_tests.pl"; ###require "uber/weekly_drivel.pl"; use Net::FTP; $MONDAY = "Mon"; # Must be "Mon" # Override oblong obliteration # "DEFAULT" - only obliterate on an obliteration date # "FORCE" - force obliteration today (for testing only) # "DISABLE" - don't do oblong obliterations at all (fall back) #$OVERRIDE_OBLIT = "FORCE"; $OVERRIDE_OBLIT = "DEFAULT"; $FISH = 27; ############################################################ # # Handle pooclub requests # ############################################################ sub uber_pooclub { check_for_daily_stuff(); my $message = ""; my $page = $cgi->param('page'); my $id = $cgi->param('id'); if ($cgi->param('voty_approve') eq "Submit") { process_voty_approve(); $page = "voty_all_noms"; } if ($cgi->param('setpoll') eq "Set Poll") { process_new_poll_notify(); } elsif ($cgi->param('postas')) # eq "Send") { process_postas_page(); # rename process_postas() ? } elsif ($cgi->param('topic')) # eq "Send") { process_topic(); } elsif ($cgi->param('complaint') eq "Whinge") { process_complaint(); } elsif ($cgi->param('caption') eq "Send") { # process_captionupload(); # doesn't work process_caption_ftp(); } elsif ($cgi->param('caption') eq "Post") { process_caption_url(); } elsif ($cgi->param('drivel_add') eq "Submit") { process_drivel_add(); } elsif (($cgi->param('drivel') eq "Add Drivel") || ($page eq "add_drivel")) { print_drivel_input_page(); } if ($cgi->param('cull_candidates') eq "Apply Changes") { process_cull_candidates(); $page = "cull_candidates"; } if ($cgi->param('topic_oblongs') eq "Update") { process_input_topic_oblongs(); } if ($cgi->param('poochoonz_oblongz') eq "Update") { process_input_poochoonz_oblongz(); } if ($cgi->param('give_oblongs') eq "Give") { process_give_oblongs(); # process_give_oblongs_new(); } if ($cgi->param('fine_oblongs') eq "Fine") { process_fine_oblongs(); # process_fine_oblongs_new(); } if ($cgi->param('buy_ticket') eq "Buy") { process_buy_ticket(); } # Which page should we print? if ($page eq "daily") { print_daily_page(); } elsif (($page eq "voty_my_noms") || ($cgi->param('voty_nominate'))) { print_voty_my_noms_page(); } elsif (($page eq "voty_all_noms") || ($page eq "voty") || ($cgi->param('voty_all_noms'))) { print_voty_all_noms_page(); } elsif ($page eq "voty_approve") { print_voty_approve_page(); } elsif ($page eq "topic") { print_topic_form_page(); } elsif ($page eq "caption") { print_caption_form_page(); } elsif ($page eq "postas") { print_postas_form_page(); } elsif ($page eq "cull_candidates") { print_cull_candidates_form_page(); } elsif ($cgi->param('reg') eq "Register") # catch new user's registration { print_new_user_page(); } # if ($cgi->param('pooclub') eq "checkdaily") # { # check_for_daily_stuff(); # } } ############################################################ # # Allow user to set a Daily Drivel feature. # ############################################################ sub print_daily_page { my ($message) = @_; log_info("print_daily_page(message=$message)"); my $title = "Daily Drivel"; my $daily = $cgi->param('daily'); my $message = qq(Add or edit an entry for pooclub's daily drivel); my $warning = ""; my @category_list = ("Event", "Joke", "Thought", "Quote", "Link"); my $daily_dir = "${USERROOT}/$UBERACC{'USERNAME'}/daily"; makedir("$daily_dir"); my $category = $cgi->param('category'); my $details = $cgi->param('details'); my $dd = $cgi->param('dd_daily'); my $mm = $cgi->param('mm_daily'); my $yyyy = $cgi->param('yyyy_daily'); $yyyy = "all" if (!$yyyy); my $yyyymmdd = sprintf("%04d%02d%02d", $yyyy, $mm, $dd); my $fname = "${daily_dir}/${yyyymmdd}_$category.txt"; # check if date is valid my $date = ""; $yyyy = substr($yyyymmdd, 0, 4); if ($yyyy > 0) # specific year { $year = $yyyy; $diff = date_manip("-c $yyyymmdd"); $date = date_manip("-fDAYOFWEEK_DD_MONTH_YYYY $yyyymmdd"); $warning = qq(You must set the event date in the future) if ($diff >= 0); $warning = qq(Invalid date) if ($date =~ /INVALID_DATE/); } else # every year { $year = "zero"; $yyyymmdd = sprintf("2008%02d%02d", $mm, $dd); $date = date_manip("-fDAYOFWEEK_DD_MONTH_YYYY $yyyymmdd"); $warning = qq(Invalid date) if ($date =~ /INVALID_DATE/); $date = "$dd " . $MonthList[$mm - 1] . " every "; $date .= "leap " if ($yyyymmdd =~ /229$/); $date .= "year"; } $warning = qq(You need to be logged in to submit some drivel.) if (! is_logged_in()); if (($daily eq 'Save') && !($details =~ /^\s*$/)) { if ($warning) { $message = qq(Not saving event.); } else { open (OUTF, ">$fname") or $warning = qq(Cannot save to file: $fname); printf OUTF "$details\n"; close(OUTF); $message = "Your " . lc($category) . " will be posted on $date" if (!$warning); log_info("Saved daily drivel file: $fname"); email_notify($UBERENV{OWNER_EMAIL}, $UBERENV{ADMIN_EMAIL}, "Saved event", "$UBERACC{'USERNAME'} saved file: $fname"); } } elsif ($daily eq 'Delete') { unlink($fname); $details = ""; log_info("Deleted daily drivel file: $fname"); email_notify($UBERENV{OWNER_EMAIL}, $UBERENV{ADMIN_EMAIL}, "Deleted event", "$UBERACC{'USERNAME'} deleted file: $fname"); $message = qq($category has been deleted.); } else # get details from file { open (INF, "$fname"); $details = ""; while() {$details .= $_;} close(INF); } $warning = "" if (!$daily); # user hasn't submitted a command print_html_head(); print_small_login_line(); # Get user's request to set up a poll print qq(
$title
$warning
  $message
Date ); date_input("daily", 0); print qq(
Type 'all' for year if event is to occur every year.
Category      
Details
  home
); print_drivel_index($daily_dir); print_copyright(); print_html_end(); exit(0); } ############################################################ sub print_drivel_index { my ($daily_dir) = @_; log_info("print_drivel_index(daily_dir=$daily_dir)"); my $date; my $yyyymmdd; my $dow; my $dd; my $mm; my $mon; my $yyyy; my $year; my $fname; my $f; my $first_line; print qq( ); for my $fname (<${daily_dir}/[0-9][0-9][0-9][0-9][0-1][0-9][0-3][0-9]_*.txt>) { $f = basename($fname); $f =~ s/\.txt$//; ($yyyymmdd, $category) = split /_/, $f; $date = $yyyymmdd; $date =~ s/^0000/2008/; ($dow, $dd, $mm, $year) = split / /, date_manip("-fDOW_DD_MM_YYYY $date"); $mon = substr($MonthList[$mm - 1], 0, 3); if (int($yyyymmdd) < 10000) { $year = "All"; $dow = ""; } open (INF, "$fname"); $first_line = ; close(INF); $first_line = substr($first_line, 0, 64); print qq( ); } print qq(
$dow $dd $mon $year $category : $first_line load

); } ############################################################ # # Handle users' nominations for next year's Vegetable Of The Year # ############################################################ sub print_voty_my_noms_page { print_voty_all_noms_page("You must be logged in to nominate.") if (! is_logged_in()); my ($message) = @_; log_info("print_voty_my_noms_page(message=$message)"); my $title = "Vegetable Of The Year"; my $warning = ""; my @winners = read_voty_winners(); my $voty_year = substr($YYYYMMDD, 0, 4) + 1; my $voty_dir = "${USERROOT}/$UBERACC{'USERNAME'}"; my $voty_file = "${voty_dir}/voty_noms_${voty_year}.dat"; makedir("$voty_dir"); my @veg_list = (); my $rating; my $rating_str; my $reason; my $disable = ""; my $message = qq(Add or edit your nominations for $voty_year); print_html_head(); print_small_login_line(); if ($cgi->param('voty_nominate') eq "Submit") # process vegetables { my $noms = ""; open (OUTF, ">$voty_file"); for (my $count = 0; $count < 3; $count++) { $veg_list[$count] = $cgi->param("veg$count"); print OUTF "$veg_list[$count]\n"; $noms .= "; $veg_list[$count]"; } close(OUTF); $noms =~ s/^;//; log_action("Nominated for VOTY: $noms"); # notify group by email my $subject = "New VOTY Nominations"; my $user = get_name_for_display($UBERACC{'USERNAME'}); my $message = qq($user has nominated $noms for Vegetable Of the Year. To see VOTY nominations go to: http://pooclub.shite.org/voty ); email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Vegetable Of The Year"); } else # read them from file { open (INF, "$voty_file"); my $count = 0; while() { chop; next if (/^#/); next if (/^\s*$/); $veg_list[$count++] = $_; } close(INF); } print qq(
$title
$warning
); my $not_accepted = 0; for (my $count = 0; $count < 3; $count++) { ($rating, $rating_str, $reason) = check_voty_approval($veg_list[$count]); $not_accepted++ if (($rating == 0) || ($rating == -1)); $icon = "${IMGROOT}/icons/${rating}.gif"; print qq( ); } print qq(
 

$message

  
  $rating_str $rating_str $reason
   all nominations  home      
  ); if ($not_accepted) { print qq(
Not approved? Don't worry. It just means that your nomination is not on our administrators' list of approved vegetables.

If your nomination is 'Pending' this means that the pooclub elves are busily trying to work out if what you have nominated is a proper vegetable. To speed things along, you can help them by posting evidence of vegetable worthiness to pooclub where the elves will be happy to give you a big green tick once they can verify your claim.

If however your nomination is 'Rejected' this means that the pooclub elves have carefully considered your nomination but cannot find enough evidence to validate it. But don't worry, all is not lost, they will still consider fresh evidence if it is presented before close of nominations. Mind you, this would have to be totally new evidence - the elves will not be swayed by moans of 'aw go on, please' or bickering. ); } print qq(

 
); print_copyright(); print_html_end(); exit(0); } ############################################################ # # assumes voty_winners.dat is reverse sorted, i.e. most # recent winner first. This file is manually maintained. sub read_voty_winners { my $fname = "${SHAREDROOT}/voty_winners.dat"; my @winners; open (VOTY, $fname) or log_error("Cannot open VOTY Winners file: $fname"); while() { chop; next if (! /;/); push @winners, $_; } close(VOTY); return @winners; } ############################################################ sub check_voty_approval { my ($veg) = @_; log_info("check_voty_approval(veg=$veg)"); return (2, "", "") if ($veg =~ /^\s*$/); my @rating_list = ("Rejected", "Pending", "Approved"); my $fname = "${SHAREDROOT}/voty_vegetables.dat"; my $veg_rating; my $veg_reason; open (VEGF, "$fname"); while() { chop; next if (/^#/); next if (/^\s$/); ($vegetable, $rating, $reason, $others) = split /;/, $_; if (lc($veg) eq lc($vegetable)) { $veg_rating = $rating; $veg_reason = $reason; } } close(VEGF); $veg_rating = 0 if (! $veg_rating); return ($veg_rating, $rating_list[$veg_rating + 1], $veg_reason); } ############################################################ sub print_voty_all_noms_page { my ($warning) = @_; log_info("print_voty_all_noms_page(warning=$warning)"); my $title = "Vegetable Of The Year - Nominations"; my $message; my @approved_list = (); my @rejected_list = (); my @pending_list = (); my %nominator_hash = {}; my %reason_hash = {}; my $vegetable; my $rating; my $rating_str; my $reason; my $member; print_html_head(); print_small_login_line(); print qq(
$title
$warning
); for my $fname (<${USERROOT}/*/voty_noms_${voty_year}.dat>) { $member = $fname; $member =~ s/\/voty_noms_${voty_year}.dat$//; $member = basename($member); open (INF, "$fname"); my $count = 0; while() { chop; next if (/^#/); next if (/^\s*$/); $vegetable = $_; ($rating, $rating_str, $reason) = check_voty_approval($vegetable); log_info("vegetable=$vegetable rating=$rating rating_str=$rating_str reason=$reason"); if (! $nominator_hash{"$vegetable"}) { if ($rating == 1) { push (@approved_list, $vegetable); } elsif ($rating == -1) { push (@rejected_list, $vegetable); } else { push (@pending_list, $vegetable); } } $nominator_hash{"$vegetable"} .= "${member}, "; $reason_hash{"$vegetable"} = $reason; } close(INF); } if (scalar(@approved_list)) # Approved List { print qq( ); for my $veg (sort @approved_list) { $nominated_by = substr($nominator_hash{"$veg"}, 0, -2); $nominated_by = get_name_for_display($nominated_by); print qq( ); } } if (scalar(@pending_list)) # Pending List { print qq( ); for my $veg (sort @pending_list) { $nominated_by = substr($nominator_hash{"$veg"}, 0, -2); $nominated_by = get_name_for_display($nominated_by); print qq( ); } } if (scalar(@rejected_list)) # Rejected List { print qq( ); for my $veg (sort @rejected_list) { $nominated_by = substr($nominator_hash{"$veg"}, 0, -2); $nominated_by = get_name_for_display($nominated_by); print qq( ); } } print qq(
); # Determine voty year my $voty_year = $cgi->param('voty_year'); my $next_year = substr($YYYYMMDD, 0, 4) + 1; print_voty_year_form(); $voty_year = $next_year if (! $voty_year); if ($voty_year ne $next_year) { $message = qq(Nominations for $voty_year are closed.); } print qq( my nominations | about VOTY | home
  $message

  
  Approved Nominated by
  $veg Approved $nominated_by $reason_hash{"$veg"}
 
Pending
  $veg Approved $nominated_by approve
 
Rejected
  $veg Approved $nominated_by $reason_hash{"$veg"}

my nominations | about VOTY | home

); if (! is_logged_in()) { print qq(
Not got a pooclub account? Then and nominate your chosen vegetables
for our next Vegetable Of The Year
elections.

); } print_copyright(); print_html_end(); exit(0); } ############################################################ # # Admin: approve or reject a nomination # ############################################################ sub print_voty_approve_page { my ($message) = @_; log_info("print_voty_approve_page(message=$message)"); my $title = "Vegetable Of The Year"; my $veg = $cgi->param('veg'); my $message = qq(Approve or reject a nomination); my $warning = ""; my $disabled = ""; if ($UBERACC{'PRIVILEGE'} < 3) { $message = qq(Only administrators may approve or reject nominations.); $disabled = qq(disabled="disabled"); } print_html_head(); print_small_login_line(); print qq(
$title
$warning
  $message

  
  Nomination:    
  Reason: (optional)    
    all nominations  
); print_copyright(); print_html_end(); exit(0); } ############################################################ sub process_complaint { # return if ($UBERACC{'PRIVILEGE'} < 3); log_info("process_complaint()"); my $subject = $cgi->param('subject'); my $message = $cgi->param('message'); if (is_logged_in()) { email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Some Whinger"); } } ############################################################ sub process_voty_approve { return if ($UBERACC{'PRIVILEGE'} < 3); log_info("process_voty_approve()"); my $fname = "${SHAREDROOT}/voty_vegetables.dat"; my $veg = $cgi->param('veg'); my $reason = $cgi->param('reason'); my $action = $cgi->param('action'); my $act = ""; $act = "Approved" if ($action > 0); $act = "Rejected" if ($action < 0); my $year = substr($YYYYMMDD, 0, 4) + 1; log_action("$act VOTY nomination: $veg (reason: $reason)"); open (OUTF, ">>$fname"); print OUTF "${veg};${action};${reason};${year};${YYYYMMDD};\n\n"; close(OUTF); my $subject = "$veg Has Been $act"; $act = lc($act); my $user = get_name_for_display($UBERACC{'USERNAME'}); my $message = qq(Vegetable of the Year nomination "$veg" has been $act To see VOTY nominations go to: http://pooclub.shite.org/voty ); email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Vegetable Of The Year"); } ############################################################ # # Welcome new user to pooclub # ############################################################ sub print_new_user_page { my ($message) = @_; my $title = "Welcome To Pooclub"; print_html_head(); print_small_login_line(); print qq(
$title

Welcome Well done! You now have a poopages account.

Before we return you to the poopages, would you like to subscribe to our googlegroups forum where you can observe, and even interact with, other pooclubbers in their natural habitat? These are the people that you’ll be voting for if you wish to expel anyone in The Cull.

Forum
Join the Forum
); print_drivel_index($daily_dir); print_copyright(); print_html_end(); exit(0); } ############################################################ sub voty_year { my $fname = "${SHAREDROOT}/voty_years.dat"; my $voty_year_status = $cgi->param('voty_year_status'); my ($voty_year, $voty_status) = split /;/, $voty_year_status; print qq(
Year:
); return($voty_year, $voty_status); # default values } ############################################################ sub print_voty_year_form { # get list of years from voty_vegetables file my $fname = "${SHAREDROOT}/voty_vegetables.dat"; my $selected_year = $cgi->param('voty_year'); my $yyyymmdd; my $year = substr($YYYYMMDD, 0, 4) + 1; my %yearFlag; $yearFlag{$year} = "Y"; my @year_list = ($year); $selected_year = $year if ($selected_year eq ""); open(INF, $fname) or log_error("print_voty_year_form() Cannot open file: $fname"); while() { chop; next if (/^#/); next if (/^\s*$/); ($veg, $app, $reason, $year, $yyyymmdd) = split /;/, $_; if ((! $year =~ /^\s*$/) && ($yearFlag{$year} ne "Y")) { $yearFlag{$year} = "Y"; push @year_list, $year; } } close(INF); #@array = ('Apple', 'Orange', 'Apple', 'Banana'); #%hashTemp = map { $_ => 1 } @array; #@array_out = sort keys %hashTemp; ## @array_out contains ('Apple', 'Banana', 'Orange') print qq(
Year:
); } ############################################################ sub get_voty_status { my ($voty_year) = @_; my $fname = "${SHAREDROOT}/voty_years.dat"; my $voty_status = 0; open (INF, "$fname"); while() { chop; next if (/^#/); next if (/^\s*$/); ($year, $status) = split /;/, $_; $voty_status = $status if ($voty_year eq $year); } close(INF); return($voty_status); } ############################################################ sub check_for_daily_stuff { # Only perform these tasks ONCE per day my $date_file = "${SHAREDROOT}/latest_date.txt"; open (DATE, "$date_file"); my $latest_date = ; close(DATE); my $today = date_manip(); log_info("check_for_daily_stuff - today=$today latest_date=$latest_date"); if ($today eq $latest_date) # same day, no action { return; } # record today's date as latest date open (DATE, ">$date_file"); print DATE $today; close(DATE); log_info("check_for_daily_stuff - Doing daily stuff"); check_for_expired_polls(); update_weekly_oblongs(); check_for_birthday_oblongs(); check_for_obliteration_date(); ###$YYYYMMDD = "20111219"; # TODO: temp fix - remove this! ###write_bigoblong_table_file(); # TODO: temp fix - remove this! check_oblottery_draw(); # Check for events... make_daily_drivel(); make_weekly_drivel(); # new separate email for oblong updates make_lent_drivel(); make_new_cull_poll(); check_todays_topic_individual(); post_todays_topic(); post_caption_competition(); post_logfile(); } ############################################################ sub make_weekly_drivel { my $dow = date_manip("-fDOW $YYYYMMDD"); log_info("make_weekly_drivel() - start - dow=$dow"); if ($dow ne $MONDAY) { log_info("make_weekly_drivel() - it's not Monday"); return; } log_info("make_weekly_drivel() - making weekly drivel for Monday"); makedir("${SHAREDROOT}/weekly"); my $weekly_file = "${SHAREDROOT}/weekly/weekly_${YYYYMMDD}.txt"; my $poodate = date_manip("-c 20000727 $YYYYMMDD"); #Num days since 27 July 2000 log_info("make_weekly_drivel() YYYYMMDD=$YYYYMMDD poodate=$poodate"); my $today = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR"); my $monthDD = date_manip("-fMONTH_DD"); $monthDD =~ s/\s//g; # test if today's weekly drivel file exists yet open (WEEKLY, "$weekly_file"); my $test = ; close(WEEKLY); if ($test) { log_info("weekly_file already exists: $weekly_file"); return; } log_info("Making weekly_file: $weekly_file"); my $events_file = "${DATAROOT}/../tripe/public/data/general/events.dat"; my $events_file2 = "${DATAROOT}/../tripe/public/data/events/$monthDD"; open (WEEKLY, ">$weekly_file"); # print WEEKLY "Weekly Waste - Poodate: $poodate\n\n"; print WEEKLY "$today\n"; print WEEKLY "-" x length($today), "\n"; # Include notification of impending obliteration day my $obliteration_yyyymmdd = next_obliteration_yyyymmdd($YYYYMMDD); my $days_to_obliteration = date_manip("-c $YYYYMMDD $obliteration_yyyymmdd"); if (($days_to_obliteration == 3) || ($days_to_obliteration == 7)) { my $obliteration_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $obliteration_yyyymmdd"); print WEEKLY qq( $days_to_obliteration days to next Oblong Obliteration Day: $obliteration_date This is the last week of the current Corner of The Big Oblong. ); } # Show final tally of oblongs at End Of Quarter (only on obliteration days) if (can_obliterate() == 1) { log_info("make_weekly_drivel - can obliterate"); log_info("make_weekly_drivel - show final table of oblongs just before obliteration"); my %players = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); my %bonus = {}; read_players_file(\@id_list, \%players); $YYYYMMDD = date_manip("-d-7 $YYYYMMDD"); # nasty hack read_oblong_files(\%players, \%oblongs, \%bag, \@id_list); $YYYYMMDD = date_manip("-d7 $YYYYMMDD"); reset_date_time(); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); # Get generosity and scrooge bonuses from new oblog file my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${YYYYMMDD}.log"; open (LOGF, "$log_fname") or log_error ("make_weekly_drivel - cannot open oblong file: $log_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $time, $from, $to, $points, $reason) = split /;/, $_; } close(LOGF); print WEEKLY qq( It's Oblong Obliteration Day! Today's the day we obliterate everybody's oblongs and find out who is this Corner's oblong champion. Final Oblongs ------------- ); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; my $count = 0; my $winner = ""; for my $id (@ids) { my $info = ""; if ($count == 0) { $info = "Winner!"; $winner = $players{$id}; } $info = "Runner up" if ($count == 1); $info = "Third place" if ($count == 2); printf WEEKLY "%2d %-20s %s\n", $oblongs{$id}, $players{$id}, $info; $count++; } print WEEKLY qq( So congratulations to $winner who wins a covetted Corner in this year's Big Oblong. And well done to everyone else who took part in the oblongathon. Now it is time to obliterate all these oblongs and start afresh. Who will be next Corner's champion? Could it be you? ); } # can_obliterate # Show current tally of oblongs (only on Mondays) my $dow = date_manip("-fDOW $YYYYMMDD"); my $winner = ""; if ($dow eq $MONDAY) { my %players = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); my %bonus = {}; read_players_file(\@id_list, \%players); read_oblong_files(\%players, \%oblongs, \%bag, \@id_list); # Get generosity and scrooge bonuses from new oblog file my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${YYYYMMDD}.log"; open (LOGF, "$log_fname") or log_error ("make_weekly_drivel - cannot open oblong file: $log_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $time, $from, $to, $points, $reason) = split /;/, $_; if ($from eq "pooclub") { $bonus{$to} = qq(Generosity bonus) if (($points > 0) && ($obliteration_yyyymmdd != $YYYYMMDD)); $bonus{$to} = qq(Scrooge penalty) if (($points < 0) && ($obliteration_yyyymmdd != $YYYYMMDD)); } } close(LOGF); print WEEKLY qq( Oblongs ------- ); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; for my $id (@ids) { printf WEEKLY "%2d %-20s %s\n", $oblongs{$id}, $players{$id}, $bonus{$id}; if ($winner eq "") { $winner = $players{$id}; } } print WEEKLY qq( Manage your oblongs here: http://pooclub.shite.org/oblongs ); } close(WEEKLY); my $to_email = $UBERENV{GROUP_EMAIL}; # mail to pooclub forum my $subject = "Weekly Oblong Winner: $winner"; log_info("Mailing $subject to $to_email from $UBERENV{ADMIN_EMAIL}"); email_notify_file($to_email, $UBERENV{ADMIN_EMAIL}, "$subject", "$weekly_file", "Oblong Observer"); log_info("make_weekly_drivel() - end"); } ############################################################ ############################################################ sub post_logfile { # mail yesterday's action log file to me my $logdir = "${LOGROOT}/actions"; my $yyyymmdd = date_manip("-d-1 $YYYYMMDD"); my $logfname = "${logdir}/${SCRIPT_TITLE}_${yyyymmdd}.csv"; my $subject = "Log File: ${SCRIPT_TITLE}_${yyyymmdd}.csv"; my $to_email = "mike2sheds\@gmail.com"; log_info("Mailing log file $logfname to $to_email"); email_notify_file($to_email, $UBERENV{ADMIN_EMAIL}, "$subject", "$logfname", "Admin"); } ############################################################ sub make_new_cull_poll { # only do this on the first day of the month if (substr($YYYYMMDD, 6, 2) != "01") { return; } log_info("Setting up new cull poll"); my $name; my $flag; my $c = 0; my $candidates_file = "${SHAREDROOT}/cull_candidates.dat"; open (CULL, "$candidates_file"); if (! CULL) { log_info("Cannot open Cull Candidates file: $candidates_file"); return; } while() { chop; next if (/^#/); next if (/^s*$/); ($name, $flag) = split /;/; if ($flag eq "1") { log_info("Including $name"); $cgi->param(-name => "choice$c", -value => "$name"); $c++; } else { log_info("$name is switched off"); } } close(CULL); my $closing_date = date_manip("-l $YYYYMMDD"); my $yyyy_poll = substr($closing_date, 0, 4); my $mm_poll = substr($closing_date, 4, 2); my $dd_poll = substr($closing_date, 6, 2); my $closing_month = date_manip("-fMONTH $closing_date"); my $question = qq(The Cull - $closing_month $yyyy_poll); $question .= qq(: Vote for the player you wish to see thrown out of pooclub.); $cgi->param(-name => 'yyyy_poll', -value => "$yyyy_poll"); $cgi->param(-name => 'mm_poll', -value => "$mm_poll"); $cgi->param(-name => 'dd_poll', -value => "$dd_poll"); $cgi->param(-name => 'question', -value => "$question"); $cgi->param(-name => 'choices', -value => "$c"); $cgi->param(-name => 'setpoll', -value => "Set Poll"); my $save_username = $UBERACC{'USERNAME'}; $UBERACC{'USERNAME'} = "philip"; my $message = process_setnewpoll(); log_info("message=$message"); $UBERACC{'USERNAME'} = $save_username; } ############################################################ sub count_selections_in_file { my ($fname, $separator) = @_; my $count = 0; open (INF, "$fname") or return -1; while() { chop; $count++ if (/^$separator/); } close(INF); return $count; } ############################################################ sub get_file_selection { my ($julian, $fname, $separator, $title) = @_; my $ret = ""; my $numRecords = count_selections_in_file($fname, $separator); return $ret if (($numRecords < 1) || ($julian < 1)); my $seed = $julian % $numRecords; my $count = 0; open (SFILE, "$fname") or return; if ($title) { $ret .= qq($title\n); $ret .= "-" x length($title); $ret .= "\n"; } while() { $ret .= $_ if (($count == $seed) && !(/^$separator/)); $count++ if (/^$separator/); } close(SFILE); $ret .= "\n"; return $ret; } ############################################################ sub get_monthly_drivel { my $dd = substr($YYYYMMDD, 6, 2); my ($fname) = "${REFROOT}/monthly_drivel.dat"; open (INF, "$fname"); while() { chop; next if (/^#/); next if (/^\s*$/); ($day_num, $message, $link) = split /;/, $_; if ($dd eq $day_num) { $drivel = "$message\n"; $drivel .= "$link\n" if ($link ne ""); last; } } return $drivel; } ############################################################ sub make_daily_drivel { makedir("${SHAREDROOT}/drivel"); my $drivel_file = "${SHAREDROOT}/drivel/drivel_${YYYYMMDD}.txt"; my $poodate = date_manip("-c 20000727 $YYYYMMDD"); #Num days since 27 July 2000 log_info("make_daily_drivel() YYYYMMDD=$YYYYMMDD poodate=$poodate"); my $today = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR"); my $monthDD = date_manip("-fMONTH_DD"); $monthDD =~ s/\s//g; # test if today's drivel file exists yet open (DRIVEL, "$drivel_file"); my $test = ; close(DRIVEL); if ($test) { log_info("drivel_file already exists: $drivel_file"); return; } log_info("Making drivel_file: $drivel_file"); my $events_file = "${DATAROOT}/../tripe/public/data/general/events.dat"; my $events_file2 = "${DATAROOT}/../tripe/public/data/events/$monthDD"; open (DRIVEL, ">$drivel_file"); print DRIVEL "Daily Drivel - Poodate: $poodate\n\n"; # print DRIVEL "+++ NEWS +++ NEWS +++ NEWS +++ NEWS +++\n\n"; # print DRIVEL "The Daily Drivel is being updated!\n\n"; # print DRIVEL "Yes, that's right. We know you've been enjoying the Daily Drivel for a long time, but you have to admit it is rather in need of a lick of paint. That's why we have produced a brand spanking new and thoroughly enthralling publication called Stuff Today. Loyal readers of the Daily Drivel may have noticed that they have already been receiving the new exciting and wholly amazing Stuff Today. However, because Stuff Today is sent from your new (and equally astonishingly brilliant) website pooclub.com it might have ended up in your spam folder because your email client doesn't yet know how fabulous pooclub.com is.\n\n"; # print DRIVEL "So, we are advising you to make sure that you can receive email from stuff\@pooclub.com because some day pretty soon Daily Drivel is going to end.\n\n"; # print DRIVEL "I know it sounds bad but sometimes you've got to move with the times, embrace the new, and bid a stoic farewell to the old, no matter how cherished it is. I'm sure you'll agree that this move is for the best and you'll enjoy Stuff Today even more than you have the Daily Drivel.\n\n"; # print DRIVEL "+++ NEWS +++ NEWS +++ NEWS +++ NEWS +++\n\n"; print DRIVEL qq( +++ NEWS +++ NEWS +++ NEWS +++ NEWS +++ NEWS +++ NEWS +++ The Daily Drivel is being updated! Yes, that's right. We know you've been enjoying the Daily Drivel for a long time, but you have to admit it is rather in need of a lick of paint. That's why we have produced a brand spanking new and thoroughly enthralling publication called Stuff Today. Loyal readers of the Daily Drivel may have noticed that they have already been receiving the new exciting and wholly amazing Stuff Today. However, because Stuff Today is sent from your new (and equally astonishingly brilliant) website pooclub.com it might have ended up in your spam folder because your email client doesn't yet know how fabulous pooclub.com is. So, we are advising you to make sure that you can receive email from stuff\@pooclub.com because some day pretty soon Daily Drivel is going to end. I know it sounds bad but sometimes you've got to move with the times, embrace the new, and bid a stoic farewell to the old, no matter how cherished it is. I'm sure you'll agree that this move is for the best and you'll enjoy Stuff Today even more than you have the Daily Drivel. +++ NEWS +++ NEWS +++ NEWS +++ NEWS +++ NEWS +++ NEWS +++ ); print DRIVEL "$today\n"; print DRIVEL "-" x length($today), "\n"; # read events from main event file my $numEvents = 0; if (open (EVENTFILE, "$events_file")) { while () { chop; ($new, $eventMonthDD, $text) = split /;/, $_, 3; if ($monthDD eq $eventMonthDD) { $text =~ s/
/\n/g; # FISH untested print DRIVEL "$text\n\n"; $numEvents++; } } close (EVENTFILE); } # read events from separate event files if (open DATEFILE, "$events_file2") { while () { s/
/\n/g; # FISH untested print DRIVEL $_; } close (DATEFILE); print DRIVEL "\n\n"; $numEvents++; } print DRIVEL "\n" if ($numEvents < 1); # read events from users' files for my $fname (<${SHAREDROOT}/drips/${YYYYMMDD}_Event_*.txt>) # glob { open (INF, "$fname") or log_error("Cannot read event file: $fname"); while() {print DRIVEL $_;} close(INF); print DRIVEL "\n\n"; } # Check for Lucky Days (Tuesday 22nd) my $dow = date_manip("-fDOW $YYYYMMDD"); my $dd = substr($YYYYMMDD, 6, 2); #print DRIVEL qq(TODO: TEST dow=$dow dd=$dd\n); if (($dow eq "Tue") && ($dd == 22)) { print DRIVEL qq( It's a Lucky Day! see http://pooclub.shite.org/luckyday ); } # Include monthly messages my $monthly_drivel = get_monthly_drivel(); print DRIVEL $monthly_drivel; print DRIVEL "\n" if ($monthly_drivel =~ /\w/); # Include notification of impending obliteration day my $obliteration_yyyymmdd = next_obliteration_yyyymmdd($YYYYMMDD); my $days_to_obliteration = date_manip("-c $YYYYMMDD $obliteration_yyyymmdd"); if (($days_to_obliteration == 3) || ($days_to_obliteration == 7)) { my $obliteration_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $obliteration_yyyymmdd"); print DRIVEL qq( $days_to_obliteration days to next Oblong Obliteration Day: $obliteration_date This is the last week of the current Corner of The Big Oblong. ); } # Show final tally of oblongs at End Of Quarter (only on obliteration days) # if (can_obliterate() == 1) if ($dow eq "NEVER") # oblong reporting has now moved to weekly_drivel.pl { log_info("make_daily_drivel - can obliterate"); log_info("make_daily_drivel - show final table of oblongs just before obliteration"); my %players = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); my %bonus = {}; read_players_file(\@id_list, \%players); $YYYYMMDD = date_manip("-d-7 $YYYYMMDD"); # nasty hack read_oblong_files(\%players, \%oblongs, \%bag, \@id_list); $YYYYMMDD = date_manip("-d7 $YYYYMMDD"); reset_date_time(); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); # Get generosity and scrooge bonuses from new oblog file my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${YYYYMMDD}.log"; open (LOGF, "$log_fname") or log_error ("make_daily_drivel - cannot open oblong file: $log_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $time, $from, $to, $points, $reason) = split /;/, $_; } close(LOGF); print DRIVEL qq( It's Oblong Obliteration Day! Today's the day we obliterate everybody's oblongs and find out who is this Corner's oblong champion. Final Oblongs ------------- ); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; my $count = 0; my $winner = ""; for my $id (@ids) { my $info = ""; if ($count == 0) { $info = "Winner!"; $winner = $players{$id}; } $info = "Runner up" if ($count == 1); $info = "Third place" if ($count == 2); printf DRIVEL "%2d %-20s %s\n", $oblongs{$id}, $players{$id}, $info; $count++; } print DRIVEL qq( So congratulations to $winner who wins a covetted Corner in this year's Big Oblong. And well done to everyone else who took part in the oblongathon. Now it is time to obliterate all these oblongs and start afresh. Who will be next Corner's champion? Could it be you? ); } # can_obliterate # Show current tally of oblongs (only on Mondays) my $dow = date_manip("-fDOW $YYYYMMDD"); # if ($dow eq $MONDAY) if ($dow eq "NEVER") # oblong reporting has now moved to weekly_drivel.pl { my %players = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); my %bonus = {}; read_players_file(\@id_list, \%players); read_oblong_files(\%players, \%oblongs, \%bag, \@id_list); # Get generosity and scrooge bonuses from new oblog file my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${YYYYMMDD}.log"; open (LOGF, "$log_fname") or log_error ("make_daily_drivel - cannot open oblong file: $log_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $time, $from, $to, $points, $reason) = split /;/, $_; if ($from eq "pooclub") { $bonus{$to} = qq(Generosity bonus) if (($points > 0) && ($obliteration_yyyymmdd != $YYYYMMDD)); $bonus{$to} = qq(Scrooge penalty) if (($points < 0) && ($obliteration_yyyymmdd != $YYYYMMDD)); } } close(LOGF); print DRIVEL qq( Oblongs ------- ); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; for my $id (@ids) { printf DRIVEL "%2d %-20s %s\n", $oblongs{$id}, $players{$id}, $bonus{$id}; } print DRIVEL qq( Manage your oblongs here: http://pooclub.shite.org/oblongs ); } # Show today's pope if we're in lent my $lent_day_number = lent_day_number(); if ($lent_day_number > 0) { my $pope = todays_pope(); print DRIVEL qq( Today's Pope ------------ ); if ($lent_day_number == 1) { print DRIVEL qq( It is a well known fact to those that know it well that the pope gives up his papacy during lent every year. What is less well known is that on these days pooclub provides a pope to take over while the normal pope's doing lenty stuff. Here in the Daily Drivel we will keep you informed on each day during lent of who is the pope for the day, and so it is with great pleasure that we present to you on Ash Wednesday the first pope of lent: $pope ); } else { print DRIVEL qq($pope Lent day number: $lent_day_number - see http://pooclub.shite.org/pope ); } } # Add Meaning Of Liff to Drivel file # (poodate offset sets first item to appear on 1 Jan 2010) my $liff = get_file_selection($poodate + 398, "${REFROOT}/liff.txt", ":", "The Meaning Of Liff"); print DRIVEL $liff; # Look for drivel submitted by pooclub members my $category; my $poem_file = ""; for my $fname (<${SHAREDROOT}/drips/${YYYYMMDD}_*_*.txt>) # glob { $bname = basename($fname); $bname =~ s/.txt$//; ($yyyymmdd, $category, $user) = split /_/, $bname; $category =~ s/-/ /g; next if ($category eq "Event"); # we deal with Events separately if ($category ne "Poem Of The Day") { print DRIVEL "$category\n"; print DRIVEL "-" x length($category), "\n"; open (INF, "$fname") or log_error("Cannot read drip file: $fname"); while() {print DRIVEL $_;} close(INF); print DRIVEL "\n\n"; makedir("${SHAREDROOT}/drips/posted"); move ("$fname", "${SHAREDROOT}/drips/posted"); } else # save Poem Of The Day for the last item { $poem_file = $fname; } } # Put Today's Poem in Drivel File if ($poem_file) { print DRIVEL qq( Poem Of The Day --------------- ); open (INF, "$poem_file") or log_error("Cannot read poem file: $fname"); while() {print DRIVEL $_;} close(INF); print DRIVEL "\n\n"; makedir("${SHAREDROOT}/drips/posted"); move ("$poem_file", "${SHAREDROOT}/drips/posted"); } else # use a Shitespace poem by default { $POEMS_FIXED_FILE = "${DATAROOT}/../tripe/public/data/meta/poems_fixed.dat"; $SHITE_INDEX_FILE = "${DATAROOT}/../tripe/public/data/meta/shite_index.dat"; # we need to use functions from shitespace to get today's poem require "tripe/stuff_funcs.pl"; my $poem_record = todays_poem($YYYYMMDD); my ($shiteId, $poemTitle, $poemAuthor, $poemType, $imageCode) = split /;/, $poem_record; log_info("Adding shitespace poem id $shiteId to drivel file"); $poem_file = "${DATAROOT}/../tripe/public/data/poetry/${shiteId}.txt"; open (POEM_FILE, "$poem_file"); print DRIVEL qq( Poem Of The Day --------------- $poemTitle ($poemAuthor) ); while() { next if (/^#/); s/
/\n/g; s/\margintext.*$//; print DRIVEL $_; } close(POEM_FILE); } print DRIVEL qq( Links ----- For quick links to important pooclub pages, bookmark this: http://pooclub.shite.org/map Help write the Daily Drivel! Plonk your drivel here: http://pooclub.shite.org/drivel The Shit At The End ------------------- If you’ve received this email it’s either because the ‘Daily Drivel’ box in your poopages account has been selected or because you've been foolish enough to wander into the pooclub forum. If you don’t want this bollocks anymore you can deselect it by editing your poopages account here: http://pooclub.shite.org/account or change your mailing options in the forum here: http://groups.google.com/group/pooclub or you can email us and we’ll sort it out for you. (Please quote your user id) pooclub\@shite.org pooclub admin ); close(DRIVEL); check_daily_drivel(); # send_daily_drivel($UBERENV{GROUP_EMAIL}); # to pooclub forum } ############################################################ # # Check if any users want Daily Drivel sent to their # personal email address sub check_daily_drivel { log_info("check_daily_drivel() Checking Daily Drivel for email"); my $fname; my $dir; my %account; my @loginfiles = <${LOGINROOT}/*/login.dat>; for $fname (@loginfiles) { $dir = $fname; $dir =~ s/\/login.dat//; ($user_id, $tmp) = split /\./, basename($dir); read_login_file(\%account, $user_id); $daily = $account{'DAILY'}; $email = $account{'EMAIL'}; if (($daily eq "1") && ($email ne "")) { if (valid_email_address($email)) { send_daily_drivel($email); } else { log_info("WARNING $user_id has bad email address: $email"); } } } } ############################################################ # # Post Daily Drivel to pooclub forum sub send_daily_drivel { log_info("send_daily_drivel"); if ($YYYYMMDD > 20140930) { log_info("NOT Mailing $subject to $to_email from $UBERENV{ADMIN_EMAIL}"); return; } my ($to_email) = @_; my $drivel_file = "${SHAREDROOT}/drivel/drivel_${YYYYMMDD}.txt"; my $poodate = date_manip("-c 20000727 $YYYYMMDD"); my $subject = "Daily Drivel $poodate"; log_info("Mailing $subject to $to_email from $UBERENV{ADMIN_EMAIL}"); email_notify_file($to_email, $UBERENV{ADMIN_EMAIL}, "$subject", "$drivel_file", "Daily Drivel"); } ############################################################ # # Check if any users want Today's Topic sent to their # personal email address sub check_todays_topic_individual { log_info("check_todays_topic_individual() Checking Todays Topic for email"); my $fname; my $dir; my %account; my @loginfiles = <${LOGINROOT}/*/login.dat>; for $fname (@loginfiles) { %account = {}; $dir = $fname; $dir =~ s/\/login.dat//; ($user_id, $tmp) = split /\./, basename($dir); read_login_file(\%account, $user_id); my $topic_flag = $account{'TOPIC'}; my $email = $account{'EMAIL'}; #log_info("FISH user_id=$user_id topic_flag=$topic_flag email=$email"); if (($topic_flag eq "1") && ($email ne "")) { if (valid_email_address($email)) { send_todays_topic_individual($email); } else { log_info("WARNING $user_id has bad email address: $email"); } } # Check also for users who have subscribed to the caption competition my $caption_flag = $account{'CAPTION'}; if (($caption_flag eq "1") && ($email ne "")) { if (valid_email_address($email)) { send_caption_competition_individual($email); } else { log_info("WARNING $user_id has bad email address: $email"); } } } } ############################################################ # # Post Today's Topic to an individual member # sub send_todays_topic_individual { my ($to_email) = @_; log_info("send_todays_topic_individual() to_email=$to_email"); my $user; my $subject; my $message; my $fname = read_topic_file(\$user, \$subject, \$message, $YYYYMMDD); if (($fname =~ /^\s*$/) || ($subject =~ /^\s*$/) || ($message =~ /^\s*$/)) { return; } $subject = qq(Today's Topic: $subject); log_info("Mailing $subject to $to_email from $UBERENV{ADMIN_EMAIL}"); email_notify($to_email, $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Today's Topic"); } ############################################################ # # Post today's Caption Competition to an individual member # sub send_caption_competition_individual { my ($to_email) = @_; log_info("send_caption_competition_individual() to_email=$to_email"); my $user; my $subject; my $message; my $fname = qq(${SHAREDROOT}/captions/caption_${YYYYMMDD}.txt); if (-e $fname) # file exists { my $poodate = date_manip("-c 20000727 $YYYYMMDD"); $subject = qq(Caption Competition $poodate); log_info("Mailing $subject to $to_email from $UBERENV{ADMIN_EMAIL}"); email_notify_file($to_email, $UBERENV{'ADMIN_EMAIL'}, "$subject", "$fname", "Caption Competition"); } } ############################################################ # # email caption competition sub zz_post_caption_competition { log_info("post_caption_competition()"); my $mailto = $UBERENV{'GROUP_EMAIL'}; my $mailfrom = $UBERENV{'ADMIN_EMAIL'}; my $mailname = qq(Caption Competition); my $user; my $subject = $mailname; my $message; my $signature; my $fname = "../captions/caption_${YYYYMMDD}.jpg"; # my $fname = "${SHAREDROOT}/captions/caption_${YYYYMMDD}.jpg"; # my $fname = "http://pooclub.shite.org/captions/caption_${YYYYMMDD}.jpg"; if (-e $fname) # file exists { $message = qq(http://shite.org/captions/caption_${YYYYMMDD}.jpg); log_info("Found file: $fname - posting caption competition"); # email_notify($UBERENV{'GROUP_EMAIL'}, email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "$mailname"); } else { log_info("No caption competition: $fname does not exist"); } } ############################################################ # # email today's caption competition sub post_caption_competition { log_info("post_caption_competition()"); my $mailto = $UBERENV{'GROUP_EMAIL'}; # my $mailfrom = $UBERENV{'ADMIN_EMAIL'}; #pooclub@shite.org my $mailfrom = "poomail\@shite.org"; my $mailname = qq(Caption Competition); my $poodate = date_manip("-c 20000727 $YYYYMMDD"); my $subject = qq(Caption Competition $poodate); my $fname = "${SHAREDROOT}/captions/caption_${YYYYMMDD}.txt"; if (-e $fname) # file exists { log_info("Found file: $fname - posting caption competition"); email_notify_file($UBERENV{'GROUP_EMAIL'}, # email_notify_file($UBERENV{'EMAIL'}, # mike2sheds@gmail.com for testing "$mailfrom", "$subject", "$fname", "$mailname"); } else { log_info("No caption competition: $fname does not exist"); } } ############################################################ # # email today's topic sub post_todays_topic { log_info("post_todays_topic()"); my $mailto = $UBERENV{'GROUP_EMAIL'}; my $mailfrom = $UBERENV{'ADMIN_EMAIL'}; my $mailname = qq(Today's Topic); my $user; my $subject; my $message; my $signature; # look for a scheduled topic for today my $fname = read_topic_file(\$user, \$subject, \$message, $YYYYMMDD); if ($fname eq "") # try for a queued topic { my @num_list = get_queued_topic_num_list(); my $num = $num_list[0]; $fname = read_topic_file(\$user, \$subject, \$message, $num); log_info("No scheduled topic for $YYYYMMDD - topic num=$num"); } if ($fname ne "") { log_info("Found topic file: $fname"); if ($subject =~ /^\s*$/) { log_error("Topic has empty subject."); return; } if ($message =~ /^\s*$/) { log_error("Topic has empty message."); return; } my $today = date_manip(); my $date_file = "${SHAREDROOT}/latest_topic_date.txt"; open (DATE, "$date_file"); my $latest_topic_date = ; close(DATE); # # Revisit this # if ($today <= $latest_topic_date) # { # log_info("Cannot post topic - a topic has already been posted today"); # return; # } # record today's date as latest date open (DATE, ">$date_file"); print DATE $today; close(DATE); open(SENDMAIL, "|$SENDMAIL") or $error = qq(ERROR - Sorry, cannot send topic.); print SENDMAIL qq(To: $mailto From: "$mailname" <$mailfrom> Subject: Today's Topic: $subject Content-type: text/plain $message $signature ------------------------------ http://pooclub.shite.org/topic - to set your own topic http://pooclub.shite.org/topics - to see all the topics http://pooclub.shite.org/toblongs - to see the topic oblongs ------------------------------ ); close(SENDMAIL); log_info("Sent topic from '$user' to $mailto on '$subject'"); makedir("${SHAREDROOT}/topics/posted"); move ("$fname", "${SHAREDROOT}/topics/posted"); $fname = basename($fname); # record topic in history of posted topics my $history_file = "${SHAREDROOT}/topics/topic_history.dat"; open (HISTORY, ">>$history_file") or log_error("Cannot write to topic history file: $history_file"); print HISTORY qq(${YYYYMMDD};${subject};${user};${fname};\n); close(HISTORY); } else { log_info("No queued topics"); } } ############################################################ sub get_topic_file_info { my ($fname) = @_; log_info("get_topic_file_info($fname)"); open (TOPIC, "$fname"); $user = ; chop($user); $subject = ; chop($subject); close(TOPIC); return ($user, $subject); } ############################################################ sub read_topic_file { my ($user_ref, $subject_ref, $message_ref, $id) = @_; my $fname = make_topic_filename($id); log_info("read_topic_file($id) fname=$fname"); if (-e $fname) # file exists { log_info(" Found topic file: $fname"); open (TOPIC, "$fname") or log_error("Cannot open topic file: $fname"); $$user_ref = ; chop($$user_ref); $$subject_ref = ; chop($$subject_ref); while() { chop; $$message_ref .= $_; } close(TOPIC); return $fname; } else { log_info(" No topic file: $fname"); $$user = ""; $$subject = ""; $$message = ""; } return ""; } ############################################################ sub make_topic_filename { my ($id, $subdir) = @_; my $fname; if ($id =~ /^\d+/) # purely numeric id { if ($id > 20000000) # use id as yyyymmdd { $fname = "${SHAREDROOT}/topics/scheduled_${id}.txt"; } else # treat it as a sequence number { $fname = "${SHAREDROOT}/topics/queued_${id}.txt"; } } elsif ($id =~ /\.txt$/) # id already contains the filename { if ($id =~ /\/topics\//) # assume it comprises the { # full file path too $fname = $id; } else { $fname = "${SHAREDROOT}/topics/${subdir}/$id"; } } else { $fname = "BAD_TOPIC_FILENAME"; log_error("make_topic_filename() fname=$fname Cannot make topic filename from id=$id subdir=$subdir"); } } ############################################################ # # called by pooclub_topicoblongs.html sub show_topic_oblongs { my %hash; my %points; $points{'diamond'} = 10; $points{'platinum'} = 8; $points{'gold'} = 6; $points{'silver'} = 4; $points{'bronze'} = 2; $points{'marble'} = 1; $points{'cardboard'} = 0; $points{'welsh'} = -1; my %score; my %diamond; my %platinum; my %gold; my %silver; my %bronze; my %marble; my %cardboard; my %welsh; my %black; my %white; my $table = qq( ); open (OBLONGS, "${SHAREDROOT}/topic_oblongs.dat"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $name, $reason, $rating, $other) = split /;/,$_; my ($dow, $dd, $month, $yyyy) = split / /, date_manip("-fDOW_DD_MON_YYYY $yyyymmdd"); my $saturday = date_manip("-nSAT $yyyymmdd"); # date of theme answer if ($name =~ /\w/) { my $pts; my $img; if (($rating eq "1") || ($rating eq "+1")) { $oblong = "Marble"; $pts = $points{'marble'}; $marble{$name}++; $img = qq(); } elsif ($rating eq "0") { $oblong = "Cardboard"; $pts = $points{'cardboard'}; $cardboard{$name}++; $img = qq(); } elsif ($rating eq "-1") { $oblong = "Welsh"; $pts = $points{'welsh'}; $welsh{$name}++; $img = qq(); } elsif ($dow eq "Mon") { $oblong = "Diamond"; $pts = $points{'diamond'}; $diamond{$name}++; $img = qq(); } elsif ($dow eq "Tue") { $oblong = "Platinum"; $pts = $points{'platinum'}; $platinum{$name}++; $img = qq(); } elsif ($dow eq "Wed") { $oblong = "Gold"; $pts = $points{'gold'}; $gold{$name}++; $img = qq(); } elsif ($dow eq "Thu") { $oblong = "Silver"; $pts = $points{'silver'}; $silver{$name}++; $img = qq(); } elsif ($dow eq "Fri") { $oblong = "Bronze"; $pts = $points{'bronze'}; $bronze{$name}++; $img = qq(); } if ($pts > 1) # It's a correct theme guess so create a link { # to the theme answer. $reason = qq($reason); } $table .= qq( ); # $hash{$name}{'name'} = $name; $score{$name} += $pts; } else # no winner { if (($dow eq "Sat") || ($dow eq "Sun")) { $reason = qq($reason); $table .= qq( ); } } } close(OBLONGS); $table .= qq(
When Why Who What
$dow $dd $month $yyyy $reason $name $pts  $oblong $img
$dow $dd $month $yyyy $reason No winner      
); my @names = (); for my $name (keys %score) { push @names, $name; } my @sortedNames = sort {$score{$b} <=> $score{$a}} @names; print qq( ); my $printName = ""; my $prevName = ""; for my $name (@sortedNames) { if ($diamond{$name} > 0) { # prevent repetition of name for each oblong type a player has $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $diamond{$name} * $points{'diamond'}; print qq( ); $prevName = $name; } if ($platinum{$name} > 0) { # prevent repetition of name for each oblong type a player has $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $platinum{$name} * $points{'platinum'}; print qq( ); $prevName = $name; } if ($gold{$name} > 0) { # prevent repetition of name for each oblong type a player has $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $gold{$name} * $points{'gold'}; print qq( ); $prevName = $name; } if ($silver{$name} > 0) { $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $silver{$name} * $points{'silver'}; print qq( ); $prevName = $name; } if ($bronze{$name} > 0) { $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $bronze{$name} * $points{'bronze'}; print qq( ); $prevName = $name; } if ($marble{$name} > 0) { # prevent repetition of name for each oblong type a player has $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $marble{$name} * $points{'marble'}; print qq( ); $prevName = $name; } if ($cardboard{$name} > 0) { # prevent repetition of name for each oblong type a player has $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $cardboard{$name} * $points{'cardboard'}; print qq( ); $prevName = $name; } if ($welsh{$name} > 0) { # prevent repetition of name for each oblong type a player has $printName = $prevName ne $name ? qq($name) : " "; $printScore = $prevName ne $name ? $score{$name} : " "; my $pts = $welsh{$name} * $points{'welsh'}; print qq( ); $prevName = $name; } # print qq( # # # ); #FISH name=$name
#FISH points=$points{$name}
#FISH gold=$gold{$name}
} print qq(
Score Name Points Oblongs
$printScore $printName $pts  Diamond ); for ($i = 0; $i < $diamond{$name}; $i++) { print qq( ); } print qq(
$printScore $printName $pts  Platinum ); for ($i = 0; $i < $platinum{$name}; $i++) { print qq( ); } print qq(
$printScore $printName $pts  Gold ); for ($i = 0; $i < $gold{$name}; $i++) { print qq( ); } print qq(
$printScore $printName $pts  Silver ); for ($i = 0; $i < $silver{$name}; $i++) { print qq( ); } print qq(
$printScore $printName $pts  Bronze ); for ($i = 0; $i < $bronze{$name}; $i++) { print qq( ); } print qq(
$printScore $printName $pts  Marble ); for ($i = 0; $i < $marble{$name}; $i++) { print qq( ); } print qq(
$printScore $printName $pts  Cardboard ); for ($i = 0; $i < $cardboard{$name}; $i++) { print qq( ); } print qq(
$printScore $printName $pts  Welsh ); for ($i = 0; $i < $welsh{$name}; $i++) { print qq( ); } print qq(

); print qq( And here's how they got there:

$table

) if (2 == 2); } ############################################################ # # called by pooclub_topicoblongs.html sub input_topic_oblongs { my $contents = ""; my $disabled = ""; my $fname = "${SHAREDROOT}/topic_oblongs.dat"; if ($UBERACC{'PRIVILEGE'} > 2) { log_info("SQUID reading topic_oblongs"); open (OBLONGS, "${SHAREDROOT}/topic_oblongs.dat"); while() { $contents .= $_; } close(OBLONGS); print qq( Admin: $fname

); } } ############################################################ sub process_input_topic_oblongs { my $contents = $cgi->param('contents'); my $fname = "${SHAREDROOT}/topic_oblongs.dat"; log_info("SQUID process_input_topic_oblongs() - writing to fname=$fname"); #log_info("FISH contents=$contents"); open (OBLONGS, ">$fname") or log_error ("Cannot write to topic oblongs file: $fname"); log_info("SQUID 1"); print OBLONGS $contents; log_info("SQUID 2"); close(OBLONGS); log_info("SQUID 3"); } ############################################################ sub process_input_poochoonz_oblongz { my $contents = $cgi->param('contents'); my $fname = "${SHAREDROOT}/poochoonz_winnerz.dat"; #log_info("FISH process_input_topic_oblongs() - writing to fname=$fname"); #log_info("FISH contents=$contents"); open (OBLONGS, ">$fname") or log_error ("Cannot write to topic oblongs file: $fname"); print OBLONGS $contents; close(OBLONGS); } ############################################################ sub process_new_poll_notify { log_info("FISH process_new_poll_notify"); } ############################################################ # # Allow user to post to pooclub under an alias # e.g. Carol Vorderman # Prince Philip # ############################################################ sub print_postas_form_page { my $who = $cgi->param('who'); my $title = "Post as ..."; my $whoami = username_and_priv(); my ($fname) = "${REFROOT}/postas.dat"; open (INF, "$fname"); while() { chop; next if (/^#/); next if (/^\s*$/); ($id, $from_name, $from_email, $to_name, $to_email, $signature) = split /;/, $_; last if ($who eq $id); } my $mailfrom = $from_email; my $mailfrom_html = qq("$from_name"<$from_email>); my $mailto = $to_email; my $mailto_html = "$to_name<$to_email>"; my $disabled = ""; if ($UBERACC{'PRIVILEGE'} < 2) { $warning = qq(Only managers may post as celebrity pooclubbers.); $disabled = qq(disabled="disabled"); } print_html_head(); print qq(
); if ($warning ne "") { print qq( ); } print qq( ) if (is_logged_in()); print qq(
$title
    $warning
  Login: $whoami  
  From: $mailfrom_html  
  To: $mailto_html  
  Subject:  
  Message:  
  Signature: $signature  
        home   
       
); print_html_end(); exit(0); } ############################################################ # # Allow user to set a Today's Topic for pooclub # ############################################################ sub print_topic_form_page { my $yyyymmdd = $cgi->param('d'); log_info("print_topic_form_page(yyyymmdd=$yyyymmdd)"); my $warning = ""; my $whoami = username_and_priv(); my $title = qq(Set A Queued Topic); my $date = qq(the next available date); if ($yyyymmdd > 20000000) # it's a scheduled topic { $title = qq(Set A Scheduled Topic); $date = date_manip("-fDAYOFWEEK_DD_MONTH_YYYY $yyyymmdd"); } if (! is_logged_in()) { $warning = qq(You are not logged in. If you set a topic without being logged in, others may edit or delete your topic before it is posted. However, if you log in then only you will be able to edit or delete your topic.); } my $user = ""; my $subject = ""; my $message = ""; my $fname = read_topic_file(\$user, \$subject, \$message, $yyyymmdd); my $disabled = ""; # if ($UBERACC{'PRIVILEGE'} < 2) # { # $warning = qq(Only managers may set a topic.); # $disabled = qq(disabled="disabled"); # } print_html_head(); print_small_login_line(); # Prevent users seeing other users' topics if (($UBERACC{'USERNAME'} ne $user) && ($user ne "")) { log_info("User attempted to view someone else's topic (user=$user yyyymmdd=$yyyymmdd)"); print qq(   continue
); print_html_end(); exit(0); } print qq(
); if ($warning ne "") { print qq( ); } print qq(
$title
    $warning
   
Enter your topic in the form below. Your topic will then be posted to the pooclub forum on $date where it will be discussed in detail by our professional body of bickerers and nit pickers. Make sure you are subscribed to the forum if you want to see their responses. 		 
  Today's Topic:  
  Introduction:  
        back to topics home   
    If you'd like to propose a Today's Topic but have got a bit of shiter's block regarding the introduction, why not use our template topic introduction below? Simply copy and paste the below text replacing the words in angle brackets with ones applicable to your topic. 

Today's Topic: <Wibbles>

Love them, loathe them, or simply ignore them, it's difficult 
to imagine a world without <wibbles>. <Wibbles> have now become 
the <thingiest> thing since <nubwarts>, and look set to take 
over as the world's favourite <barmuttock>.

But what do really know about <wibbles> Can they ever be a 
suitable replacement for <ninglummies>? And is there any truth 
in the recent allegations about their tendency to <hiberponge>?

Pooclubbers, you decide.

Then just post it to pooclub and enjoy the barrage of bollocks you'll get back in response.

Other ideas:

  • An otherwise dull news item can be given a good freshen up in pooclub.
  • A problem shared is a problem several people have. Don’t be shy to trouble us with something that’s bothering you. We just might be able to help.
  • Sometimes pooclubbers have simply chosen Wikipedia’s current featured article and just cut-n-paste a couple of paragraphs from that. That’s fine by us.
  
); print_html_end(); exit(0); } ############################################################ # # Allow user to set a Caption Competition for pooclub # ############################################################ sub print_caption_form_page { my $yyyymmdd = $cgi->param('d'); log_info("print_caption_form_page(yyyymmdd=$yyyymmdd)"); my $warning = ""; my $whoami = username_and_priv(); my $title = qq(Set A Caption Competition); my $date = date_manip("-fDAYOFWEEK_DD_MONTH_YYYY $yyyymmdd"); if (! is_logged_in()) { $warning = qq(FISH You are not logged in. If you set a topic without being logged in, others may edit or delete your topic before it is posted. However, if you log in then only you will be able to edit or delete your topic.); } my $user = ""; my $subject = ""; my $message = ""; my $fname = read_topic_file(\$user, \$subject, \$message, $yyyymmdd); my $disabled = ""; # if ($UBERACC{'PRIVILEGE'} < 2) # { # $warning = qq(Only managers may set a caption competition.); # $disabled = qq(disabled="disabled"); # } print_html_head(); print_small_login_line(); print qq(
$title
   
To set a caption competition, just send us a picture from your computer, phone, iThingy or interocitor.

Your caption competition will be posted to the pooclub forum on $date where our witty members will provide comical captions and titilating titles, guaranteed to entertain.

 
  File:  
  Message:
(optional)		  

   
Alternatively, post us the URL of an image you've found out there in webland that you think might make a good caption competition. 		 
  URL:  
  Message:
(optional)		  
); #
# # #
print_html_end(); exit(0); } ############################################################ # # Handle user's request to set a topic. # ############################################################ sub process_topic { log_info("process_topic()"); my $num = $cgi->param('yyyymmdd'); my $date = $cgi->param('date'); my $subject = $cgi->param('subject'); my $message = $cgi->param('message'); my $fname; $subject =~ s/^\s*Today.*s\s*Topic//i; $subject =~ s/^\W+//; log_info("process_topic - num=$num"); log_info("process_topic - subject=WITHHELD"); # log_info("message=$message"); # TODO: TEMP - do proper fix for this if (! is_logged_in()) { log_info("process_topic - TEMPORARILY REFUSED NON-LOGGED IN TOPICS"); return; } # log_action("set a topic for $date entitled '$subject'"); log_action("set a topic for $date"); makedir("${SHAREDROOT}/topics"); if ($num eq "") # set a new queued topic { # assign next sequence number my $posted_num = get_latest_queued_topic_number("posted"); my $pending_num = get_latest_queued_topic_number(); $num = ($posted_num > $pending_num) ? $posted_num : $pending_num; $num = sprintf "%05d", $num + 1; } my $fname = make_topic_filename($num); open(TOPIC, ">$fname") or log_error("process_topic - Cannot write topic file: $fname"); print TOPIC qq($UBERACC{'USERNAME'} $subject $message ); close(TOPIC); # if the sun's not yet over the yardarm my $hh = substr($HHMMSS, 0, 2); if ($hh < 12) { post_todays_topic(); } } ############################################################ sub get_queued_topic_num_list { my ($subdir) = @_; # so we can get posted topics my @fname_list = <${SHAREDROOT}/topics/${subdir}/queued_*.txt>; my $num; my @num_list; for $fname (@fname_list) { $num = $fname; $num =~ s/^.*queued_//; $num =~ s/\.txt$//; push @num_list, $num; } return sort @num_list; } ############################################################ sub show_queued_topics { my @fname_list = sort <${SHAREDROOT}/topics/queued_*.txt>; my $fnames = scalar(@fname_list); my $num; my $user; my $subject; print qq(There are $fnames queued topics.
); for $fname (@fname_list) { $num = $fname; $num =~ s/^.*queued_//; $num =~ s/\.txt$//; ($user, $subject) = get_topic_file_info($fname); if ($UBERACC{'PRIVILEGE'} > 3) # admin owner { print qq(   q$num [${user}] $subject - delete
); } elsif (($UBERACC{'USERNAME'} eq $user) || ($user eq "")) { print qq(   q$num [${user}] $subject
); } else { print qq(   q$num private
); } } } ############################################################ # # called by: # \sub show_topic_dates() # in data/poo/pooclub_topic.html # # Shows list of scheduled topics and available dates sub show_topic_dates { my @args = @_; for my $arg (@args) { print qq(arg="$arg"
); } my $yyyymmdd = $YYYYMMDD; my $days_ahead = 30; my $last_date = date_manip("-d$days_ahead $YYYYMMDD"); my $hh = substr($HHMMSS, 0, 2); my $date; my $user; my $subject; require("uber/uber_date.pl"); # Can't post for today if it's gone mid-day $yyyymmdd = date_manip("-d1 $yyyymmdd"); # if ($hh > 11); while ($days_ahead > 0) # while($yyyymmdd < $last_date) { $fname = "${SHAREDROOT}/topics/scheduled_${yyyymmdd}.txt"; ($user, $subject) = get_topic_file_info($fname); $yyyy = substr($yyyymmdd, 0, 4); $mm = substr($yyyymmdd, 4, 2) - 1; $dd = substr($yyyymmdd, 6, 2); $date = qq($dd $MonthList[$mm] $yyyy); ($thingy, $dow) = split / /, date_calc("-s $yyyymmdd"); $dow = substr($dow, 0, 3); if (($UBERACC{'USERNAME'} eq $user) || ($user eq "")) { $user = "[" . $user . "]" if ($subject ne ""); print qq(   $dow $date $user $subject
); } else { print qq(  $dow $date private
); } $days_ahead-- if ($user eq ""); $yyyymmdd = date_manip("-d1 $yyyymmdd"); } print qq(
); } ############################################################ # # called by: # \sub show_caption_dates() # in data/poo/pooclub_caption.html # # Shows list of available caption competition dates sub show_caption_dates { # my @args = @_; # # for my $arg (@args) # { # print qq(arg="$arg"
); # } my $yyyymmdd = $YYYYMMDD; my $days_ahead = 10; my $last_date = date_manip("-d$days_ahead $YYYYMMDD"); my $hh = substr($HHMMSS, 0, 2); my $date; my $user; my $subject; require("uber/uber_date.pl"); # Can't post for today if it's gone mid-day $yyyymmdd = date_manip("-d1 $yyyymmdd"); # if ($hh > 11); while($yyyymmdd < $last_date) { # TODO: check for existence of text file ${SHAREDROOT}/captions/caption_YYYYMMDD.txt instead of image file $fname = "${SHAREDROOT}/captions/caption_${yyyymmdd}.jpg"; $yyyy = substr($yyyymmdd, 0, 4); $mm = substr($yyyymmdd, 4, 2) - 1; $dd = substr($yyyymmdd, 6, 2); $date = qq($dd $MonthList[$mm] $yyyy); ($thingy, $dow) = split / /, date_calc("-s $yyyymmdd"); $dow = substr($dow, 0, 3); # if (1) # file doesn't exist # { print qq(   $dow $date $subject
); # } $yyyymmdd = date_manip("-d1 $yyyymmdd"); } print qq(
); } ############################################################ # # called by: # \sub show_latest_caption_image() # in data/poo/pooclub_caption.html # sub show_latest_caption_image { # print qq(FISH YYYYMMDD=${YYYYMMDD}
); my @flist = (reverse sort <${SHAREDROOT}/captions/caption_*.txt>); # glob my $latest_fname = $flist[0]; # TODO: what if list is empty? for my $fname (@flist) { # print qq(fname=${fname}
); my $yyyymmdd = $fname; $yyyymmdd =~ s/^.*caption_//; $yyyymmdd =~ s/.txt$//; #print qq(yyyymmdd=$yyyymmdd YYYYMMDD=$YYYYMMDD
); $latest_fname = $fname; last if ($yyyymmdd <= $YYYYMMDD); } # print qq(latest_fname=${latest_fname}
); # url of image file is in second line of text file open (INF, "$latest_fname"); my $blank_line = ; my $url = ; close(INF); chop $url; #print qq(url=$url
); print qq(src="$url"); } ############################################################ sub get_latest_queued_topic_number { my ($subdir) = @_; my @num_list = get_queued_topic_num_list($subdir); # for my $num (@num_list) # { # log_info("SQUID num=$num"); # } if (scalar(@num_list) < 1) { return 0; } return $num_list[scalar(@num_list) - 1]; } ############################################################ # # Handle user's request to post as someone else. # ############################################################ sub process_postas_page { my $title = "Sent Poomail"; my $mailto = $cgi->param('mailto'); my $mailfrom = $cgi->param('mailfrom'); my $from_email = $cgi->param('from_email'); my $from_name = $cgi->param('from_name'); my $subject = $cgi->param('subject'); my $message = $cgi->param('message'); my $signature = $cgi->param('signature'); $signature =~ s/
/\n/; my $thankyou = ""; my $error = ""; $error .= "No subject. " if ($subject =~ /^\s*$/); $error .= "No message. " if ($message =~ /^\s*$/); if ($error eq "") { open(SENDMAIL, "|$SENDMAIL") or $error = qq(ERROR - Sorry, cannot send email.); print SENDMAIL qq(To: $mailto From: "$from_name" <$from_email> Reply-to: $mailfrom Subject: $subject Content-type: text/plain $message $signature ); close(SENDMAIL); $thankyou = qq(Your message has been posted to $mailto); log_action("Post As: Sent mail from $mailfrom to $mailto subject: $subject"); } else { $title = "Not $title"; log_info("Post As: Not sent mail from $mailfrom to $mailto subject=$subject error=$error"); } print_html_head(); print qq(
); print qq( ) if ($UBERACC{'USERNAME'} ne ""); print qq(
$title
  $thankyou
$error

  
  Login: $UBERACC{'USERNAME'}  
  From: $mailfrom  
  To: $mailto  
  Subject: $subject  
  Message: $message  
  Signature: $signature  
        home   
       
); print_html_end(); exit(0); } ############################################################ # # Admin: edit cull candidates # ############################################################ sub print_cull_candidates_form_page { my ($message) = @_; my $title = "Edit Cull Candidates"; my $message = qq(Checked candidates will appear in next month's cull.); my $warning = ""; my $disabled = ""; my $mday = substr($YYYYMMDD, 6, 2); if ($mday > 25) # Near end of month only administrators { # may edit candidates if ($UBERACC{'PRIVILEGE'} < 3) { $message = qq(Only administrators may edit cull candidates near the end of the month.); $disabled = qq(disabled="disabled"); } } else { if ($UBERACC{'PRIVILEGE'} < 2) { $message = qq(Only managers may edit cull candidates.); $disabled = qq(disabled="disabled"); } } print_html_head(); print_small_login_line(); print qq(
$title
$warning
); my $i = 0; my $cand_name; my $active_flag; my $checked; # Allow user to edit current candidates open(CULL, "${SHAREDROOT}/cull_candidates.dat"); while() { chop; next if (/^#/); next if (/^\s*$/); ($cand_name, $active_flag) = split /;/; $checked = ($active_flag eq "1") ? qq(checked="checked") : ""; print qq( ); $i++; } close(CULL); # Allow user to add a new candidate print qq(
  $message

  
     
    New  
      admin  
); print_copyright(); print_html_end(); exit(0); } ############################################################ # # Admin: "Apply Changes" to cull candidates file # ############################################################ sub process_cull_candidates { my $fname = "${SHAREDROOT}/cull_candidates.dat"; log_info("Applying changes to cull candidates file: $fname"); my $candidate; my $flag; my $count = $cgi->param('cull_count'); open(CULL, ">$fname"); if (! CULL) { log_info("ERROR process_cull_candidates() cannot open file $fname"); return; } for (my $i = 0; $i <= $count; $i++) { $candidate = $cgi->param("cand$i"); if ($candidate =~ /\w+/) { $flag = $cgi->param("flag$i"); print CULL qq(${candidate};${flag};\n); } } log_action("Edited cull candidates."); } ############################################################ # # For some reason the file ends up with zero size when uploaded # sub process_captionupload { # restrict size of file # $CGI::POST_MAX = 1024 * 5000; # Can't get this to work log_info("process_captionupload() CGI::POST_MAX=$CGI::POST_MAX"); my $filename = $cgi->param('datafile'); if (!$filename) { log_info("File too large. Limit is $CGI::POST_MAX"); return; } # restrict filename characters my $safe_filename_characters = "a-zA-Z0-9_.-"; my ( $name, $path, $extension ) = fileparse ( $filename, '\..*' ); $fname = $name . $extension; $fname =~ tr/ /_/; $fname =~ s/[^$safe_filename_characters]//g; if ( $fname =~ /^([$safe_filename_characters]+)$/ ) { $fname = $1; } else { log_info("Filename contains invalid characters"); return; } my $uploadDir = "${SHAREDROOT}/captions"; $uploadDir = "/captions"; makedir("$uploadDir"); my $upload_filehandle = $cgi->upload('datafile'); open ( UPLOADFILE, ">${uploadDir}/$fname" ) or log_error("$message - Failed to upload file: $fname"); binmode UPLOADFILE; while ( <$upload_filehandle> ) { print UPLOADFILE; } close UPLOADFILE; log_info("Uploaded file $fname to $uploadDir"); } ############################################################ # example from http://perldoc.perl.org/Net/FTP.html # # $ftp = Net::FTP->new("some.host.name", Debug => 0) # or die "Cannot connect to some.host.name: $@"; # # $ftp->login("anonymous",'-anonymous@') # or die "Cannot login ", $ftp->message; # # $ftp->cwd("/pub") # or die "Cannot change working directory ", $ftp->message; # # $ftp->get("that.file") # or die "get failed ", $ftp->message; # # $ftp->quit; sub process_caption_ftp { my $filename = $cgi->param('datafile'); #$filename = "C:\\Users\\stollery\\Downloads\\$filename"; # TODO: fix this $ftp = Net::FTP->new("ftp.ubervoid.com", Debug => 0) or log_error("Cannot connect to ftp.ubervoid.com"); $ftp->login("ubervoid", "gorilla") or log_error("Cannot login: $ftp->message"); $ftp->cwd("shite.org") or log_error("Failed cwd shite.org"); $ftp->cwd("captions") or log_error("Failed cwd captions"); $ftp->put("$filename") or log_error("Failed put $filename"); set_caption_competition("http://shite.org/captions/" . $cgi->param('datafile')); } ############################################################ sub set_caption_competition { my ($url) = @_; my $yyyymmdd = $cgi->param('d'); # my $url = "http://shite.org/captions/" . $cgi->param('datafile'); my $fname = "${SHAREDROOT}/captions/caption_${yyyymmdd}.txt"; my $message = $cgi->param('message'); log_info("url=$url"); log_info("fname=$fname"); log_info("yyyymmdd=$yyyymmdd"); log_info("message=$message"); open(CAPTION, ">$fname") or log_error("Cannot write caption file: $fname"); print CAPTION qq( $url $message ); close(CAPTION); # if the sun's not yet over the yardarm # my $hh = substr($HHMMSS, 0, 2); # if ($hh < 12) # { # post_caption_competition(); # } } ############################################################ # # Process a request to set a caption competition using # an given URL to a picture. sub process_caption_url { my $url = $cgi->param('url'); set_caption_competition("$url"); } ############################################################ sub process_drivel_add { my $yyyymmdd = $cgi->param('yyyymmdd'); my $category = $cgi->param('category'); my $text = $cgi->param('message'); $category =~ s/ /-/g; my $fname = "${SHAREDROOT}/drips/${yyyymmdd}_${category}_$UBERACC{'USERNAME'}.txt"; if ($UBERACC{'PRIVILEGE'} < 1) # not logged in { log_info("Not logged in. Cannot write drivel to file: $fname"); return; } makedir("${SHAREDROOT}/drips"); open (OUTF, ">$fname") or log_error("Failed to write drivel to file: $fname"); print OUTF qq($text); close(OUTF); log_action("contributed $category to Daily Drivel for $yyyymmdd"); } ############################################################ sub find_next_available_drip_date { my ($category, $yyyymmdd) = @_; $yyyymmdd = date_calc("-d1 $YYYYMMDD") if (! $yyyymmdd); my @flist = (sort <${SHAREDROOT}/drips/*_${category}_*.txt>); # glob return $yyyymmdd if (scalar(@flist) < 1); return $yyyymmdd if ($category eq "Event"); # exceptional case my $n_yyyymmdd = $yyyymmdd; my $o_yyyymmdd = 0; my $y_yyyymmdd = 0; my $t_yyyymmdd = 0; my $t_cat; my $t_user; my $bname; for $fname (@flist) { $bname = basename($fname); ($t_yyyymmdd, $t_cat, $t_user) = split /_/, $bname; $y_yyyymmdd = date_manip("-d-1 $t_yyyymmdd"); if (($o_yyyymmdd < $y_yyyymmdd) && ($t_yyyymmdd > $yyyymmdd)) { return $yyyymmdd if ($o_yyyymmdd < 1); $n_yyyymmdd = date_manip("-d1 $o_yyyymmdd"); return $n_yyyymmdd; } $o_yyyymmdd = $t_yyyymmdd; } if ($t_yyyymmdd < $yyyymmdd) { $n_yyyymmdd = $yyyymmdd; } else { $n_yyyymmdd = date_manip("-d1 $t_yyyymmdd"); } return $n_yyyymmdd; } ############################################################ sub print_drivel_input_page { my $title = "Drivel Management"; my $category = $cgi->param('category'); my $dd = $cgi->param('dd_drivel'); my $mm = $cgi->param('mm_drivel'); my $yyyy = $cgi->param('yyyy_drivel'); my $yyyymmdd = sprintf "%04d%02d%02d", $yyyy, $mm, $dd; my $print_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $yyyymmdd"); my $showcat = $category; $showcat =~ s/-/ /g; my $fname = "${SHAREDROOT}/drips/${yyyymmdd}_${category}_$UBERACC{'USERNAME'}.txt"; my $disabled=""; my $text = ""; # if (! $category ) # go back to drivel page # { # $cgi->param(-name => "p", -value => "drivel"); # return; # } if ($category) { open (INF, "$fname"); while() {$text .= $_;} close(INF); } print_html_head(); print_small_login_line(); print qq(
$title
$warning
); my $next_yyyymmdd = $yyyymmdd; my $print_next_yyyymmdd; # if ($yyyymmdd <= $YYYYMMDD) # previous # { # allow events with no year set if (($yyyymmdd <= $YYYYMMDD) && (($yyyymmdd > 9999) || (lc($category) ne "event"))) { $next_yyyymmdd = find_next_available_drip_date($category); $yyyymmdd = $next_yyyymmdd; $print_next_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $next_yyyymmdd"); print qq(
The Daily Drivel for ${print_date} has already been compiled.
The next available date for $showcat is ${print_next_date}.
); } else { if ($text) # drip file belongs to $me so we can use this date { $next_yyyymmdd = $yyyymmdd; } else { $next_yyyymmdd = find_next_available_drip_date($category, $yyyymmdd); } $print_next_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $next_yyyymmdd"); } if ($UBERACC{'PRIVILEGE'} < 1) # not logged in { $disabled = qq(disabled="disabled"); print qq(

You need to be logged in to contribute drivel.
Login here
); } if ($yyyymmdd ne $next_yyyymmdd) { print qq(

Someone has already set a $showcat for ${print_date}.
The next available date is ${print_next_date}.
); } print qq(

Date: $print_next_date - change this
Category: ); if ($category) { print qq( $showcat ); } else { print qq( ); } print qq(
Text:
); print_copyright(); print_html_end(); exit(0); } ##### # my %names = {}; # my %dobs = {}; # my %bag = {}; # my %oblongs = {}; # my @id_list = (); # ##check_for_birthday_oblongs(); # TODO: delete this # my $imgOblong = qq(); # # read_players_file(\@id_list, \%names, \%dobs); # read_oblong_files(\%names, \%oblongs, \%bag, \@id_list); ############################################################ sub process_give_oblongs { my %players = {}; my @ids = (); $UBERENV{'MESSAGE'} = ""; if (! is_logged_in()) { $UBERENV{'MESSAGE'} = qq(FAILED - You are not logged in.); log_action("ALERT process_give_oblongs failed - not logged in."); return; } my $to = $cgi->param('to'); my $num = $cgi->param('n'); my $reason = $cgi->param('reason'); my $username = $UBERACC{'USERNAME'}; read_players_file(\@ids, \%players); my $to_name = $players{$to}; my $name = $players{$username}; # For validation my %names = {}; my %bag = {}; my %oblongs = {}; read_oblong_files(\%names, \%oblongs, \%bag, \@ids); my $inBag = int($bag{$username}) + 5; # TODO: Why do I have to add 5 here? my $myTrophy = int($oblongs{$username}); my $toTrophy = int($oblongs{$to}); if ($inBag < 1) { $UBERENV{'MESSAGE'} .= qq(YOU HAVE NO OBLONGS IN YOUR BAG.); return; } if ($inBag < $num) { $UBERENV{'MESSAGE'} .= qq(YOU ONLY HAVE $num OBLONGS IN YOUR BAG.); return; } if ($to eq $username) { $UBERENV{'MESSAGE'} .= qq(A-AH! NO CHEATING NOW.); return; } reset_date_time(); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); my $week_commencing = date_manip("-nMON -d-7 $YYYYMMDD"); my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${week_commencing}.log"; open (FLOG, ">>$log_fname") or log_error("process_give_oblongs - failed to open file $log_fname"); print FLOG qq($YYYYMMDD;$timestamp;$username;$to;$num;$reason;\n); close(FLOG); # my $oblongs = qq(oblong); # $oblongs = qq(oblongs) if ($num > 1); my $text = plural("oblong", $num); # pass this on to oblongs_page $UBERENV{'MESSAGE'} .= qq(You have given $to_name $text for "$reason"); my $mailname = qq(Pooclub Oblongs); my $subject = qq($name has given $to_name $text); my $message = qq($subject Reason: $reason To send or fine an oblong go to: http://pooclub.shite.org/oblongs ); email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "$mailname"); log_action("$name [$username] gave $to_name [$to] $num oblong(s) for \"$reason\""); } ############################################################ sub process_fine_oblongs { my %players = {}; my @ids = (); $UBERENV{'MESSAGE'} = ""; if (! is_logged_in()) { $UBERENV{'MESSAGE'} = qq(FAILED - You are not logged in.); log_action("ALERT process_fine_oblongs failed - not logged in."); return; } my $to = $cgi->param('to'); my $num = -1; # Currently, can only fine one oblong at a time my $reason = $cgi->param('reason'); my $username = $UBERACC{'USERNAME'}; read_players_file(\@ids, \%players); my $to_name = $players{$to}; my $name = $players{$username}; # For validation my %names = {}; my %bag = {}; my %oblongs = {}; read_oblong_files(\%names, \%oblongs, \%bag, \@ids); my $inBag = int($bag{$username}) + 5; # TODO: Why do I have to add 5 here? my $myTrophy = int($oblongs{$username}); my $toTrophy = int($oblongs{$to}); if ($myTrophy < 1) { $UBERENV{'MESSAGE'} .= qq(YOU HAVE NO OBLONGS IN THE TROPHY CABINET.); return; } if ($toTrophy < 1) { $UBERENV{'MESSAGE'} .= qq($players{$to} HAS NO OBLONGS TO FINE.); return; } if ($to eq $username) { $UBERENV{'MESSAGE'} .= qq(YOU WANT TO FINE YOURSELF? TWAT.); return; } # write this action in the oblog reset_date_time(); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); my $week_commencing = date_manip("-nMON -d-7 $YYYYMMDD"); my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${week_commencing}.log"; open (FLOG, ">>$log_fname") or log_error("process_fine_oblongs - failed to open file $log_fname"); print FLOG qq($YYYYMMDD;$timestamp;$username;$to;$num;$reason;\n); close(FLOG); # pass this on to oblongs_page $UBERENV{'MESSAGE'} = qq(You have fined $to_name [$to] an oblong for "$reason"); my $mailname = qq(Pooclub Oblongs); my $subject = qq($name has fined $to_name an oblong); my $message = qq($subject Reason: $reason To send or fine an oblong go to: http://pooclub.shite.org/oblongs ); email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "$mailname"); log_action("$name [$username] fined $to_name [$to] an oblong for \"$reason\""); } ############################################################ # # process the purchase of an oblottery ticket sub process_buy_ticket { my %players = {}; my @ids = (); $UBERENV{'MESSAGE'} = ""; if (! is_logged_in()) { $UBERENV{'MESSAGE'} = qq(FAILED - You are not logged in.); log_action("ALERT process_buy_ticket failed - not logged in."); return; } my $ticket_num = $cgi->param('ticket'); my $username = $UBERACC{'USERNAME'}; read_players_file(\@ids, \%players); my $name = $players{$username}; reset_date_time(); # For validation my %names = {}; my %bag = {}; my %oblongs = {}; read_oblong_files(\%names, \%oblongs, \%bag, \@ids); my $myTrophy = int($oblongs{$username}); if ($myTrophy < 1) { $UBERENV{'MESSAGE'} .= qq(YOU HAVE NO OBLONGS IN THE TROPHY CABINET.); return; } my $dow = date_manip("-fDOW $YYYYMMDD"); if (($dow eq "Wed") && ($Hour > 18)) { $UBERENV{'MESSAGE'} .= qq(OBLOTTERY TICKETS CANNOT BE BOUGHT BETWEEN 6PM AND MIDNIGHT ON WEDNESDAYS.); return; } my $ticket_available = 1; #$UBERENV{'MESSAGE'} .= qq(ticket_num=$ticket_num ); my $oblottery_fname = latest_oblottery_filename(); open (BLOT, "$oblottery_fname"); while() { chop; my ($yyyymmdd, $hhmmss, $user, $ticket) = split /;/, $_; #$UBERENV{'MESSAGE'} .= qq(ticket=$ticket ); if ($ticket eq $ticket_num) { $ticket_available = 0; last; } } close(BLOT); if ($ticket_available == 0) { $UBERENV{'MESSAGE'} .= qq(OBLOTTERY TICKET NUMBER $ticket_num HAS ALREADY BEEN BOUGHT.); return; } # write this purchase in the oblog my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); my $week_commencing = date_manip("-nMON -d-7 $YYYYMMDD"); my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${week_commencing}.log"; open (FLOG, ">>$log_fname") or log_error("process_buy_ticket - failed to open file $log_fname"); print FLOG qq($YYYYMMDD;$timestamp;pooclub;$username;-1;Bought oblottery ticket $ticket_num;\n); close(FLOG); my $oblottery_fname = latest_oblottery_filename(); # also record the purchase in the current game's oblottery file open (LOTLOG, ">>$oblottery_fname") or log_error("process_buy_ticket - failed to open file $oblottery_fname"); print LOTLOG qq($YYYYMMDD;$timestamp;$username;$ticket_num;\n); close(LOTLOG); # pass this info on to oblongs_page $UBERENV{'MESSAGE'} = qq(You have bought oblottery ticket number $ticket_num); # tell the rest of pooclub my $jackpot = plural("oblong", oblottery_jackpot()); my $mailname = qq(Pooclub Oblongs); my $subject = qq($name has bought oblottery ticket number $ticket_num); my $message = qq($subject The jackpot is now an estimated $jackpot To play pooclub's oblottery go to: http://pooclub.shite.org/oblongs ); email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "$mailname"); log_action("$name [$username] bought oblottery ticket number $ticket_num"); } # \process_buy_ticket ############################################################ sub show_oblog_header { print qq(

); } ############################################################ # # called by pooclub_oblog.html sub show_the_oblog { # my ($names) = @_; my %names = {}; my %dobs = {}; my @id_list = (); read_players_file(\@id_list, \%names, \%dobs); my $yyyy = $cgi->param('yyyy'); my $this_year = date_manip("-fYYYY $YYYYMMDD"); my @log_years = (); while($this_year >= 2010) { push @log_years, $this_year; $this_year--; } # print qq( #
# # The Oblog #

# ); if ($yyyy eq "") { print qq(recent log); } else { print qq(recent log); } for $log_year (@log_years) { if ($log_year eq $yyyy) { print qq( | $log_year); } else { print qq( | $log_year); } } show_oblog_header(); if ($yyyy eq "" ) # show this week's and last week's logs { my $last_week = date_manip("-nMON -d-14 $YYYYMMDD"); my $last_week_oblog_fname = "${SHAREDROOT}/oblongs/oblongs_${last_week}.log"; show_oblog_file(\%names, $last_week_oblog_fname); $this_week = date_manip("-nMON -d-7 $YYYYMMDD"); my $this_week_oblog_fname = "${SHAREDROOT}/oblongs/oblongs_${this_week}.log"; show_oblog_file(\%names, $this_week_oblog_fname); } else # show a whole year of logs { my @fnames = (sort <${SHAREDROOT}/oblongs/oblongs_${yyyy}*.log>); # glob for $fname (@fnames) { show_oblog_file(\%names, $fname); } } show_oblog_footer(); # my $obliteration_yyyymmdd = next_obliteration_yyyymmdd($YYYYMMDD); # # my $ob_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $obliteration_yyyymmdd"); # print qq(

Next Obliteration Date: $ob_date

); } ############################################################ sub show_oblog_file { # my ($players, $week_commencing) = @_; # # $$week_commencing = date_manip("-nMON -d-7 $YYYYMMDD") if ($$week_commencing eq ""); # # my $oblog_fname = "${SHAREDROOT}/oblongs/oblongs_$${week_commencing}.log"; my ($players, $oblog_fname) = @_; # Read oblong log open (LOG, "$oblog_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $time, $from, $to, $points, $reason) = split /;/, $_; my $date = date_manip("-fDOW_DD_MON $yyyymmdd"); my $colour = "black"; if (($points < 0) && !($reason =~ /Bought oblottery ticket/)) { $points = qq(Fine $points); $colour = "red"; } print qq(

); } close(LOG); } ############################################################ ## to be deprecated sub show_oblog { my ($players, $week_commencing) = @_; $$week_commencing = date_manip("-nMON -d-7 $YYYYMMDD") if ($$week_commencing eq ""); my $oblog_fname = "${SHAREDROOT}/oblongs/oblongs_$${week_commencing}.log"; # Read oblong log open (LOG, "$oblog_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $time, $from, $to, $points, $reason) = split /;/, $_; my $date = date_manip("-fDOW_DD_MON $yyyymmdd"); my $colour = "black"; if ($points < 0) { $points = qq(Fine $points); $colour = "red"; } print qq( ); } close(LOG); } ############################################################ sub show_oblog_footer { print qq(
Date Time From To Oblongs Reason
$date $time $$players{$from} $$players{$to} $points $reason
$date $time $$players{$from} $$players{$to} $points $reason
); } ############################################################ sub read_players_file { my ($id_list, $names, $dobs) = @_; my $play_fname = "${SHAREDROOT}/oblongs/players.dat"; open (PLAY, "$play_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($id, $name, $dob) = split /;/, $_; $$names{$id} = $name; $$dobs{$id} = $dob; push @$id_list, $id if ($id ne "pooclub"); } close(PLAY); } ############################################################ sub read_oblong_files { my ($players, $oblongs, $bag, $ids, $week_commencing) = @_; log_info("read_oblong_files - week_commencing=$week_commencing"); if ($week_commencing eq "") { $week_commencing = date_manip("-nMON -d-7 $YYYYMMDD"); log_info("read_oblong_files - week_commencing=$week_commencing YYYYMMDD=$YYYYMMDD"); } my $sow_fname = "${SHAREDROOT}/oblongs/oblongs_${week_commencing}.dat"; my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${week_commencing}.log"; # Players start each week with 5 oblongs in their bag for my $id (keys %$players) { $$bag{$id} = 5; } # Read start of week file log_info("read_oblong_files - reading start of week file: $sow_fname"); open (SOW, "$sow_fname") or log_error("read_oblong_files - cannot read start of week file: $sow_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($id, $obs) = split /;/, $_; $$oblongs{$id} += $obs; # push @$ids, $id; #print qq($name --> $$oblongs{$id}, $$bag{$id}
); } close(SOW); # Add oblongs from this week's oblog log_info("read_oblong_files - reading oblog file: $log_fname"); open (LOG, "$log_fname") or log_error("read_oblong_files - cannot read oblog file: $log_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $time, $from, $to, $points, $reason) = split /;/, $_; $$oblongs{$to} += $points; if ($points < 0) { if ($from ne $to) # finer must lose an oblong { $$oblongs{$from} += $points; # add -ve number of oblongs } } else { $$bag{$from} -= $points; } } close(LOG); } ############################################################ sub show_oblong_message { my $message = $UBERENV{'MESSAGE'}; if ($message ne "") { print qq(

$message

); log_info("message=$message"); } } ############################################################ sub show_trophy_cabinet { my ($players, $oblongs, $bag, $idList, $img) = @_; my $imgOblong = qq(); my $imgTen = qq(); my $bgcolor = "white"; # read oblottery ticket numbers for each player my $ticketFilename = latest_oblottery_filename(); my %ticketListHash = {}; open (TICKETS, $ticketFilename) or log_info("WARNING: Cannot open oblottery file: $ticketFilename"); while() { my ($yyyymmdd, $hhmmss, $user, $ticket) = split /;/, $_; push @{ $ticketListHash{$user} }, $ticket; } close(TICKETS); #print qq(
); print qq( ); $bgcolor = "#e0e0e0"; for my $id (@$idList) # Display oblongs { # next if ($id =~ /HASH/); # next if ($id eq "pooclub"); next if ($id eq "brian"); my $obs = int($$oblongs{$id}); my $inBag = int($$bag{$id}); print qq( ); # # if user has oblottery tickets show them # my $num_tickets = scalar(@{ $ticketListHash{$id} }); # if ($num_tickets > 0) # { # print qq( # # # # # # # # ); # } } print qq(
  Trophy cabinet oblongs Bag Oblottery tickets
$$players{$id} $obs ); for (my $i = 1; $i <= $obs / 10; $i++) { print qq($imgTen ); } for (my $i = 0; $i < $obs % 10; $i++) { print qq($imgOblong ); } print qq( ); for (my $i = 0; $i < $inBag; $i++) { print qq($imgOblong ); } print qq( ); for my $ticket ( sort {$a <=> $b} @{ $ticketListHash{$id} }) { display_oblottery_ticket($ticket); } print qq(
   $num_tickets Oblottery ticket); # print "s" if ($num_tickets > 1); # print ":"; # for my $ticket ( sort @{ $ticketListHash{$id} }) # { # print qq( $ticket ); # } # print qq( #  

); show_oblong_menu("oblongs", "only"); print qq(

); } ############################################################ sub show_oblong_form { my ($players, $oblongs, $bag, $ids, $img) = @_; my $give_disabled = ""; my $fine_disabled = ""; my $username = $UBERACC{'USERNAME'}; my $name = $$players{$username}; # my ($champ, $image) = current_corner_champ(); # print qq( #
# Current Corner Champion

#

$champ
#

# - see The Big Oblong. # ); print qq(

); if ($username eq "") { print qq( You need to be logged in to award oblongs.

); $give_disabled = qq(disabled="disabled"); $fine_disabled = qq(disabled="disabled"); } elsif ($name eq "") { print qq( You need to be added to the oblong group to award oblongs. Please ask an administrator at the forum.

); $give_disabled = qq(disabled="disabled"); $fine_disabled = qq(disabled="disabled"); } # 'Give' form print qq(

In your bag: ); for (my $i = 1; $i <= $$bag{$username}; $i++) { print qq($img ); } print qq(
Give
Reason
(optional)

); # 'Fine' form my $warning = qq(Warning: You will be charged one oblong for submitting a fine.); $warning = qq(You can only fine someone if you have an oblong in the trophy cabinet.) if ($$oblongs{$username} < 1); print qq(

  $warning
           Fine 1 oblong
Reason
(optional)

); # if ($FISH eq "27") { # TMP # 'Oblottery' form $disabled = ""; my $jackpot = oblottery_jackpot(); reset_date_time(); my $draw_yyyymmdd = $YYYYMMDD; my $dow = date_manip("-fDOW $draw_yyyymmdd"); if ($dow ne "Wed") { $draw_yyyymmdd = date_manip("-nWED $draw_yyyymmdd"); } my $draw_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $draw_yyyymmdd"); print qq(
Oblottery

); $warning = qq(An oblottery ticket will cost you one oblong from the trophy cabinet.); if (($dow eq "Wed") && ($Hour > 18)) { $warning = qq(The oblottery is currently closed.); $disabled = qq(disabled="disabled"); } else { print qq( The next draw date is on ${draw_date}. This week's jackpot is currently an estimated $jackpot oblongs! ); } print qq(

      $warning
      Buy oblottery ticket number

Tell me interesting stuff about this oblottery thing
); # } # TMP } ############################################################ sub oblong_page { my %names = {}; my %dobs = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); my $imgOblong = qq(); read_players_file(\@id_list, \%names, \%dobs); read_oblong_files(\%names, \%oblongs, \%bag, \@id_list); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; display_oblong_page_header(\%names, \%oblongs, \@ids); print qq(
The Oblong Table ); show_oblong_message(); show_trophy_cabinet(\%names, \%oblongs, \%bag, \@ids, $imgOblong); show_oblong_form(\%names, \%oblongs, \%bag, \@ids, $imgOblong); # show_the_oblog(\%names); } ############################################################ sub update_weekly_oblongs { my $dow = date_manip("-fDOW $YYYYMMDD"); log_info("update_weekly_oblongs - dow=$dow"); return if ($dow ne $MONDAY); # Only do it on Mondays log_info("update_weekly_oblongs - it's $MONDAY"); my $ob_yyyymmdd = next_obliteration_yyyymmdd($YYYYMMDD); log_info("update_weekly_oblongs - ob_yyyymmdd=$ob_yyyymmdd YYYYMMDD=$YYYYMMDD"); if (can_obliterate() == 1) { log_info("update_weekly_oblongs - can obliterate"); # obliterate_oblongs(); # 06/01/2011 removed this duplicated call return; # don't do normal weekly oblong update } my %players = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); read_players_file(\@id_list, \%players); log_info("update_weekly_oblongs - A YYYYMMDD=$YYYYMMDD"); $YYYYMMDD = date_manip("-d-7 $YYYYMMDD"); # don't like this log_info("update_weekly_oblongs - B YYYYMMDD=$YYYYMMDD"); $lastMonday = date_manip("-d-7 $YYYYMMDD"); log_info("update_weekly_oblongs - C YYYYMMDD=$YYYYMMDD"); log_info("update_weekly_oblongs - lastMonday=$lastMonday"); read_oblong_files(\%players, \%oblongs, \%bag, \@id_list, $lastMonday); log_info("update_weekly_oblongs - D YYYYMMDD=$YYYYMMDD"); $YYYYMMDD = date_manip("-d7 $YYYYMMDD"); # don't like this log_info("update_weekly_oblongs - E YYYYMMDD=$YYYYMMDD"); reset_date_time(); log_info("update_weekly_oblongs - F YYYYMMDD=$YYYYMMDD"); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); my $sow_fname = "${SHAREDROOT}/oblongs/oblongs_${YYYYMMDD}.dat"; my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${YYYYMMDD}.log"; log_info("update_weekly_oblongs - writing new oblongs file $sow_fname"); open (SOW, ">$sow_fname") or log_error("update_weekly_oblongs - cannot write new oblongs file $sow_fname"); print SOW qq( # Week commencing $YYYYMMDD # reset time: $timestamp #id,oblongs ); for my $id (@id_list) { # write players' oblong counts for start of week my $num = int($oblongs{$id}); print SOW qq($id;$num\n); } close(SOW); log_info("update_weekly_oblongs - writing new oblongs log $log_fname"); open (LOGG, ">$log_fname") or log_error("update_weekly_oblongs - cannot write new oblongs log $log_fname"); print LOGG qq( # Oblong log - week commencing $YYYYMMDD # reset time: $timestamp #yyyymmdd;HH:MM:SS;from;to;oblongs;reason; ); for my $id (@id_list) { my $intBag = int($bag{$id}); my $intOblongs = int($oblongs{$id}); log_info("update_weekly_oblongs - id=$id bag=$intBag oblongs=$intOblongs"); if ($intBag < 1) # Player gave away all oblongs from bag last week { print LOGG qq($YYYYMMDD;$timestamp;pooclub;$id;1;Generosity bonus;\n); log_action("$players{$id} [$id] gained a generosity bonus oblong"); } if (($intBag > 4) && ($intOblongs > 0)) # Player gave away no oblongs from bag last week { print LOGG qq($YYYYMMDD;$timestamp;pooclub;$id;-1;Scrooge penalty;\n); log_action("$players{$id} [$id] incurred a scrooge penalty oblong"); } } close(LOGG); } ############################################################ # # Only call this on an obliterate date. # It must be done INSTEAD OF update_weekly_oblongs sub obliterate_oblongs { log_info("---------------------------------------------"); log_info("obliterate_oblongs - YYYYMMDD=$YYYYMMDD"); my $ob_yyyymmdd = next_obliteration_yyyymmdd($YYYYMMDD); log_info("obliterate_oblongs - ob_yyyymmdd=$ob_yyyymmdd"); return if (can_obliterate($YYYYMMDD) == 0); # it's not an obliteration date log_info("obliterate_oblongs - it's an obliteration date"); log_info("obliterate_oblongs - *** OBLITERATE OBLONGS! ***"); my %players = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); my $last_week = date_manip("-d-7 $YYYYMMDD"); my $this_week = $YYYYMMDD; log_info("obliterate_oblongs - last_week=$last_week"); log_info("obliterate_oblongs - this_week=$this_week"); read_players_file(\@id_list, \%players); # Prior to October 2013 fix # $YYYYMMDD = date_manip("-d-7 $YYYYMMDD"); # nasty hack # read_oblong_files(\%players, \%oblongs, \%bag, \@id_list); # $YYYYMMDD = date_manip("-d7 $YYYYMMDD"); log_info("obliterate_oblongs - calling read_oblong_files for last_week=$last_week"); read_oblong_files(\%players, \%oblongs, \%bag, \@id_list, $last_week); # Oct 2013 fix reset_date_time(); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); my $prev_sow_fname = "${SHAREDROOT}/oblongs/oblongs_${last_week}.dat"; my $prev_log_fname = "${SHAREDROOT}/oblongs/oblongs_${last_week}.log"; my $new_sow_fname = "${SHAREDROOT}/oblongs/oblongs_${this_week}.dat"; my $new_log_fname = "${SHAREDROOT}/oblongs/oblongs_${this_week}.log"; my $corners_fname = "${SHAREDROOT}/oblongs/corners_${YYYYMMDD}.dat"; # deprecate my $bigoblong_table_fname = "${SHAREDROOT}/oblongs/bigoblong_table_${YYYYMMDD}.dat"; my $bigoblong_fname = "${SHAREDROOT}/oblongs/bigoblong.dat"; # obliterate_oblongs differs from update_weekly_oblongs # in that we append the bonus oblongs to end of last week's log file log_info("obliterate_oblongs - appending bonus oblongs to old log file: $prev_log_fname"); open (OLDLOG, ">>$prev_log_fname") or log_error("obliterate_oblongs - cannot write bonus oblongs to old log file: $prev_log_fname"); print OLDLOG qq( # End of obliteration period ); for my $id (@id_list) { my $intBag = int($bag{$id}); my $intOblongs = int($oblongs{$id}); log_info("obliterate_oblongs - for: id=$id bag=$intBag oblongs=$intOblongs"); if ($intBag < 1) # Player gave away all oblongs from bag last week { $oblongs{$id}++; print OLDLOG qq(${YYYYMMDD};${timestamp};pooclub;${id};1;Generosity bonus;\n); log_action("$players{$id} [$id] gained a generosity bonus oblong"); } if (($intBag > 4) && ($intOblongs > 0)) # Player gave away no oblongs from bag last week { $oblongs{$id}--; print OLDLOG qq(${YYYYMMDD};${timestamp};pooclub;${id};-1;Scrooge penalty;\n); log_action("$players{$id} [$id] incurred a scrooge penalty oblong"); } } close(OLDLOG); # Backup the current oblongs data file log_info("obliterate_oblongs - backing up oblongs data file: $prev_sow_fname"); open (SAVED, ">${prev_sow_fname}.saved") or log_error("obliterate_oblongs - cannot write saved oblongs file: ${prev_sow_fname}.saved"); open (OLDSOW, "$prev_sow_fname") or log_error("obliterate_oblongs - cannot read start of week oblongs file: $prev_sow_fname"); while() { print SAVED $_; } close(OLDSOW); close(SAVED); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; # Write new start of week oblong file with no oblongs for each player. log_info("obliterate_oblongs - writing new (empty) oblongs data file: $new_sow_fname"); open (NEWSOW, ">$new_sow_fname") or log_error("obliterate_oblongs - cannot write new oblongs file $new_sow_fname"); print NEWSOW qq( # Week commencing $YYYYMMDD # reset time: $timestamp #id;oblongs; ); for my $id (@id_list) { # write players' oblong counts for start of week print NEWSOW qq($id;0\n); } close(NEWSOW); # Write new log file with initial numbers of oblongs. # Last quarter's winner start with 3 oblongs, # the runner up starts with 2 oblongs # and the third place holder has 1 oblong. log_info("obliterate_oblongs - writing new oblongs log file $new_log_fname"); my $num_oblongs = 3; open (NEWLOG, ">$new_log_fname") or log_error("obliterate_oblongs - cannot write new oblongs log file $new_log_fname"); print NEWLOG qq( # Week commencing $YYYYMMDD # reset time: $timestamp #id;oblongs; ); print NEWLOG qq( # Oblong log - week commencing $this_week # reset time: $timestamp #yyyymmdd;HH:MM:SS;from;to;oblongs;reason; $this_week;$timestamp;pooclub;$ids[0];3;Corner Champion; $this_week;$timestamp;pooclub;$ids[1];2;Corner Runner Up; $this_week;$timestamp;pooclub;$ids[2];1;Corner Third Place; ); close(NEWLOG); # Write the new oblong corners file - deprecate this log_info("obliterate_oblongs - writing new oblong corners file: $corners_fname"); open (COR, ">$corners_fname") or log_error("obliterate_oblongs - cannot write oblong corners file: $corners_fname"); print COR qq( # Oblong Corners file $YYYYMMDD $timestamp #id;oblongs; ); for my $id (@id_list) { print COR qq(${id};$oblongs{$id};\n); } close(COR); log_info("obliterate_oblongs - calling: write_bigoblong_table_file"); write_bigoblong_table_file(); # Add an entry to the big oblong file log_info("obliterate_oblongs - appending winner to big oblong file: $bigoblong_fname"); my $mm = substr($YYYYMMDD, 4, 2); my $year = substr($YYYYMMDD, 0, 4); my $month = $MonthList[$mm - 1]; open (BIG, ">>$bigoblong_fname") or log_error("obliterate_oblongs - cannot write to big oblong file: $bigoblong_fname"); print BIG qq(${YYYYMMDD};$month;$year;$ids[0];$players{$ids[0]}; ); close(BIG); log_info("obliterate_oblongs - end"); log_info("============================================="); } # obliterate_oblongs ############################################################ sub check_for_birthday_oblongs { log_info("check_for_birthday_oblongs"); my %names = {}; my %dobs = {}; my @id_list = (); my $week_commencing = date_manip("-nMON -d-7 $YYYYMMDD"); my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${week_commencing}.log"; reset_date_time(); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); read_players_file(\@id_list, \%names, \%dobs); for my $id (@id_list) { my $dob = $dobs{$id}; if ($dob) { my $today = $YYYYMMDD % 10000; # chop year my $ndays = date_manip("-c $dob $YYYYMMDD"); my $bday = 0; $bday = 1 if (($dob % 10000) == $today); # is birthday my $daystok = 1000 - ($ndays % 1000); my $nextk = int($ndays / 1000) + 1; #print qq($names{$id} dob=$dob bday=$bday ndays=$ndays daystok=$daystok nextk=$nextk
); my $name = $names{$id}; if ($bday == 1) { open(BLOG, ">>$log_fname") or log_error("check_for_birthday_oblongs - (bday) cannot open log file $log_fname"); print BLOG qq($YYYYMMDD;$timestamp;pooclub;$id;1;Happy birthday!;\n); log_action("$name [$id] gained a birthday oblong"); close(BLOG); my $mailname = qq(Pooclub Oblongs); my $subject = qq(Happy birthday, ${name}!); my $message = qq($subject pooclub has awarded you a special birthday oblong! If other pooclubbers would like to give $name an oblong, please go to: http://pooclub.shite.org/oblongs ); email_notify($UBERENV{'GROUP_EMAIL'}, $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "$mailname"); } my $k = int($ndays / 1000); if (($k > 0) && (($daystok == 0) || ($daystok == 1000)) ) # is k-day { open(BLOG, ">>$log_fname") or log_error("check_for_birthday_oblongs - (kday) cannot open log file $log_fname"); print BLOG qq($YYYYMMDD;$timestamp;pooclub;$id;3;Happy k-day!;\n); log_action("$name [$id] gained 3 k-day oblongs for being ${k},000 days old today"); close(BLOG); my $mailname = qq(Pooclub Oblongs); my $subject = qq(Happy k-day, ${name}!); my $message = qq($subject You are ${k},000 days old today, and pooclub has awarded you 3 special k-day oblongs! If other pooclubbers would like to give $name an oblong, please go to: http://pooclub.shite.org/oblongs ); email_notify($UBERENV{'GROUP_EMAIL'}, $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "$mailname"); } } } } ############################################################ # # called by pooclub_oblongz.html sub show_poochoonz_oblongz { print qq( Here's what our playerz have won so far. ); my $choonzFname = qq(${SHAREDROOT}/poochoonz_winnerz.dat); my @winners = (); my %oblongs = {}; my @lines = (); open (CHOONZ, "$choonzFname") or log_error("show_poochoonz_oblongz - cannot open choonz file: $choonzFname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($num, $month, $meister, $winner, $artist, $song, $theme) = split /;/, $_; push @winners, $winner if (! $oblongs{$winner}); $oblongs{$winner}++; push @lines, $_; } close(CHOONZ); # for my $name (@winners) # { # print qq(name=$name oblongs=$oblongs{$name}
); # } my $img = qq(); print qq( ); my @sorted_winners = sort {$oblongs{$b} <=> $oblongs{$a}} @winners; for my $id (@sorted_winners) # Display oblongs { next if (! $id); my $obs = int($oblongs{$id}); print qq( ); } print qq(
       
$id   $obs ); for (my $i = 0; $i < $oblongs{$id}; $i++) { print qq($img ); } print qq( $inBag

); # Show details of each month's play print qq( ); for my $line (@lines) { # print qq(line=$line
); my ($num, $month, $meister, $winner, $artist, $song, $theme) = split /;/, $line; my ($mon, $year) = split / /, $month; $mon = substr($mon, 0, 3); print qq( ); } print qq(
    Month Choonmeister Winner Artist Song Theme
${num}:   $mon $year $meister $winner $artist $song $theme

); } ############################################################ # # called by pooclub_oblongz.html sub input_poochoonz_oblongz { my $contents = ""; my $disabled = ""; my $fname = "${SHAREDROOT}/poochoonz_winnerz.dat"; if ($UBERACC{'PRIVILEGE'} > 2) { open (OBLONGS, $fname); while() { $contents .= $_; } close(OBLONGS); print qq(

Admin: $fname

); } } ############################################################ # # return current oblottery filename sub latest_oblottery_filename { my @fnames = (reverse sort <${SHAREDROOT}/oblottery/tickets_*.log>); # glob my $latest_fname; if (scalar (@fnames) > 0) { $latest_fname = $fnames[0]; } else # there are no files yet { $latest_fname = new_oblottery_filename(); } return $latest_fname; } ############################################################ # # start the next oblottery file sub new_oblottery_filename { $fname = qq(${SHAREDROOT}/oblottery/tickets_${YYYYMMDD}.log); log_info("new_oblottery_filename - creating new oblottery file: $fname"); open (NEW, ">>$fname") or log_error("new_oblottery_filename - failed to touch new file: $fname"); print NEW "# oblottery file starting: $YYYYMMDD\n"; close(NEW); return $fname; } ############################################################ sub oblottery_jackpot { my $jackpot = 0; my $fname = latest_oblottery_filename(); open (JACKPOT, $fname); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $hhmmss, $user, $ticket) = split /;/, $_; $jackpot++ if ($ticket > 0); } close(JACKPOT); return $jackpot; } ############################################################ sub check_oblottery_draw { my $dow = date_manip("-fDAYOFWEEK $YYYYMMDD"); if ($dow eq "Thursday") # check the Wednesday draw { # find latest Wednesday my $wednesday_yyyymmdd = date_manip("-d-7 $YYYYMMDD"); $wednesday_yyyymmdd = date_manip("-nWED $wednesday_yyyymmdd"); # TODO: uncomment my $dd = substr($wednesday_yyyymmdd, 6, 2); my $yyyy = substr($wednesday_yyyymmdd, 0, 4); my $mon = date_manip("-fMON $wednesday_yyyymmdd"); my $wednesday = "${dd}-${mon}-${yyyy}"; my $draw_fname = get_remote_lottery_file(); log_info("Oblottery wednesday=$wednesday draw_fname=$draw_fname"); my $winning_ball = 0; open (DRAW, "$draw_fname"); if (! DRAW) { log_info("ERROR: Cannot read draw file: $draw_fname"); # notify group by email my $subject = "This Week's Draw"; my $message = qq( Oh dear, the draw file failed to be collected from the National Lottery. Can you all please badger Mike into doing a manual oblottery draw if it looks like there might be a winner. ); email_notify($UBERENV{'GROUP_EMAIL'}, $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Oblottery"); return; } # open (DRAW, "$draw_fname") # or log_info("WARNING: Cannot read draw file: $draw_fname"); while() { chop; my ($draw_date, $b1, $b2, $b3, $b4, $b5, $b6, $bonus, $set, $machine) = split /,/, $_; if ($draw_date eq $wednesday) { $winning_ball = $bonus; # the bonus ball log_info("WINNING LOTTERY BALL FOR $wednesday: $winning_ball"); } } close(DRAW); log_info("winning_ball=$winning_ball"); if ($winning_ball < 1) { log_info("ERROR: Cannot get winning ball."); # notify group by email my $subject = "This Week's Draw"; my $message = qq( Oh dear, the National Lottery has failed to tell us the winning ball. Can you all please badger Mike into doing a manual oblottery draw if it looks like there might be a winner. ); email_notify($UBERENV{'GROUP_EMAIL'}, $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Oblottery"); return; } my $jackpot = oblottery_jackpot(); # Now check for a winner my $winner = "Nobody"; my $oblottery_fname = latest_oblottery_filename(); open (OBLOT, "$oblottery_fname") or log_error("check_oblottery_draw - cannot open oblottery file: $oblottery_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($datestamp, $timestamp, $userid, $ticket_num) = split /;/, $_; if ($ticket_num == $winning_ball) { $winner = $userid; last; } } close(OBLOT); if ($winner eq "Nobody") { log_info("No oblottery winner - it's a rollover"); # notify group by email my $subject = "This Week's Draw"; my $message = qq( This week's winning lottery draw is ball number $winning_ball Nobody won the jackpot of $jackpot oblongs so we will go into a rollover next week. For more oblong fun: http://pooclub.shite.org/oblongs ); email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Oblottery"); } else # We have a winner! { my @id_list = (); my %names = {}; my %dobs = {}; read_players_file(\@id_list, \%names, \%dobs); my $winner_name = $names{$winner}; log_info("Oblottery winner - $winner_name [$winner] wins the jackpot of $jackpot oblongs"); # Add the prize to the oblog reset_date_time(); my $timestamp = sprintf ("%02d:%02d:%02d", $Hour, $Min, $Sec); my $week_commencing = date_manip("-nMON -d-7 $YYYYMMDD"); my $log_fname = "${SHAREDROOT}/oblongs/oblongs_${week_commencing}.log"; open (FLOG, ">>$log_fname") or log_error("check_oblottery_draw - failed to open file $log_fname"); print FLOG qq($YYYYMMDD;$timestamp;pooclub;$winner;$jackpot;Oblottery jackpot (ball number $winning_ball);\n); close(FLOG); # Start a new, empty, oblottery tickets file my $oblottery_fname = new_oblottery_filename(); # notify group by email my $subject = "This Week's Draw"; my $message = qq( This week's winning lottery draw is ball number $winning_ball $winner_name wins $jackpot oblongs! For more oblong fun: http://pooclub.shite.org/oblongs ); email_notify($UBERENV{'GROUP_EMAIL'}, # email_notify($UBERENV{'EMAIL'}, # mike2sheds@gmail.com $UBERENV{'ADMIN_EMAIL'}, "$subject", "$message", "Oblottery"); } # if winner # Record the oblottery draw my $draws_fname = "${SHAREDROOT}/oblottery/draws.log"; open (OBDRAWS, ">>$draws_fname") or log_error("check_oblottery_draw - failed to open draws file: $draws_fname"); print OBDRAWS qq($YYYYMMDD;$jackpot;$winning_ball;$winner; ); close(OBDRAWS); } # if Thursday } ############################################################ sub next_obliteration_yyyymmdd { my ($current_yyyymmdd) = @_; log_info("next_obliteration_yyyymmdd - switch current_yyyymmdd=$current_yyyymmdd"); $yyyymmdd_old = next_obliteration_yyyymmdd_old($current_yyyymmdd); $yyyymmdd_new = next_obliteration_yyyymmdd_new($current_yyyymmdd); log_info("next_obliteration_yyyymmdd($from_yyyymmdd) - old=$yyyymmdd_old new=$yyyymmdd_new"); return $yyyymmdd_new; } ############################################################ sub next_obliteration_yyyymmdd_old { log_info("next_obliteration_date_old"); my ($from_yyyymmdd) = @_; $from_yyyymmdd = $YYYYMMDD if ($from_yyyymmdd eq ""); my $yyyy = substr($from_yyyymmdd, 0, 4); my $mm = substr($from_yyyymmdd, 4, 2); my $dd = substr($from_yyyymmdd, 6, 2); my $yyyymm21 = $yyyy . $mm . "21"; $yyyymm21 = add_a_month($yyyymm21) if ($dd > 21); # next month if after 21st # find next quarter $mm = substr($yyyymm21, 4, 2); my $mod3 = $mm % 3; if ($mod3 == 2) { $yyyymm21 = add_a_month($yyyymm21); } if ($mod3 == 1) { $yyyymm21 = add_a_month($yyyymm21); $yyyymm21 = add_a_month($yyyymm21); } my $yyyymmdd = date_manip("-d-3 $yyyymm21"); $yyyymmdd = date_manip("-nMON $yyyymmdd"); return $yyyymmdd; } ############################################################ # # an alternative method for getting the next obliteration # date. # It relies upon a maintained file of obliteration dates # in chronological order. # If today is an obliteration date the method returns # today's YYYYMMDD and will not return a future # obliteration date sub next_obliteration_yyyymmdd_new { log_info("next_obliteration_yyyymmdd_new"); $oblit_yyyymmdd = ''; my $fname = "${SHAREDROOT}/oblongs/obliteration_dates.list"; #print qq(fname=$fname
); open (OBLIT, "$fname") or log_error("next_obliteration_yyyymmdd_new - cannot open file: $fname"); while() { chop; # log_info("next_obliteration_yyyymmdd - while: _=$_"); next if (/^\s*$/); next if (/^#/); if ($_ >= $YYYYMMDD) { $oblit_yyyymmdd = $_; # log_info("next_obliteration_yyyymmdd - last: oblit_yyyymmdd=$yyyymmdd"); last; } } close(OBLIT); return $oblit_yyyymmdd; } ############################################################ sub add_a_month { my ($from_yyyymmdd) = @_; $from_yyyymmdd = $YYYYMMDD if ($from_yyyymmdd eq ""); my $yyyy = substr($from_yyyymmdd, 0, 4); my $mm = substr($from_yyyymmdd, 4, 2); my $dd = substr($from_yyyymmdd, 6, 2); $mm++; if ($mm > 12) { $yyyy++; $mm -= 12; } my $to_yyyymmdd = sprintf ("%04d%02d%02d", $yyyy, $mm, $dd); return $to_yyyymmdd; } ############################################################ sub check_for_obliteration_date { log_info("check_for_obliteration_date"); my $obliteration_yyyymmdd = next_obliteration_yyyymmdd(); log_info("check_for_obliteration_date - obliteration_yyyymmdd=$obliteration_yyyymmdd YYYYMMDD=$YYYYMMDD"); if ($obliteration_yyyymmdd != $YYYYMMDD) { return; } else { obliterate_oblongs(); } } ############################################################ # # Returns today's pope if it is a lent date sub todays_pope { my ($yyyymmdd) = @_; $yyyymmdd = $YYYYMMDD if ($yyyymmdd eq ""); my $day_num = lent_day_number($yyyymmdd); return "" if ($day_num < 1); my @pope_list = (); open(CULL, "${SHAREDROOT}/cull_candidates.dat"); while() { chop; next if (/^#/); next if (/^\s*$/); ($name, $active_flag) = split /;/; push @pope_list, $name if ($active_flag eq "1"); } close(CULL); my @popes = sort @pope_list; my $yyyy = substr($yyyymmdd, 0, 4); $day_num += $yyyy; # so that the first pope is different each year return $popes[ $day_num % scalar(@pope_list) ]; } ############################################################ # # Returns the day number of a lent date, i.e. # 1 = first day of lent (Ash Wednesday) # 40 = last day of lent (Holy Saturday) # 0 = not a lent day sub lent_day_number { my ($yyyymmdd) = @_; $yyyymmdd = $YYYYMMDD if ($yyyymmdd eq ""); my $day_num = 0; # Sundays are not considered part of lent. if (date_manip("-fDAYOFWEEK $yyyymmdd") eq "Sunday") { return 0; } my $is_in_lent = 0; my $lent_fname = "${REFROOT}/lent.dat"; open (LENT, "$lent_fname") or log_error("Cannot open lent file: $lent_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); ($ash_wednesday, $easter_sunday) = split /;/, $_; if (($yyyymmdd >= $ash_wednesday) && ($yyyymmdd < $easter_sunday)) { $is_in_lent = 1; last; } } close(LENT); if ($is_in_lent == 1) { $day_num = date_manip("-c $ash_wednesday $yyyymmdd") + 1; # subtract number of Sundays we've passed so far my $sundays = int(($day_num + 2) / 7); $day_num -= $sundays; } return $day_num; } ############################################################ # # called by pooclub_pope.html sub show_todays_pope { my ($yyyymmdd) = @_; $yyyymmdd = $YYYYMMDD if ($yyyymmdd eq ""); my $caption = qq( In pooclub anybody can be pope.); my $pope_pic = qq(${IMGPOODIR}/pope_bono.jpg); if (lent_day_number($yyyymmdd) > 0) { my $pope = todays_pope($yyyymmdd); $caption = "Today's pope: " . $pope; $pope_pic = "${IMGPOODIR}/who_" . lc($pope) . ".jpg"; } print qq(
Pope
$caption
); } ############################################################ # # called by pooclub_pope.html sub show_this_years_popes { my ($yyyymmdd) = @_; $yyyymmdd = $YYYYMMDD if ($yyyymmdd eq ""); # don't show the list of popes during lent return if (lent_day_number($yyyymmdd) > 0); my $yyyy = substr($yyyymmdd, 0, 4); print qq(

Popes for lent $yyyy

); my $yyyymmdd = 20110201; while ($yyyymmdd <= 20110430) { my $day_num = lent_day_number($yyyymmdd); if ($day_num > 0) { my $pope = todays_pope($yyyymmdd); my $date = date_manip("-fDOW_DD_MON_YYYY $yyyymmdd"); print qq(${day_num}: $date $pope
); } $yyyymmdd = date_calc("-d1 $yyyymmdd"); } } ############################################################ # # Not for public access. Used for testing sub show_popes { print qq(

Popes for lent 2011

); my $yyyymmdd = 20110301; while ($yyyymmdd <= 20110430) { my $day_num = lent_day_number($yyyymmdd); my $pope = todays_pope($yyyymmdd); my $date = date_manip("-fDOW_DD_MON_YYYY $yyyymmdd"); print qq($day_num $yyyymmdd $date $pope
); $yyyymmdd = date_calc("-d1 $yyyymmdd"); } } ############################################################ sub can_obliterate1 { return false if ($OVERRIDE_OBLIT eq "DISABLE"); return true if ($OVERRIDE_OBLIT eq "FORCE"); my ($yyyymmdd) = @_; $yyyymmdd = $YYYYMMDD if ($yyyymmdd eq ""); my $obliteration_yyyymmdd = next_obliteration_yyyymmdd($yyyymmdd); return true if ($obliteration_yyyymmdd == $YYYYMMDD); return false; } ############################################################ sub can_obliterate { my $can_oblit = 0; # cannot obliterate log_info("can_obliterate - OVERRIDE_OBLIT=$OVERRIDE_OBLIT"); if ($OVERRIDE_OBLIT eq "DISABLE") { $can_oblit = 0; log_info("can_obliterate - can_oblit=$can_oblit DISABLE"); return $can_oblit; } if ($OVERRIDE_OBLIT eq "FORCE") { $can_oblit = 1; log_info("can_obliterate - can_oblit=$can_oblit FORCE"); return $can_oblit; } my ($yyyymmdd) = @_; $yyyymmdd = $YYYYMMDD if ($yyyymmdd eq ""); my $obliteration_yyyymmdd = next_obliteration_yyyymmdd($yyyymmdd); log_info("can_obliterate - yyyymmdd=$yyyymmdd obliteration_yyyymmdd=$obliteration_yyyymmdd"); if ($obliteration_yyyymmdd == $YYYYMMDD) { $can_oblit = 1; log_info("can_obliterate - can_oblit=$can_oblit OBLIT"); return $can_oblit; } $can_oblit = 0; log_info("can_obliterate - can_oblit=$can_oblit DEFAULT"); return $can_oblit; } ############################################################ # # deprecate - replace with corner_champ sub current_corner_champ { my $champ_id = "Nobody"; my $champ_name = $champ_id; my $champ_oblongs = -1; # Find most recent corners file my @fnames = (reverse sort <${SHAREDROOT}/oblongs/corners_*.dat>); # glob my $latest_fname = $fnames[0]; # TODO: what if list is empty? open (CORNERS, "$latest_fname") or log_error("current_corner_champ - cannot open corner file: $latest_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($id, $oblongs) = split /;/, $_; if ($oblongs > $champ_oblongs) { $champ_id = $id; $champ_oblongs = $oblongs; } } close(CORNERS); if ($champ_oblongs > -1) # found champ's id { my @id_list = (); my %names = {}; my %dobs = {}; read_players_file(\@id_list, \%names, \%dobs); $champ_name = $names{$champ_id}; $champ_name = "Unknown" if ($champ_name eq ""); } my $champ_image = "${IMGPOODIR}/who_" . lc( ${champ_name} ) . ".jpg"; return ($champ_name, $champ_image); } ############################################################ sub corner_champ { my $oblit_yyyymmdd = $cgi->param('oblit'); my $corner_fname = bigoblong_table_filename($oblit_yyyymmdd); my $champ_id = "Nobody"; my $champ_name = $champ_id; my $champ_oblongs = -1; open (CORNERS, "$corner_fname") or log_error("corner_champ - cannot open corner file: $corner_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($id, $oblongs, $others) = split /;/, $_; if ($oblongs > $champ_oblongs) { $champ_id = $id; $champ_oblongs = $oblongs; } } close(CORNERS); if ($champ_oblongs > -1) # found champ's id { my @id_list = (); my %names = {}; my %dobs = {}; read_players_file(\@id_list, \%names, \%dobs); $champ_name = $names{$champ_id}; $champ_name = "Unknown" if ($champ_name eq ""); } my $champ_image = "${IMGPOODIR}/who_" . lc( ${champ_name} ) . ".jpg"; my $yyyymmdd = $corner_fname; $yyyymmdd =~ s/^.*bigoblong_table_//; $yyyymmdd =~ s/.dat$//; my $mm = substr($yyyymmdd, 4, 2) -1; my $yyyy = substr($yyyymmdd, 0, 4); my $date = qq($MonthList[$mm] $yyyy); return ($champ_name, $champ_image, $date, $champ_oblongs); } ############################################################ # # called by pooclub_bigoblong.html sub show_current_big_oblong { my ($name, $image) = current_corner_champ(); my $latest_year = 0; my $first_year = 9999; my %obliteration_dates = {}; my %winner_names = {}; my $bigoblong_fname = "${SHAREDROOT}/oblongs/bigoblong.dat"; open (BIG, "$bigoblong_fname") or log_error("show_big_oblongs - cannot read big oblong file: $bigoblong_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($obliteration_date, $month, $year, $winner_id, $winner_name) = split /;/, $_; $latest_year = $year if ($year > $latest_year); $first_year = $year if ($year < $first_year); $winner_names{$year . $month} = $winner_name; $obliteration_dates{$year . $month} = $obliteration_date; } close(BIG); show_big_oblong($latest_year, \%obliteration_dates, \%winner_names); return; } ############################################################ # # called by pooclub_bigoblong.html sub show_previous_big_oblongs { my ($name, $image) = current_corner_champ(); my $latest_year = 0; my $first_year = 9999; my %obliteration_dates = {}; my %winner_names = {}; my $bigoblong_fname = "${SHAREDROOT}/oblongs/bigoblong.dat"; open (BIG, "$bigoblong_fname") or log_error("show_big_oblongs - cannot read big oblong file: $bigoblong_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($obliteration_date, $month, $year, $winner_id, $winner_name) = split /;/, $_; $latest_year = $year if ($year > $latest_year); $first_year = $year if ($year < $first_year); $winner_names{$year . $month} = $winner_name; $obliteration_dates{$year . $month} = $obliteration_date; } close(BIG); my $last_year = $latest_year - 1; if ($last_year >= $first_year) { print qq(Previous Big Oblongs

); for(my $yyyy = $last_year; $yyyy >= $first_year; $yyyy--) { show_big_oblong($yyyy, \%obliteration_dates, \%winner_names); } } return; } ############################################################ sub show_big_oblong { my ($yyyy, $obliteration_dates, $winner_names) = @_; print qq(
March   June
$$winner_names{$yyyy . "March"}   $$winner_names{$yyyy . "June"}
$yyyy
September   December
$$winner_names{$yyyy . "September"}   $$winner_names{$yyyy . "December"}

); } ############################################################ sub show_oblong_menu { my ($page, $other) = @_; print qq(

); if ($page eq "oblongs") { print qq(oblongs | ); } else { print qq(oblongs | ); } if ($page eq "oblog") { print qq(the oblog | ); } else { print qq(the oblog | ); } if ($page eq "bigoblong") { print qq(the big oblong | ); } else { print qq(the big oblong | ); } if ($page eq "oblongsabout") { print qq(about oblongs ); } else { print qq(about oblongs ); } if ($other ne "only") { print qq(

Other oblongs: topic oblongs | poochoonz oblongz | ppotd oblongs ); } print qq(

); } ############################################################ sub show_next_obliteration_date { my $obliteration_yyyymmdd = next_obliteration_yyyymmdd($YYYYMMDD); my $ob_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR $obliteration_yyyymmdd"); print qq(

Next Obliteration Date: $ob_date

); } ############################################################# ## ## called by pooclub_oblongs.html # #sub show_corner_champ #{ # my ($name, $image, $date) = corner_champ(); # # print qq( # #

$date
# # # # # # #
#
Corner Champion
# #
# $name #
$name
#
# #
# #); #} # ############################################################ sub show_corner_oblongs { my $oblit_yyyymmdd = $cgi->param('oblit'); my $corner_fname = corner_filename($oblit_yyyymmdd); my %names = {}; my %dobs = {}; my %oblongs = {}; my @id_list = (); read_players_file(\@id_list, \%names, \%dobs); read_corner_file(\%names, \%oblongs, $corner_fname); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; print qq(
Corner Oblongs
); for my $id (@ids) { print qq( ); } print qq(
$names{$id} $oblongs{$id}
); } ############################################################ # to replace show_corner_oblongs #FISH sub show_big_oblong_table { my %players = {}; my %dobs = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); my %given = {}; my %received = {}; my %fined = {}; my %been_fined = {}; my %generosity_bonus = {}; my %scrooge_penalty = {}; my %other_bonus = {}; my %other_penalty = {}; my %check = {}; # my $yyyymmdd = "20110321"; my $yyyymmdd = $cgi->param('oblit'); my $fname = bigoblong_table_filename($yyyymmdd); read_players_file(\@id_list, \%players, \%dobs); # read_oblong_files(\%players, \%oblongs, \%bag, \@id_list); read_bigoblong_table_file($fname, \%oblongs, \%given, \%received, \%fined, \%been_fined, \%generosity_bonus, \%scrooge_penalty, \%other_bonus, \%other_penalty, \%bag, \%check); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; # if ($UBERACC{'PRIVILEGE'} > 2) # { # print qq(fname=$fname); # print qq(

); # } show_oblong_table_html(\@ids, \%players, \%oblongs, \%bag, \%given, \%received, \%fined, \%been_fined, \%generosity_bonus, \%scrooge_penalty, \%other_bonus, \%other_penalty); } ############################################################ # deprecate sub corner_filename { my ($yyyymmdd) = @_; my $corner_fname; if ($yyyymmdd eq "") # find most recent corner file { my @fnames = (reverse sort <${SHAREDROOT}/oblongs/corners_*.dat>); # glob $corner_fname = $fnames[0]; # TODO: what if list is empty? } else { $corner_fname = "${SHAREDROOT}/oblongs/corners_${yyyymmdd}.dat"; } return $corner_fname; } ############################################################ # deprecate sub read_corner_file { my ($players, $oblongs, $corner_fname) = @_; # Read start of week file open (CORNER, "$corner_fname") or print log_error("Cannot open corner file: $corner_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($id, $obs) = split /;/, $_; $$oblongs{$id} += $obs; } close(CORNER); } ############################################################ sub bigoblong_table_filename { my ($yyyymmdd) = @_; my $bigoblong_table_fname; if ($yyyymmdd eq "") # find most recent bigoblong table file { my @fnames = (reverse sort <${SHAREDROOT}/oblongs/bigoblong_table_*.dat>); # glob $bigoblong_table_fname = $fnames[0]; # TODO: what if list is empty? } else { $bigoblong_table_fname = "${SHAREDROOT}/oblongs/bigoblong_table_${yyyymmdd}.dat"; } return $bigoblong_table_fname; } ############################################################ sub read_bigoblong_table_file { # my ($players, $oblongs, $bigoblong_table_fname) = @_; my ($bigoblong_table_fname, $oblongs, $given, $received, $fined, $been_fined, $generosity_bonus, $scrooge_penalty, $other_bonus, $other_penalty, $bag, $check) = @_; open (BIG, "$bigoblong_table_fname") or print log_error("Cannot open bigoblong table file: $bigoblong_table_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($id, $obs, $giv, $rec, $fin, $been, $gen, $scr, $obon, $open, $bag, $chk) = split /;/, $_; $$oblongs{$id} += $obs; $$given{$id} += $giv; $$received{$id} += $rec; $$fined{$id} += $fin; $$been_fined{$id} += $been; $$generosity_bonus{$id} += $gen; $$scrooge_penalty{$id} += $scr; $$other_bonus{$id} += $obon; $$other_penalty{$id} += $open; $$bag{$id} += $bag; $$check{$id} += $chk; } close(BIG); } ############################################################ # Create bigoblong_table file from last 3 month's log files sub write_bigoblong_table_file { log_info("write_bigoblong_table_file()"); my %players = {}; my %dobs = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); # new fields my %given = {}; my %received = {}; my %fined = {}; my %been_fined = {}; my %generosity_bonus = {}; my %scrooge_penalty = {}; my %other_bonus = {}; my %other_penalty = {}; read_players_file(\@id_list, \%players, \%dobs); $week_commencing = date_manip("-d-7 $YYYYMMDD"); # get last week's oblongs # OBLITERATION PROBLEM FIX read_oblong_files(\%players, \%oblongs, \%bag, \@id_list, $week_commencing); #read_oblong_files(\%players, \%oblongs, \%bag, \@id_list, 20110613); # March - June #read_oblong_files(\%players, \%oblongs, \%bag, \@id_list, 20110912); # June - Sept #read_oblong_files(\%players, \%oblongs, \%bag, \@id_list, 20111212); # Sept - Dec my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; my $latest_oblit_yyyymmdd = latest_obliteration_date(); log_info("write_bigoblong_table_file - latest_oblit_yyyymmdd=$latest_oblit_yyyymmdd"); my @oblog_fnames = latest_oblog_files($latest_oblit_yyyymmdd); #@oblog_fnames = latest_oblog_files(20110321, 20110620); # TODO: testing March - June #@oblog_fnames = latest_oblog_files(20110620, 20110919); # TODO: testing June - Sept #@oblog_fnames = latest_oblog_files(20110920, 20111219); # TODO: testing Sept - Dec 2011 for my $oblog_fname (@oblog_fnames) { log_info("write_bigoblong_table_file - for: calling read_oblog_file(latest_obliteration_date=$latest_obliteration_date , oblog_fname=$oblog_fname"); read_oblog_file($latest_obliteration_date, $oblog_fname, \%given, \%received, \%fined, \%been_fined, \%generosity_bonus, \%scrooge_penalty, \%other_bonus, \%other_penalty); } my $fname = bigoblong_table_filename($YYYYMMDD); #$fname = bigoblong_table_filename(20110919); # TODO: June - Sept open (OBIG, ">$fname") or print log_error("Cannot write bigoblong table file: $fname"); print OBIG qq(#id;oblongs;given;received;fined;been_fined;generosity_bonus;scrooge_penalty;other_bonus;other_penalty;bag;check;\n); for my $id (@ids) { my $data_line = qq($id;$oblongs{$id};$given{$id};$received{$id};$fined{$id};$been_fined{$id};$generosity_bonus{$id};$scrooge_penalty{$id};$other_bonus{$id};$other_penalty{$id};$bag{$id};;); log_info("write_bigoblong_table_file - writing data_line=$data_line"); print OBIG qq($id;$oblongs{$id};$given{$id};$received{$id};$fined{$id};$been_fined{$id};$generosity_bonus{$id};$scrooge_penalty{$id};$other_bonus{$id};$other_penalty{$id};$bag{$id};;\n); } close(OBIG); } ############################################################ # # called by pooclub_oblog sub show_oblong_table { my %players = {}; my %dobs = {}; my %bag = {}; my %oblongs = {}; my @id_list = (); # new fields my %given = {}; my %received = {}; my %fined = {}; my %been_fined = {}; my %generosity_bonus = {}; my %scrooge_penalty = {}; my %other_bonus = {}; my %other_penalty = {}; read_players_file(\@id_list, \%players, \%dobs); read_oblong_files(\%players, \%oblongs, \%bag, \@id_list); my @ids = sort {$oblongs{$b} <=> $oblongs{$a}} @id_list; my $latest_oblit_yyyymmdd = latest_obliteration_date(); my @oblog_fnames = latest_oblog_files($latest_oblit_yyyymmdd); for my $oblog_fname (@oblog_fnames) { read_oblog_file($latest_obliteration_date, $oblog_fname, \%given, \%received, \%fined, \%been_fined, \%generosity_bonus, \%scrooge_penalty, \%other_bonus, \%other_penalty); } if ($UBERACC{'PRIVILEGE'} > 2) { print qq(Log files used:); for $foo (@oblog_fnames) { print qq(
$foo); } print qq(

); } my $from_date = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR", $latest_oblit_yyyymmdd); print qq(Oblongs since last obliteration date: $from_date

); show_oblong_table_html(\@ids, \%players, \%oblongs, \%bag, \%given, \%received, \%fined, \%been_fined, \%generosity_bonus, \%scrooge_penalty, \%other_bonus, \%other_penalty); } ############################################################ # # detailed oblong table sub show_oblong_table_html { my ($ids, $players, $oblongs, $bag, $given, $received, $fined, $been_fined, $generosity_bonus, $scrooge_penalty, $other_bonus, $other_penalty) = @_; print qq( ); print qq( ) if ($UBERACC{'PRIVILEGE'} > 2); print qq( ); for my $id (@$ids) # Display oblongs { my $obs = int($$oblongs{$id}); my $inBag = int($$bag{$id}); my $obsGiven = int($$given{$id}); my $obsReceived = int($$received{$id}); my $obsFined = int($$fined{$id}); my $obsBeenFined = int($$been_fined{$id}); my $obsGenerosityBonus = int($$generosity_bonus{$id}); my $obsScroogePenalty = int($$scrooge_penalty{$id}); my $obsOtherBonus = int($$other_bonus{$id}); my $obsOtherPenalty = int($$other_penalty{$id}); my $obsCheck = $obsReceived - $obsBeenFined + $obsGenerosityBonus - $obsScroogePenalty + $obsOtherBonus - $obsOtherPenalty; print qq( ); print qq( ) if ($UBERACC{'PRIVILEGE'} > 2); print qq( ); } print qq(
    Cabinet Given Received Fined Been Fined Generosity Bonus Scrooge Penalty Other  Bonus* Other PenaltyCheckBag
$$players{$id}   $obs  $obsGiven  $obsReceived   $obsFined   $obsBeenFined   $obsGenerosityBonus      $obsScroogePenalty    $obsOtherBonus   $obsOtherPenalty  $obsCheck $inBag 

*Birthday, k-day, oblottery, previous Corner oblongs
); } ############################################################ sub zz_latest_obliteration_date { my @obliteration_dates = (); my $bigoblong_fname = "${SHAREDROOT}/oblongs/bigoblong.dat"; open (BIG, "$bigoblong_fname") or log_error("latest_obliteration_date - cannot read big oblong file: $bigoblong_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($obliteration_date, $month, $year, $winner_id, $winner_name) = split /;/, $_; push @obliteration_dates, $obliteration_date; } close(BIG); # my @sorted_dates = sort reverse @obliteration_dates; # TODO: surely this should be correct? my @sorted_dates = sort @obliteration_dates; return $sorted_dates[0]; } ############################################################ sub latest_obliteration_date { my @obliteration_dates = (); my $bigoblong_fname = "${SHAREDROOT}/oblongs/bigoblong.dat"; my $obliteration_date; my @others; open (BIG, "$bigoblong_fname") or log_error("latest_obliteration_date - cannot read big oblong file: $bigoblong_fname"); while() { chop; next if (/^\s*$/); next if (/^#/); ($obliteration_date, @others) = split /;/, $_; push @obliteration_dates, $obliteration_date; } close(BIG); return $obliteration_date; # just return the last date in the file. } ############################################################ sub latest_oblog_files { my ($latest_oblit_yyyymmdd, $current_oblit_yyyymmdd) = @_; log_info("latest_oblog_files - latest_oblit_yyyymmdd=$latest_oblit_yyyymmdd current_oblit_yyyymmdd=$current_oblit_yyyymmdd"); # $current_oblit_yyyymmdd = $YYYYMMDD if ($current_oblit_yyyymmdd eq ""); $current_oblit_yyyymmdd = next_obliteration_yyyymmdd() if ($current_oblit_yyyymmdd eq ""); my @latest_fnames = (); my @fnames = (sort <${SHAREDROOT}/oblongs/oblongs_*.log>); # glob for my $fname (@fnames) { my $yyyymmdd = $fname; $yyyymmdd =~ s/^.*oblongs_//; $yyyymmdd =~ s/.log$//; if (($yyyymmdd >= $latest_oblit_yyyymmdd) && ($yyyymmdd < $current_oblit_yyyymmdd)) { push @latest_fnames, $fname; } } return @latest_fnames; } ############################################################ sub read_oblog_file { my ($latest_oblit_yyyymmdd, $oblog_fname, $given, $received, $fined, $been_fined, $generosity_bonus, $scrooge_penalty, $other_bonus, $other_penalty) = @_; open (OB, "$oblog_fname") or log_error("read_oblog_file - cannot open oblog file: $oblog"); while() { chop; next if (/^\s*$/); next if (/^#/); my ($yyyymmdd, $timestamp, $from, $to, $number, $reason) = split /;/, $_; if ($from ne "pooclub") # Oblongs given and fined { if ($number > 0) { $$given{$from} += $number; $$received{$to} += $number; } elsif ($number < 0) { $$fined{$from} -= $number; $$been_fined{$to} -= $number; } } else # Bonuses and penalties { if ($reason eq "Generosity bonus") { $$generosity_bonus{$to} += $number; } elsif ($reason eq "Scrooge penalty") { $$scrooge_penalty{$to} -= $number; } elsif ($number > 0) { $$other_bonus{$to} += $number; } # elsif ($number < 0) # { # $$other_penalty{$to} -= $number; # } } } close(OB); } ############################################################ sub make_lent_drivel { makedir("${SHAREDROOT}/lent"); my $lent_file = "${SHAREDROOT}/lent/lent_${YYYYMMDD}.txt"; my $poodate = date_manip("-c 20000727 $YYYYMMDD"); #Num days since 27 July 2000 log_info("make_lent_drivel() YYYYMMDD=$YYYYMMDD poodate=$poodate"); my $today = date_manip("-fDAYOFWEEK_DD_MONTH_YEAR"); my $monthDD = date_manip("-fMONTH_DD"); $monthDD =~ s/\s//g; my $pope = ""; # test if today's drivel file exists yet open (LENTF, "$lent_file"); my $test = ; close(LENTF); if ($test) { log_info("lent_file already exists: $lent_file"); return; } log_info("Making lent_file: $lent_file"); my $events_file = "${DATAROOT}/../tripe/public/data/general/events.dat"; my $events_file2 = "${DATAROOT}/../tripe/public/data/events/$monthDD"; open (LENTF, ">$lent_file"); # print LENTF "$today\n"; # print LENTF "-" x length($today), "\n"; my $dow = date_manip("-fDOW $YYYYMMDD"); # Show today's pope if we're in lent my $lent_day_number = lent_day_number(); log_info("FISH lent_day_number=$lent_day_number"); if ($lent_day_number > 0) { $pope = todays_pope(); print LENTF qq( Today's Pope ------------ ); if ($lent_day_number == 1) { print LENTF qq( It is a well known fact to those that know it well that the pope gives up his papacy during lent every year. What is less well known is that on these days pooclub provides a pope to take over while the normal pope's doing lenty stuff. Here in this papal decree we will keep you informed on each day during lent of who is the pope for the day, and so it is with great pleasure that we present to you on Ash Wednesday the first pope of lent: $pope ); } else { print LENTF qq(Today's pope is $pope Lent day number: $lent_day_number - see http://pooclub.shite.org/pope ); } close(LENTF); # send_daily_drivel($UBERENV{GROUP_EMAIL}); # to pooclub forum log_info("send lent drivel - pope=$pope"); # my ($to_email) = "mike\@stollery.co.uk"; my ($to_email) = "$UBERENV{GROUP_EMAIL}"; my $subject = "Today's Pope: $pope"; log_info("Mailing $subject to $to_email from $UBERENV{ADMIN_EMAIL}"); email_notify_file($to_email, $UBERENV{ADMIN_EMAIL}, "$subject", "$lent_file", "The Vatican"); } } 1; ############################################################ # EOF