#!/usr/bin/perl -w ################################################## # ecal.cgi # Electronic/Embeddable Calendar # Version 2.0 (1/22/04) # Richard Rathe # Copyright 2002 by Richard Rathe # ##### redirect error messages #################### BEGIN { open(LOG,">error_logs/ecal_err.log"); open(STDERR,">&LOG"); } ##### include sendmail module #################### use Mail::Sendmail; ##### global variables ########################### $vers = '2.0b2'; $dlim = '/'; $eol = "\x0D\x0A"; $numcols = 7; $allcols = '1234567'; $weekcols = '134'; $editrows = '30'; $timeout = '10'; $cfgfile = '000000.cfg'; $exptfile = 'ecal.vcs'; $holidays = 'holidays.lst'; $tokenfile = 'token.dat'; $datadir = 'ecaldata/'; $admdir = 'admin/'; $logdir = 'logfiles/'; $admname = $admdir; chop($admname); %totals = (); # hash for hour totals $header = "Content-type: text/html\n\n"; $dtdinfo = ''; $charset = ""; $comment = ""; $action = 'http://medinfo.ufl.edu/cgi-bin/ecal.cgi'; $ecalhome = 'http://medinfo.ufl.edu/cgi-about/ecal.html'; @dnames = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); @mnames = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); @months = ('*','January','February','March','April','May','June', 'July','August','September','October','November','December',); @mdays = (0,31,28,31,30,31,30,31,31,30,31,30,31); @leaps = (1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1); $ltarrow = '<<'; $rtarrow = '>>'; $uparrow = '+>'; $dnarrow = '<-'; # $ltarrow = '←'; ### future? ### # $rtarrow = '→'; # $uparrow = '↑'; # $dnarrow = '↓'; ##### style sheet info ########################### $style = '"; $hstyle = " style=\"font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; font-weight: bold; color: #000000\""; $dstyle = " style=\"font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 10px; font-weight: normal; color: #000000\""; ##### main program ############################### ## print $header; # for debugging $| = 1; # output not buffered #$refer = $ENV{'HTTP_REFERER'}; # where did link come from? $addr = $ENV{'REMOTE_ADDR'}; # remote client IP number #!exists $ENV{'HTTPS'} and $ENV{'HTTPS'} ne 'on' and # &error('01', 'anonymous', 'Non Secure Page', # "You must use https (SSL) to access these pages.

Go to ECal..."); $raw_data = ''; # stuff data in here for processing if ($ENV{'REQUEST_METHOD'} eq 'POST') { read(STDIN, $raw_data, $ENV{CONTENT_LENGTH}); } elsif ($ENV{'REQUEST_METHOD'} eq 'GET' and ($ENV{'QUERY_STRING'}) ne '') { $raw_data = $ENV{'QUERY_STRING'}; } else { &splash_screen; } ##### unpack args with = signs ##### foreach(split(/;|&/, $raw_data)) { # ; or & arg seperator if(/(.*)=(.*)/) { ($nam, $val) = ($1, $2); $val =~ s/\+/ /g; # decode spaces $val =~ s/%(..)/pack('c',hex($1))/eg; # decode esc chars $args{$nam} = $val; # fill hash # print "debug: $nam = $val
\n"; # for debugging } else { $args{'dir'} = $_; # default arg } } $args{'dir'} =~ /$dlim/ and # block hackers &error('02', 'anonymous', 'Illegal Character', "Cannot use the \'\/\' character here."); exists $args{'day'} and $day = $args{'day'}; exists $args{'mon'} and $day = $args{'mon'}; if ($day) { $day =~ /(\d\d)(\d\d)(\d\d)/i; $yy = $1; $mdays[2] += $leaps[$yy]; # add extra day for leap years } ##### decide what to do ##### !exists $args{'ssi'} and $hstyle = $dstyle = ''; !exists $args{'day'} and $args{'day'} = &log_date_stamp; exists $args{'help'} and &help_screen($args{'help'}); exists $args{'expt'} and &export_vcal($args{'dir'}, $args{'day'}, $args{'expt'}); exists $args{'email'} and &get_message($args{'dir'}, $args{'day'}, $args{'email'}); exists $args{'addr'} and &send_message($args{'dir'}, $args{'addr'}, $args{'maddr'}, $args{'mname'}, $args{'dd'}, $args{'mm'}, $args{'yy'}, $args{'mtext'}); exists $args{'dir'} and exists $args{'edit'} and $args{'edit'} eq 'done' and &change_day($args{'dir'}, $args{'day'}); exists $args{'dir'} and exists $args{'edit'} and $args{'edit'} eq 'cfgdone' and &change_cfg($args{'dir'}, $args{'day'}); exists $args{'dir'} and exists $args{'edit'} and $args{'edit'} eq 'new' and &edit_day($args{'dir'}, 'new'); exists $args{'dir'} and exists $args{'edit'} and $args{'edit'} eq 'cfg' and &edit_cfg($args{'dir'}, $args{'mon'}); exists $args{'dir'} and exists $args{'edit'} and $args{'edit'} eq 'mon' and &output_month($args{'dir'}, $args{'mon'}, 'mon'); exists $args{'dir'} and exists $args{'edit'} and $args{'day'} > 0 and &edit_day($args{'dir'}, $args{'day'}); exists $args{'dir'} and $args{'day'} == 0 and &list_days($args{'dir'}); exists $args{'dir'} and exists $args{'mon'} and &output_month($args{'dir'}, $args{'mon'}, ''); exists $args{'dir'} and &output_days($args{'dir'}, $args{'day'}); &error('03', 'anonymous', 'Empty Page', 'Fell thru loop!'); ##### subroutines ############################ sub send_mail { my ($tolist, $from, $subj, $message) = @_; $tolist eq '' and return; # exit if no 'to' list my %mail = ( To => $tolist, From => $from, Subject => $subj, Message => $message ); sendmail(%mail) or &error('10', 'anonymous', 'Send Mail Failure', "The sendmail module failed to send your message. $tolist $from"); } sub send_message { my ($dir, $addr, $maddr, $mname, $dd, $mm, $yy, $text) = @_; $maddr !~ /^\S+\@\S+\.\S+$/ and error('11', $maddr, 'Invalid Return Address', "You must enter a valid return address."); $mname !~ /^\S+\s+\S+$/ and error('12', $maddr, 'Invalid Name', "You must enter your full name."); !$text and error('13', $maddr, 'No Message Text', "You must enter a short message."); my $message = "Request concerning $mm/$dd/$yy on '$dir' Calendar\n\n"; $message .= "From $mname <$maddr>\n\n$text\n\n"; $message .= "$action?dir=$dir;day=$yy$mm$dd;edit=day\n\n"; &send_mail($addr, $maddr, "ECal Request from $mname", $message); print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Message Sent to $addr\n"; print "$charset\n$style\n\n\n\n"; print "

Ecal v$vers Request

\n"; print "

Message sent to $addr.

\n"; print "

Message sent from $mname <$maddr>.

\n"; print "

Request for $mm/$dd/$yy.

\n"; print "

Message: $text

\n"; print "

\n"; print "\n\n"; exit; } sub get_message { my ($dir, $day, $email) = @_; $day =~ /(\d\d)(\d\d)(\d\d)/i; my ($yy, $mm, $dd) = ($1, $2, $3); my $sel = ''; print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Message to $email\n"; print "$charset\n$style\n\n\n\n"; print "
\n"; print "\n\n"; print "\n\n"; print "\n"; print "\n\n"; print "\n\n"; print "\n\n"; print "\n"; print "
ECal v$vers - Message to $email
\nMessage
\n"; print "\n		Concerning
\n"; print "\n"; print "\n"; print "\n"; print "
Your Name
Your Email Address
\n"; print "\n"; print "\n"; print "    \n"; print "\n
\n
\n\n\n"; exit; } sub get_pass { my ($dir, $day, $edit) = @_; my $mon = ''; $edit eq 'mon' and $mon = $day and $day = ''; print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Password Required!\n"; print "$charset\n$style\n\n\n\n"; print "

ECal v$vers - Password Required!

\n"; print "
\n"; print "

Please enter a password to edit this calendar.

\n"; print "

\n"; print "

\n"; print "\n"; $edit and print "\n"; $day and print "\n"; $mon and print "\n"; print "
\n\n\n"; exit; } sub check_pass { my ($dir, $day, $what) = @_; my ($pass, $token) = ('',''); exists $args{'tok'} and $token = $args{'tok'}; &check_token($dir, $token) and return $token; # return current token if valid !exists $args{'pass'} and get_pass($dir, $day, $what); my $file = "$datadir$dir$dlim$cfgfile"; if (open(FILE, "<$file")) { while () { /^pass\s+(\S+)/i and $pass = $1; } close(FILE); } if ($pass eq $args{'pass'}) { # return new token if passcode matches $token = &make_token($dir, $pass); return $token; } &error('31', $pass, 'Bad Passcode', "Click on the 'back' button in your browser and try again."); } sub check_view { my ($dir, $day, $num, $col, $inc) = @_; my ($pass, $input, $token) = ('','',''); exists $args{'tok'} and $token = $args{'tok'}; &check_token($dir, $token) and return $token; # return current token if valid my $file = "$datadir$dir$dlim$cfgfile"; if (open(FILE, "<$file")) { while () { /^view\s+(\S+)/i and $pass = $1; } close(FILE); } exists $args{'pass'} and $input = $args{'pass'}; if ($pass eq $input) { # return new token if passcode matches $token = &make_token($dir, $pass); return $token; } print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Password Required!\n"; print "$charset\n$style\n\n\n\n"; print "

ECal v$vers - Password Required!

\n"; print "
\n"; print "

Please enter a password to view this calendar.

\n"; print "

\n"; print "

\n"; print "\n"; $day and print "\n"; $num and print "\n"; $col and print "\n"; $inc and print "\n"; print "
\n\n\n"; exit; } sub make_token { my ($dir, $pass) = @_; my ($item, $tcnt) = ('',0); my @toklist = (); my $now = &log_time_stamp; my $token = "$now.$addr"; my $tokdata = "$now\t$addr\t$dir"; my $tfile = "$datadir$admdir$tokenfile"; open(TOKFILE, "<$tfile") or &error('28', $pass, 'Bad Token File', "Cannot open token file."); @toklist = ; close(TOKFILE); open(TOKFILE, ">$tfile") or &error('29', $pass, 'Bad Token File', "Cannot open token file."); print TOKFILE "$tokdata\n"; foreach $item (@toklist) { print TOKFILE "$item"; $tcnt++; ($tcnt > 100) and last; # limit output to newest 100 items } close(TOKFILE); return $token; } sub check_token { my ($dir, $token) = @_; my ($list, $line) = ('',''); my ($time, $ip, $where) = ('','',''); !$token and return; # return if empty token my $now = &log_time_stamp; my $tfile = "$datadir$admdir$tokenfile"; open(TOKFILE, "<$tfile") or &error('30', $token, 'Bad Token File', "Cannot open token file."); while () { /^($token.*)/ and $line = $1 and last; } close(TOKFILE); # &error('0', $token, 'DEBUG', "-$token-$line-"); if ($line) { $line =~ /^(\d+)\t(\d+\.\d+\.\d+\.\d+)\t(.+)/; $time = $1; $ip = $2; $where = $3; # &error('0', $token, 'DEBUG', "-$now=$time-$where-$ip-"); $dir ne $where and return; # check directory ($now < ($time + $timeout)) and return 'ok'; # check timeout } return; } sub edit_day { my ($dir, $day) = @_; my ($line, $cnt, $title) = ('','',''); my @items = (); my @template = (); my $tok = &check_pass($dir, $day, 'day'); # check passcode my $types = "\n"; print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Edit $title ($dir)\n"; print "$charset\n$style\n\n\n\n"; print "

ECal v$vers - Edit $title ($dir)

\n"; print "
\n"; print "\n\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; $file = "$datadir$dir$dlim$day.day"; ! -e $file and $day = 'new'; # nonexistent file = new $day ne 'new' and open(FILE, "<$file"); for (my $i=1; $i <= $editrows; $i++) { @items = ('','','','','','',''); # blank cells by default if ($day ne 'new') { # if new file if (defined ($line = )) { # get items from file @items = split(/\t+/, $line); } } elsif (defined $template[$i]) { # else get default items @items = split(/\t+/, $template[$i]); } $types =~ s/type\d+/type$i/i; $types =~ s/ selected//i; if ($items[3]) { $types =~ s/>$items[3]/ selected>$items[3]/i; } else { $types =~ s/>--/ selected>--/i; } print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; } $day ne 'new' and close FILE; print "
\n"; print "    \n"; print "Del:    \n"; print "Day:    \n"; print "Pass:    \n"; print "\n
DelSortStartStopRoomTypeNameNotesDetail
\n$types
\n"; print "\n"; print "\n"; $tok and print "\n"; print "
\n\n\n"; exit; } sub change_day { my ($dir, $day) = @_; my ($arg, $ord, $line, $tmp) = ('','','',''); my ($dd, $mm, $yy) = ('','',''); my %output = (); my $tok = &check_pass($dir); # check passcode before proceeding $tok and $tok = ";tok=$tok"; print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Edit Calendar\n"; print "$charset\n$style\n\n\n\n"; print "

ECal v$vers - Updating Calendar...

"; for (my $i = 1; $i <= $editrows; $i++) { $arg = "del$i"; # skip if delete checked $ord = $args{$arg}; $ord and next; $arg = "order$i"; # sort order for hash $ord = $args{$arg}; $arg = "start$i"; # start $tmp = &to24hour($args{$arg}); !$tmp and $tmp = '--'; $line = "$tmp\t"; $arg = "stop$i"; # stop $tmp = &to24hour($args{$arg}); !$tmp and $tmp = '--'; $line .= "$tmp\t"; $arg = "room$i"; # room $tmp = $args{$arg}; !$tmp and $tmp = '--'; $line .= "$tmp\t"; $arg = "type$i"; # type $tmp = $args{$arg}; !$tmp and $tmp = '--'; $line .= "$tmp\t"; $arg = "name$i"; # name $tmp = $args{$arg}; !$tmp and $tmp = '--'; $line .= "$tmp\t"; $arg = "notes$i"; # notes $tmp = $args{$arg}; !$tmp and $tmp = '--'; $line .= "$tmp\t"; $arg = "detail$i"; # detail $tmp = $args{$arg}; !$tmp and $tmp = '--'; $line .= "$tmp"; $line =~ /--\t--\t--\t--\t--\t--/ and next; # skip blank entries $line =~ s/\x0A|\x0D//ig; # kill stray cr/lf chars if (exists $output{$ord}) { # reject non-unique sort value print "

ERROR!! Sort value $ord is not unique.

\n"; print "

Each entry must have a unique number.

\n"; print "

Hint: Use fractional values (ie, 4.5) to insert between existing entries.

\n"; print "\n\n"; exit; } $output{$ord} = $line; # put line into hash for sorting } if ($day =~ /^(\d?\d)\/(\d?\d)\/(\d?\d)/) { # transform mm/dd/yy dates $mm = $1; $dd = $2; $yy = $3; $yy =~ s/^(.)$/0$1/i; $mm =~ s/^(.)$/0$1/i; $dd =~ s/^(.)$/0$1/i; $day = "$yy$mm$dd"; } if ($day !~ /^\d\d\d\d\d\d\w?$/) { # reject bad file name print "

ERROR!! Bad file name '$day'.

\n"; print "

Must be a number of the form 'mm/dd/yy' or 'yymmdd'.

\n"; print "\n\n"; exit; } my $file = "$datadir$dir$dlim$day.day"; my $bkup = "$datadir$dir$dlim$day" . 'z.day'; -e $file and (rename($file,$bkup) or die "Rename failed $file"); # create backup (z) file if (exists $args{'delcal'} and $args{'delcal'} eq 'on') { unlink ($file); print "

Deleted file '$day' in directory '$dir'.

\n"; } else { open(FILE, ">$file") or die "Bad File $file"; # open file for writing foreach $line (sort {$a <=> $b} keys %output) { # numeric sort print "$line $output{$line}
\n"; print FILE "$output{$line}\n"; # output line } close FILE; print "

Successfully wrote file '$day.day' in directory '$dir'.

\n"; print "

View Calendar Day for $day

\n"; } print "

Return to Editing

\n"; print "\n\n"; exit; } sub edit_cfg { my ($dir, $day) = @_; my ($line, $cnt) = ('',''); my @items = (); my @template = (); my $size = $editrows * 3; # triple number of edit rows my $file = "$datadir$dir$dlim$cfgfile"; my $tok = &check_pass($dir, '', 'cfg'); # check passcode before proceeding print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Edit Configuration for '$dir'\n"; print "$charset\n$style\n\n\n\n"; print "

ECal v$vers - Edit Configuration for '$dir'

\n"; print "
\n"; print "\n\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; if (-e $file) { # if file exists open(FILE, "<$file"); # open file } else { # else open(FILE, ">$file"); # create file print FILE "title\tNew Calendar\n\n"; # set default title print FILE "pass\tecal\n"; # set default password close FILE; # close file open(FILE, "<$file"); # repoen file } for (my $i=1; $i <= $size; $i++) { @items = ('','','','','','','','','',''); # blank cells by default if (defined ($line = )) { # get items from file chomp $line; @items = split(/\t+/, $line); } if ($items[0] eq 'new') { $items[3] and $items[2] = $items[2] . ';' . $items[3]; $items[4] and $items[2] = $items[2] . ';' . $items[4]; $items[5] and $items[2] = $items[2] . ';' . $items[5]; $items[6] and $items[2] = $items[2] . ';' . $items[6]; $items[7] and $items[2] = $items[2] . ';' . $items[7]; $items[8] and $items[2] = $items[2] . ';' . $items[8]; $items[9] and $items[2] = $items[2] . ';' . $items[9]; } my $bg = 'td'; my $tt = ''; my $ss = 40; # default (non color) $items[0] eq 'color' and $bg = "td bgcolor=\"$items[2]\"" and $tt = ' Sample' and $ss = 32; print "\n"; print "\n"; print "\n"; print "\n"; print "<$bg>$tt\n"; print "\n"; } close FILE; print "
\n"; print "    \n"; print "Pass:    \n"; print "\n
DelSortTypeValue 1Value 2
\n"; print "\n"; print "\n"; print "\n"; $tok and print "\n"; print "
\n\n\n"; exit; } sub change_cfg { my ($dir, $day) = @_; my ($arg, $ord, $line, $tmp) = ('','','',''); my ($dd, $mm, $yy) = ('','',''); my %output = (); my $size = $editrows * 3; # triple number of edit rows my $tok = &check_pass($dir); # check passcode before proceeding $tok and $tok = ";tok=$tok"; print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Updating Configuration for '$dir'\n"; print "$charset\n$style\n\n\n\n"; print "

ECal v$vers - Updating Configuration...

"; for (my $i = 1; $i <= $size; $i++) { $line = ''; # reset line $arg = "del$i"; # skip if delete checked $ord = $args{$arg}; $ord and next; $arg = "order$i"; # sort order for hash $ord = $args{$arg}; $arg = "type$i"; # type $tmp = $args{$arg}; $line .= "$tmp"; $arg = "vala$i"; # val1 $tmp = $args{$arg}; $line .= "\t$tmp"; $arg = "valb$i"; # val2 $tmp = $args{$arg}; $tmp and $line .= "\t$tmp"; # print "DEBUG: $i $line
\n"; $line =~ /^\t/ and next; # skip blank entries $line =~ s/\x0A|\x0D//ig; # kill stray cr/lf chars if (exists $output{$ord}) { # reject non-unique sort value print "

ERROR!! Sort value $ord is not unique.

\n"; print "

Each entry must have a unique number.

\n"; print "

Hint: Use fractional values (ie, 4.5) to insert between existing entries.

\n"; print "\n\n"; exit; } $output{$ord} = $line; # put line into hash for sorting } my $file = "$datadir$dir$dlim$cfgfile"; my $bkup = "$datadir$dir$dlim$cfgfile" . '.bak'; -e $file and (rename($file,$bkup) or die "Rename failed $file"); # create backup file open(FILE, ">$file") or die "Bad File $file"; # open file for writing foreach $line (sort {$a <=> $b} keys %output) { # numeric sort $output{$line} =~ /^new/i and $output{$line} =~ s/;/\t/g; print "$line $output{$line}
\n"; print FILE "$output{$line}\n"; # output line } close FILE; print "

Successfully wrote file '$cfgfile' in directory '$dir'.

\n"; print "

Return to Editing

\n"; print "\n\n"; exit; } sub fill_time { my ($start, $stop, $num) = @_; my $hrs = &get_fill_time($start, $stop); # get duration in hours my $pad = ''; # no padding for one hour or less while ($hrs > 1) { $num >= 7 and $pad .= "
."; # add one extra line per hour $num < 7 and $pad .= ".
"; $hrs--; } return $pad; } sub make_day { my ($dir, $day, $num) = @_; my ($type, $url, $date, $tmp, $fill) = ('','','','',''); my ($data, $color, $hol, $dow) = ('','','',''); my @items = (); my $file = "$datadir$admdir$holidays"; if (open(FILE, "<$file")) { # check for holiday while () { /([^\t]*)\t+([^\t]*)/; $1 == $day and $hol = $2 and last; } close(FILE); } $day =~ /(\d\d)(\d\d)(\d\d)/; $dow = &day_of_week($day,0); $date = "$dow+$mnames[$2-1]+$3+20$1"; $file = "$datadir$dir$dlim$day.day"; my $mday = &get_mod_date($file); if (open(FILE, "<$file")) { $hol and $data .= "$hol\n"; while () { $color = '#FFFFFF'; # default color is white chomp; # get rid of newline s/--/ /g; # filler for blank cells if (/([^\t]*)\t+([^\t]*)\t+([^\t]*)\t+([^\t]*)\t*([^\t]*)\t*([^\t]*)\t*([^\t]*)/i) { if ($1 eq ' ' and $2 eq ' ' and $3 eq ' ' and $4 eq ' ') { $tmp = $5; # untimed event detail $tmp =~ s/;/
/g; # semicolon becomes break $data .= "$tmp\n"; } else { @items = ($1,$2,$3,$4,$5,$6,$7); &total_hours($items[0], $items[1], $items[3]); # add to totals $items[4] =~ s/;/
/g; # semicolon becomes break $items[5] =~ s/;/
/g; # semicolon becomes break $type = lc($items[3]); # change color based on type chomp($type); $items[3] ne ' ' and $items[3] = uc($items[3]); # type always upper case $items[4] =~ s/{([^|]+)\|([^|]+)}/$1<\/a>/gi; # hypertext links $items[5] =~ s/{([^|]+)\|([^|]+)}/$1<\/a>/gi; $items[6] ne ' ' and $tmp = "$items[3] $items[4]" and $tmp =~ s/ /+/g and $items[6] = "*\n"; exists $colors{$type} and $color = $colors{$type}; # add color exists $urls{$type} and $items[3] = "$items[3]\n"; $fill = &fill_time($items[0], $items[1], $num); # calculate extra vertocal space $items[0] = &to12hour($items[0]); # convert to 12 hour clock $items[1] = &to12hour($items[1]); $num >= 7 and $items[0] ne ' ' and $items[0] = $items[0] . $fill . '
' . $items[1]; # add extra vertical space $num < 7 and $items[1] ne ' ' and $items[1] = $fill . $items[1]; for (my $i=0; $i < @items; $i++) { !$items[$i] and $items[$i] = ' '; } $num >= 7 and $items[0] eq ' ' and $items[0] = $items[3] and $items[3] = $items[4]; exists $args{'inc'} and !($args{'inc'} =~ /$type\+/) and next; $data .= "\n"; for ($i=1;$i<$numcols+1;$i++) { $args{'col'} =~ /$i/ and $data .= "$items[$i-1]\n"; } } } } close(FILE); my $update = "Updated $mday

"; # !exists $args{'ssi'} and # $update = "Updated $mday"; $data .= "\n$update\n\n"; } else { # blank day / no data if ($hol) { $data .= "$hol\n"; } else { $data .= " \n"; } $data .= "\nO p e n

\n"; } return $data; } sub output_days { my ($dir, $day) = @_; my ($back, $forw, $cnt, $dow, $sub, $ll, $mm, $info) = ('','',0,'','','','',''); my ($title, $date, $data, $size, $help, $out, $expt, $tok) = ('','','','','','','',''); my ($prev, $next, $inc, $tday, $noin, $sday, $week, $view) = ('','','','','','','',''); my ($less, $more, $curr, $contact, $tcolor, $day7, $indx) = ('','','','','','',''); my ($tbeg, $tend, $fmt, $state, $filters, $edit) = ('','','','','',''); %colors = (); %urls = (); my $now = &log_date_stamp; !exists $args{'num'} and $args{'num'} = 7; !exists $args{'fmt'} and $args{'fmt'} = 7; !exists $args{'col'} and $args{'col'} = $allcols; exists $args{'ssi'} and $out = " target=\"_blank\""; if (exists $args{'inc'}) { $args{'inc'} =~ s/ /\+/g; # convert spaces to '+'s $inc = ";inc=$args{'inc'}"; # pass on filter } $args{'fmt'} == 1 or $args{'fmt'} == 2 or $args{'fmt'} = 7; $fmt = ";fmt=$args{'fmt'}"; $args{'num'} >= 7 and $day = prev_monday($day); my $file = "$datadir$dir$dlim$cfgfile"; if (open(FILE, "<$file")) { while () { chomp; /^title\s+(.+)/i and $title = $1; /^contact\t+(.+)\t+(\S+)/i and $contact = "$1"; /^color\s+(\S+)\s+(\S+)/i and $colors{$1} = $2; /^url\s+(\S+)\s+(\S+)/i and $urls{$1} = $2; /^day7\s+(\S+)/i and $day7 = $1; /^view\s+(\S+)/i and $view = $1; /^info\s+(.+)/i and $info = $1; } close(FILE); } else { $title = $dir; } $info =~ s/{([^|]+)\|([^|]+)}/$1<\/a>/gi; # hypertext links $view and # if view passcode $tok = &check_view($dir, $day, $args{'num'}, $args{'col'}, $args{'inc'}); # check before proceeding $tok and $tok = ";tok=$tok"; $sday = $day; $day =~ /(\d\d)(\d\d)(\d\d)(\w?)/i; $sub = $4; $sub and $sub = " (Detail)" and chop $day; $dow = &day_of_week($day,0); $date = "$dow, $mnames[$2-1] $3, 20$1$sub"; my $menu = &month_menu($dir, $1, $2, $args{'inc'}, 'week', $tok); print $header; !exists $args{'ssi'} and print "$comment\n$dtdinfo\n\n"; !exists $args{'ssi'} and print "\n\n$date - $title\n"; !exists $args{'ssi'} and print "$charset\n$style\n\n\n\n"; if ($args{'num'} <= 1) { # 1 is min $args{'num'} = $curr = 1; $less = "$dnarrow\n"; $more = "$uparrow\n"; $size = '100%'; } elsif ($args{'num'} >= 70) { # 70 is max $args{'num'} = $curr = 70; $less = "$dnarrow\n"; $more = "$uparrow\n"; $size = '100%'; } elsif ($args{'num'} < 7) { # 2 through 6 $curr = $args{'num'}; $ll = $curr - 1; $mm = $curr + 1; $less = "$dnarrow\n"; $more = "$uparrow\n"; if ($args{'num'} % 2) { $size = '100%'; } else { $size = '50%'; } } else { $curr = $args{'num'}; # 7, 14, 21, 28, days, etc. $curr = int $curr / 7; $curr = $curr * 7; $args{'fmt'} == 7 and $args{'col'} = $weekcols; $ll = $curr - 7; $mm = $curr + 7; $ll == 0 and $ll = 6; $less = "$dnarrow\n"; $more = "$uparrow\n"; $args{'fmt'} == 7 and $ll < 7 and $less = "$dnarrow\n"; $size = '15%'; } if ($args{'fmt'} != 7) { my $num = 7; $args{'num'} > 7 and $num = $args{'num'}; $week = "Show Week\n"; } else { $week = "Show Month\n"; } ($prev, $next) = &get_prev_next($day); $args{'num'} >= 7 and $next = next_monday($day); $help = "Help\n"; $indx = "Index\n"; $tday = "Today\n"; $back = "$ltarrow\n"; $forw = "$rtarrow\n"; ($inc or ($args{'col'} !~ /\d\d\d\d\d\d\d/ and $args{'fmt'} < 7)) and $noin = "Show Hidden\n"; $sub and $back = $tday = $forw = $inc = $less = $curr = $more = ''; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print "\n\n\n\n\n\n"; !exists $args{'ssi'} and print "\n
\n"; !exists $args{'ssi'} and print "\n\n"; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print ""; !exists $args{'ssi'} and print ""; !exists $args{'ssi'} and print ""; !exists $args{'ssi'} and print "
\n$less$curr Days\n$more\n$title - $date\n\n$back$tday$forw
\n$noin\n$menu\n$week
\n"; while ($cnt < $args{'num'}) { $dow = &day_of_week($sday,0); $sday =~ /(\d\d)(\d\d)(\d\d)(\w?)/i; if ($4 and exists $args{'back'}) { $args{'back'} =~ /(\w+) (\w+) (\w+) (\w+) (.*)/; $date = "$1, $2 $3, $4
$5"; # } elsif ($curr < 7) { # $date = "$dow, $mnames[$2-1] $3, 20$1"; } else { $date = "$dow, $mnames[$2-1] $3"; } if ($sday == $now) { $tcolor = '#FFFF99'; $tbeg = '<'; $tend = '>'; } else { $tcolor = '#FFFFFF'; $tbeg = ''; $tend = ''; } if ($cnt == 0) { # start !exists $args{'ssi'} and print "
\n"; } elsif ($args{'fmt'} == 1) { # new row, 1up !exists $args{'ssi'} and print "
\n"; } elsif ($args{'fmt'} == 2 and $cnt % 7 == 6) { # sunday, 2up $state = 'sun'; !exists $args{'ssi'} and print "
\n"; } elsif ($args{'fmt'} == 2 and $state eq 'sun') { # new monday, 2up $state = 'mon'; !exists $args{'ssi'} and print "
\n"; } elsif ($args{'fmt'} == 2 and $state eq 'eol') { # new row, 2up $state = ''; !exists $args{'ssi'} and print "
\n"; } elsif ($args{'fmt'} == 7 and $cnt % 7 == 6) { # sunday, 7up if ($day7) { !exists $args{'ssi'} and print "\n"; } else { !exists $args{'ssi'} and print "
\n"; } } elsif ($args{'fmt'} == 7 and !($cnt % 7)) { # new row, 7up !exists $args{'ssi'} and print "
\n"; } else { # next day $state = 'eol'; !exists $args{'ssi'} and print "\n"; } $data = &make_day($dir, $sday, $curr); print "\n"; print ""; print "$data
\n$tbeg$date$tend\n
\n"; ($prev, $sday) = &get_prev_next($sday); # advance by one day $cnt++; } ($prev, $next) = &get_prev_next($sday); # backup one day $expt = "Export\n"; $edit = "Edit\n"; $filters = &filter_menu($dir, $day, $args{'inc'}, 'day', $args{'num'}, $args{'fmt'}); !exists $args{'ssi'} and print "
\n"; !exists $args{'ssi'} and print "\n\n"; !exists $args{'ssi'} and $info and print "\n\n"; !exists $args{'ssi'} and print "\n\n"; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print "\n"; !exists $args{'ssi'} and print "\n
$info
$filters
$contact$indx | $help | $expt | $editECal v$vers
\n
\n"; !exists $args{'ssi'} and exists $args{'back'} and print "
\n

\n\n

\n
\n"; !exists $args{'ssi'} and print "\n\n"; &log_entry($dir, $day, "day"); exit; } sub list_days { my ($dir) = @_; my ($title, $dow, $date) = ('','',''); my ($detail, $backup, $inc, $fmt) = ('','','',''); my @files = (); my @colors = ('#CCCCFF','#FFFFFF','#CCCCFF','#FFFFFF','#CCCCFF','#FFFFFF','#CCCCFF'); $args{'edit'} and @colors = ('#FFCCCC','#FFFFFF','#FFCCCC','#FFFFFF','#FFCCCC','#FFFFFF','#FFCCCC'); !exists $args{'num'} and $args{'num'} = 7; !exists $args{'fmt'} and $args{'fmt'} = 7; !exists $args{'col'} and $args{'col'} = $allcols; exists $args{'inc'} and $args{'inc'} =~ s/ /\+/g and $inc = ";inc=$args{'inc'}"; $args{'fmt'} == 1 or $args{'fmt'} == 2 or $args{'fmt'} = 7; $fmt = ";fmt=$args{'fmt'}"; my $file = "$datadir$dir$dlim$cfgfile"; if (open(FILE, "<$file")) { $title = ; chop($title); $title =~ s/title\s+//i; close(FILE); } else { $title = $dir; } my $prefix = "ECal v$vers - Index of"; $args{'edit'} and $prefix = "ECal v$vers - Edit"; print "$header$comment\n$dtdinfo\n\n"; print "\n\n$prefix $title\n"; print "$charset\n$style\n\n\n\n"; print "\n"; print "\n\n"; $args{'edit'} and print "\n"; print "\n\n\n\n\n\n"; print "\n\n\n"; $args{'edit'} and print "\n\n\n"; !$args{'edit'} and print "\n\n\n"; my $directory = "$datadir$dir$dlim"; if (opendir(DIR,"$directory")) { @files = grep(/\.day/, readdir(DIR)); closedir(DIR); } else { print "No such directory $directory."; } my $cnt = 0; # start week with sunday foreach $item (sort @files) { $item eq $cfgfile and next; # skip admin file $item =~ s/.day//i; # strip extension $dow = &day_of_week($item,1); # get numeric day of week $item =~ /(\d\d)(\d\d)(\d\d)(\w*)/i; # extract yymmdds $date = "$mnames[$2-1]-$3-$1$4"; # expand name if ($4 =~ /z/i) { # collect detail calendars if ($args{'edit'}) { $backup .= "$date\n"; } else { $backup .= "$date\n"; } next; } elsif ($4 ne '') { if ($args{'edit'}) { $detail .= "$date\n"; } else { $detail .= "$date\n"; } next; } if ($cnt > $dow) { # if new week while ($cnt < 7) { # fill in missing days print "\n"; $cnt++; } if ($detail) { # detail column print "\n"; } else { print "\n"; } if ($backup and $args{'edit'}) { # backup column print "\n"; } else { print "\n"; } $cnt = 0; # reset to sunday $detail = ''; $backup = ''; # clear detail and backup } while ($cnt < $dow) { # fill in missing days print "\n"; $cnt++; } if ($args{'edit'}) { # date columns print "\n"; } else { print "\n"; } $cnt++; } while ($cnt < 7) { # fill in missing days print "\n"; $cnt++; } if ($detail) { # detail column print "\n"; } else { print "\n"; } if ($backup and $args{'edit'}) { # backup column print "\n"; } else { print "\n"; } print "\n
$prefix $title
Exit Edit Mode\n"; $args{'edit'} and print "      New Day\n"; $args{'edit'} and print "      Edit Config\n"; !$args{'edit'} and print "
Edit Mode\n"; !$args{'edit'} and print "      Browse Other Calendars\n
SunMonTueWedThuFriSatDetailsBackups
 
 $detail $backup
 
 $date\n$date\n $detail $backup
 
\n\n\n"; exit; } sub output_month { my ($dir, $day, $edit) = @_; my $tok = ''; my %colors = (); my %urls = (); $edit and $tok = &check_pass($dir, $day, 'mon'); # check passcode for edit mode my $now = &log_date_stamp; $day =~ /(\d\d)(\d\d)(\d\d)/; my $yy = $1; my $mm = $2; # get year and month my $dow = &day_of_week($yy.$mm.'01', 1); # get numeric day of week for first day my $inc = ''; # no filter by default if (exists $args{'inc'}) { $args{'inc'} =~ s/ /\+/g; # convert spaces to '+'s $inc = ";inc=$args{'inc'}"; # pass on filter } my $title = $dir; my $contact = '???'; my $file = "$datadir$dir$dlim$cfgfile"; if (open(FILE, "<$file")) { while () { chomp; /^title\s+(.+)/i and $title = $1; /^contact\t+(.+)\t+(\S+)/i and $contact = "$1"; /^color\s+(\S+)\s+(\S+)/i and $colors{uc($1)} = $2; /^url\s+(\S+)\s+(\S+)/i and $urls{uc($1)} = $2; # /^day7\s+(\S+)/i and $day7 = $1; /^view\s+(\S+)/i and $view = $1; # /^info\s+(.+)/i and $info = $1; } close(FILE); } $view and # if view flag set $tok = &check_view($dir, $day, $args{'num'}, $args{'col'}, $args{'inc'}); # check before proceeding $tok and $tok = ";tok=$tok"; my $menu = &month_menu($dir, $yy, $mm, $args{'inc'}, $edit, $tok); my $headc = " class=\"alt\""; # default header color $edit and $headc = " class=\"edit\""; # edit mode color $edit and # edit flags $edit = ';edit=day' and $editm = ';edit=mon'; $now =~ /(\d\d)(\d\d)(\d\d)/; my $tyy = $1; my $tmm = $2; my $dd = '01'; my $pyy = $yy; my $nyy = $yy; my $pmm = $mm - 1; my $nmm = $mm + 1; $pmm < 1 and $pyy > 1 and $pmm = 12 and $pyy--; $nmm > 12 and $nmm = 1 and $nyy++; $pmm =~ s/^(.)$/0$1/; $nmm =~ s/^(.)$/0$1/; $pyy =~ s/^(.)$/0$1/; $nyy =~ s/^(.)$/0$1/; my $prev = "$ltarrow\n"; my $tday = "Today\n"; my $next = "$rtarrow\n"; my $showall = ' '; $inc and my $showall = "Show Hidden\n"; print "$header$comment\n$dtdinfo\n\n"; print "\n\n$months[$mm] 20$yy - $title\n"; print "$charset\n$style\n\n\n\n"; print "\n"; print "\n\n\n"; print " \n"; print " \n"; print " \n"; print " \n"; print " \n"; print " \n"; print " \n"; print "\n\n"; my $date = 1 - $dow; for (my $i=0; $i < 6; $i++) { for (my $j=0; $j < 7; $j++, $date++) { if ($date < 1 or $date > $mdays[$mm]) { print " \n"; } else { $date =~ s/(^.$)/0$1/; my @data = &get_slots($dir, "$yy$mm$date"); if ($now == "$yy$mm$date") { $tcolor = 'today'; $tbeg = '('; $tend = ')'; } else { $tcolor = 'date'; $tbeg = ''; $tend = ''; } my $datelink = "$tbeg$date$tend\n"; my $weeklink = "Week\n"; !@data and $datelink = "$tbeg$date$tend\n"; # no data = no link print " \n"; } } print "\n\n"; $date > $mdays[$mm] and last; } my $filters = &filter_menu($dir, $day, $args{'inc'}, 'mon'); print "\n\n
\n"; print "\n\n"; print "\n"; print "\n"; print "\n"; print "\n
\n$showall\n\n$title - $months[$mm] 20$yy\n
\n$menu\n		\n$prev$tday$next\n
\n
SunMonTueWedThuFriSat
 \n"; print " \n"; print " \n"; if ($j == 1) { print " \n"; print " \n"; } else { print " \n"; } print " \n"; my $hol = &get_holiday("$yy$mm$date"); $hol and print " \n"; $edit and print " \n\n" and $edit and print " \n \n"; my ($item, $time, $color) = ('','',''); foreach $item (@data) { $item =~ /(.+),(.+)/; $item = $1; $time = $2; $item =~ /^--$/i and next; # ignore these $item =~ /^lunch$/i and next; $item =~ /^break$/i and next; $item =~ /^open$/i and next; exists $args{'inc'} and !($args{'inc'} =~ /$item\+/i) and next; $color = '#FFFFFF'; # default color is white exists $colors{$item} and $color = $colors{$item}; exists $urls{$item} and $item = "$item\n"; $time = &to12hour($time); print " \n \n"; print " \n \n"; } print "
$weeklink$datelink$datelink
$hol
Edit\nBackup\n
$item$time
\n"; print "
\n\n\n"; print "\n\n"; print "\n"; print "\n"; } else { print "Edit\n\n"; } print "\n"; print "\n
\n$filters
$contact\nIndex |\n"; print "Help |\n"; if ($edit) { print "Edit Config | \n"; print "Exit Edit Mode\nECal v$vers
\n
\n"; exit; } sub filter_menu { my ($dir, $day, $inc, $type, $num, $fmt) = @_; my ($key, $data) = ('',''); $num and $num = ";num=$num"; $fmt and $fmt = ";fmt=$fmt"; if ($inc) { $data = "No Filter: "; } else { $data = 'Filter: '; } foreach $key (sort keys %totals) { $key = lc($key); $key =~ /^--$/i and next; $key =~ /^lunch$/i and next; $key =~ /^break$/i and next; $key =~ /^open$/i and next; if ($inc =~ /$key\+/) { $data .= "$key|"; } else { $data .= "$key|"; } } chop($data); return $data; } sub get_slots { my ($dir, $day) = @_; my @data = (); my $file = "$datadir$dir$dlim$day.day"; if (open(FILE, "<$file")) { while () { /^([^\t]+)\t+([^\t]+)\t+[^\t]+\t+([^\t]+)/; push @data, uc($3) . ',' . $1; &total_hours($1, $2, $3); } close(FILE); } return @data; } sub get_holiday { my ($day) = @_; my ($hol) = (''); my $file = "$datadir$admdir$holidays"; if (open(FILE, "<$file")) { while () { /([^\t]*)\t+([^\t]*)/; $1 == $day and $hol = $2 and last; } close(FILE); } chomp($hol); return $hol; } sub month_menu { my ($dir, $year, $month, $inc, $edit, $tok) = @_; my ($data, $yy, $mm, $mmdd, $skip) = ('','','','',''); $edit eq 'week' and $skip = 'true' and $edit = ''; $edit eq 'mon' and $edit = ';edit=mon'; $inc and $inc = ";inc=$inc"; $yy = $year - 1; $yy =~ s/(^.$)/0$1/; $mmdd = '1201'; $yy < 0 and &error('35', 'anonymous', 'Out of Range', 'Cannot go back beyond the year 2000.'); $data .= "20$yy|"; for (my $i=1;$i < 13;$i++) { $mmdd = $i; $mmdd =~ s/(^.$)/0$1/; $mmdd .= '01'; if ($i == $month and !$skip) { $data .= "$mnames[$i - 1]|"; } else { $data .= "$mnames[$i - 1]|"; } } $yy = $year + 1; $yy =~ s/(^.$)/0$1/; $mmdd = '0101'; $data .= "20$yy\n"; return $data; } sub total_hours { my ($start, $stop, $type) = @_; $type = uc($type); $totals{$type} = $start; } sub export_vcal { ### need to add 'inc=' feature my ($dir, $day, $end) = @_; my ($start, $stop, $room, $summ, $type) = ('','','','',''); my $hash = &log_date_stamp; # build hash code from date $hash =~ /^..(..)(..)/; $hash = ($1 * 31) + $2; $hash = $hash % 100; my $data = $eol . 'BEGIN:VCALENDAR' . $eol . "PRODID:Generated by ECal v$vers" . $eol . "VERSION:1.0$eol$eol"; while ($day <= $end) { my $file = "$datadir$admdir$holidays"; if (open(FILE, "<$file")) { # check for holiday while () { chomp; # get rid of newline /([^\t]*)\t+([^\t]*)/; $1 == $day and $data .= "BEGIN:VEVENT" . $eol . "SUMMARY:$hash $2" . $eol . 'DTSTART:20' . $day . "T000000$eol" . "END:VEVENT$eol$eol" and last; } close(FILE); } $file = "$datadir$dir$dlim$day.day"; my $mday = &get_mod_date($file); if (open(FILE, "<$file")) { while () { chomp; # get rid of newline # s/--/ /g; # filler for blank cells if (/([^\t]*)\t+([^\t]*)\t+([^\t]*)\t+([^\t]*)\t*([^\t]*)\t*([^\t]*)\t*([^\t]*)/i) { if ($1 eq '--' and $2 eq '--' and $3 eq '--' and $4 eq '--') { $start = 'DTSTART:20' . $day . 'T000000'; $summ = "SUMMARY:$hash $5"; $data .= "BEGIN:VEVENT$eol$summ$eol$start" . $eol . "END:VEVENT$eol$eol"; } else { $start = 'DTSTART:20' . $day . 'T' . $1 . '00'; $stop = 'DTEND:20' . $day . 'T' . $2 . '00'; $room = $3; $room ne '--' and $room = " ($room)"; $room eq '--' and $room = ''; $type = uc($4); $type ne '--' and $type = " $type"; $type eq '--' and $type = ''; $summ = $5; $summ ne '--' and $summ = " $summ"; $summ eq '--' and $summ = ''; $summ = "SUMMARY:$hash$type$room$summ"; $data .= "BEGIN:VEVENT$eol$summ$eol$start$eol$stop" . $eol . "END:VEVENT$eol$eol"; } } } close(FILE); } ($stop, $day) = &get_prev_next($day); } $data .= "END:VCALENDAR$eol"; print "Content-Type: application/octet-stream\n"; print "Content-Disposition: attachment; filename=\"$exptfile\"\n"; print "Content-Description: Download of Ecal Data\n"; print "Cache-control: no-store\n"; print "Pragma: no-cache\n\n"; print $data; exit; } sub get_mod_date { my ($file) = @_; my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat $file; my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($mtime); $year += 1900; return "$mnames[$mon] $mday, $year"; } sub prev_monday { my ($day) = @_; my $next = ''; my $dow = &day_of_week($day,1); $dow == 0 and $dow = 7; # treat sunday as end of week while ($dow > 1) { # count down to monday ($day, $next) = &get_prev_next($day); $dow--; } return $day; } sub next_monday { my ($day) = @_; my $prev = ''; my $dow = &day_of_week($day,1); $dow == 0 and $dow = 7; # treat sunday as end of week while ($dow <= 7) { # count up to monday ($prev, $day) = &get_prev_next($day); $dow++; } return $day; } sub get_prev_next { my ($day) = @_; my ($dd, $mm, $yy) = (0,0,0); my ($pd, $pm, $py) = (0,0,0); my ($nd, $nm, $ny) = (0,0,0); $day =~ /(\d\d)(\d\d)(\d\d)/i; $dd = $3; $mm = $2; $yy = $1; $pd = $dd; $pm = $mm; $py = $yy; $pd--; $pd < 1 and $pm--; $pm < 1 and $py-- and $pm = 12; $pd < 1 and $pd = $mdays[$pm]; $nd = $dd; $nm = $mm; $ny = $yy; $nd++; $nd > $mdays[$mm] and $nm++; $nm > 12 and $ny++ and $nm = 1; $nd > $mdays[$mm] and $nd = 1; $py =~ s/^(.)$/0$1/i; $pm =~ s/^(.)$/0$1/i; $pd =~ s/^(.)$/0$1/i; $ny =~ s/^(.)$/0$1/i; $nm =~ s/^(.)$/0$1/i; $nd =~ s/^(.)$/0$1/i; return ("$py$pm$pd", "$ny$nm$nd"); } sub day_of_week { my ($day, $number) = @_; my ($dd, $mm, $yy) = (0,0,0); my ($mcnt, $dcnt) = (0,0); my $base_year = 2; # 2002 my $base_day = 1; # jan 1 is tue (3 - 2 (fudge factor)) $day =~ /(\d\d)(\d\d)(\d\d)/i; $dd = $3; $mm = $2; $yy = $1; for (my $i = 1; $i < $mm; $i++) { # days from prior months $dcnt += $mdays[$i]; } $dcnt += $dd; # add this month $dcnt += $base_day; # adjust for Jan 1 2002 $dcnt += ($yy - $base_year) * 365; # add prior years for ($i=$base_year; $i < $yy; $i++) { # add prior leap years $leaps[$i] and $dcnt++; } $number and return ($dcnt % 7); # return day of week number return ($dnames[$dcnt % 7]); # return day of week name } sub help_screen { my ($what) = @_; print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers Help - \u$what\e\n"; print "$charset\n$style\n\n\n\n"; print "\n"; print "\n"; print "
ECal v$vers Help - \u$what\e
"; print <
<- 1 Days +> Sample Calendar - Wed, Mar 26, 2003 << Today >>
Show Hidden 2002|Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec|2004 Show Week
Wed, Mar 26
0800 0850 C1-15 CLINDX Rheumatology  
0900 0950 C1-15 CLINDX Rheumatology  
1000 1050 C1-15 PHARM Opioids Harrison pp 345-378
1100 1150 C1-15 PHARM NSAIDs Harrison pp 379-402
noon 0100   LUNCH  
  
0100 .
.
0400		   EPC-SG Inpatient Encounter Groups 1, 4, 8, & 11
Updated Feb 27, 2003
Filter: clindx|epc-sg|ist|pharm
Contact Info Index | Help | Export ECal v1.6b3
END_OF_SAMPLE print "\n\n\n"; print "<- 1 Days +>\n"; print "Add (+) or subtract (-) days on the current page. Adds a week at a time above seven days.\n"; print "\n\n"; print "<<Today>>\n"; print "Move forward (>>) or backward (<<) by day, week, or month.\n"; print "\n\n"; print "Show Hidden\n"; print "Add (+) or subtract (-) days on the current page. Adds a week at a time above seven days.\n"; print "\n\n"; print "Show Week\n"; print "Add (+) or subtract (-) days on the current page. Adds a week at a time above seven days.\n"; print "\n\n"; print "Month List\n"; print "Add (+) or subtract (-) days on the current page. Adds a week at a time above seven days.\n"; print "\n\n"; exit; } sub splash_screen { my ($file, $dir, $item) = ('','',''); my %ecals = (); my $now = &log_date_stamp; opendir(DIR,"$datadir") or &error('04', 'anonymous', 'Directory Error', 'Cannot open directory.'); my @dirs = grep(!/\./, readdir(DIR)); closedir(DIR); foreach $dir (@dirs) { my $title = $dir; my ($contact, $view, $newest, $archive) = (' ',' ','',''); $dir eq $admname and next; # skip admin dir $file = "$datadir$dir$dlim$cfgfile"; if (open(FILE, "<$file")) { while () { /^title\t(.*)/i and $title = $1; /^view\t(.*)/i and $view = 'Restricted Access'; /^contact\t(.*)\t(.*)/i and $contact = $1 and $email = $2; /^archive\t(.*)/i and $archive = $1; $archive and $now > $archive and $view = 'Archived'; } close(FILE); } opendir(DIR,"$datadir$dir$dlim") or &error('99', 'anonymous', 'Directory Error', 'Cannot open directory.'); my @files = grep(/\.(day|cfg)/i, readdir(DIR)); closedir(DIR); foreach $item (@files) { $file = "$datadir$dir$dlim$item"; my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat $file; $mtime > $newest and $newest = $mtime; } my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($newest); $year += 1900; $newest = "$mnames[$mon] $mday, $year"; $ecals{$title} = "$title\n"; $ecals{$title} .= "$contact\n"; $ecals{$title} .= "$newest\n"; $ecals{$title} .= "$view\n"; } print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal v$vers - Online Calendars\n"; print "$charset\n$style\n\n\n\n"; print "\n"; print "\n"; print "\n"; foreach $item (sort keys %ecals) { $ecals{$item} !~ /archived/i and print $ecals{$item} } print "\n"; print "\n"; foreach $item (sort keys %ecals) { $ecals{$item} =~ /archived/i and print $ecals{$item} } print "\n
ECal v$vers - Online Calendars
CalendarContactLast Updated 
Calendar Archive
CalendarContactLast Updated 
\n"; print "Written by Richard Rathe - Copyright 2002 by the University of Florida -\n"; print "More...\n"; print "
\n\n\n"; exit; } sub to24hour { # convert to 24 hour format my ($t) = @_; # will handle several input formats ($t eq '--' or $t eq '') and return ''; my ($h, $m, $x) = (0,0,''); $t =~ /noon/i and $t = '12:00p'; # noon is a special case $t =~ s/(\d?\d)(\d\d)/$1:$2/i; # hhmm format $t =~ s/(\d?\d)(a|p)m?/$1:00$2/i; # hh format $t =~ /(\d+):(\d+)(a|p?)m?/i; # hh:mm format $h = $1; $m = $2; $x = $3; !$x and ((($h < 7 or $h == 12) and $x = 'p') or $x = 'a'); $h == 0 and $m == 0 and $x = 'a'; $x =~ /p/i and $h < 12 and $h += 12; $x =~ /a/i and $h == 12 and $h = 0; $h =~ s/^(.)$/0$1/; # pad with leading zero $m =~ s/^(.)$/0$1/; return "$h$m"; } sub to12hour { # convert to 12 hour format my ($t) = @_; # assumes input is 24 hour format $t eq ' ' and return ' '; # no data $t eq '--' and return ' '; # no data my ($h, $m, $x) = (0,0,''); $t =~ /(\d\d)(\d\d)/; $h = $1; $m = $2; $h == 12 and $m == 0 and return 'noon'; # noon is a special case $h < 7 and $x = 'a'; # early am requires 'a' $h > 12 and $h -= 12 and $h > 6 and $x = 'p'; # second half of the day ('p') $h < 1 and $h = 12 and $x = 'a'; # 0000 becomes 12am $h =~ s/^(.)$/0$1/; # pad with leading zero $m =~ s/^(.)$/0$1/; return "$h$m$x"; } sub get_fill_time { # get number of hours for fill my ($x, $y) = @_; my ($xh, $xm, $yh, $ym) = ('','','',''); $x =~ /(\d\d)(\d\d)/; $xh = $1; $xm = $2; $y =~ /(\d\d)(\d\d)/; $yh = $1; $ym = $2; $x = ($xh * 60) + $xm; $y = ($yh * 60) + $ym; my $z = ($y - $x) / 60; $z > 1 and $z < 2 and $z = 2; # round up to 2 if > 1 return int $z; } sub error { my ($num, $name, $alert, $message) = @_; my $ts = &time_stamp; print "$header$comment\n$dtdinfo\n\n"; print "\n\nECal Error! - $alert\n"; print "$charset\n$style\n\n\n\n"; print ""; print "
ECal Error!\n"; print "
\n"; print "
\n"; print "

$alert

\n"; print "

$message

\n"; print "

Error Number $num

\n"; print "
\n"; print ""; print "
$ts\n"; print "
\n"; print "\n\n"; &log_entry($args{'dir'}, $name, "ERROR $num $alert"); exit; } sub log_entry { my ($dir, $who, $info) = @_; my $logname = &log_name; my $logdate = &log_date_stamp; my $logtime = &log_time_stamp; my $logfile = $datadir . $admdir . $logdir . $logname; open(LOGFILE, ">>$logfile") or die "Bad Log File $logfile"; my $line = join("\t",$logdate,$logtime,$addr,$dir,$who,$info); print LOGFILE "$line\n"; close LOGFILE; } sub log_name { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); $mon += 1; $year += 1900; $year =~ s/^\d\d//i; if ($mon < 10) { $mon = "0" . $mon; } if ($mday < 10) { $mday = "0" . $mday; } return "dir$year-$mon.log"; } sub log_date_stamp { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); $mon += 1; $year += 1900; $year =~ s/^\d\d//i; if ($mon < 10) { $mon = "0" . $mon; } if ($mday < 10) { $mday = "0" . $mday; } return "$year$mon$mday"; } sub log_time_stamp { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); if ($hour < 10) { $hour = "0" . $hour; } if ($min < 10) { $min = "0" . $min; } return "$hour$min"; } sub time_stamp { my @months = ('January','February','March','April','May','June', 'July','August','September','October','November','December',); my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); if ($hour > 11) { $mm = "PM"; } else { $mm = "AM"; } if ($hour > 12) { $hour -= 12; } if ($hour < 1) { $hour = 12; } if ($min < 10) { $min = "0" . $min; } $year += 1900; return "$months[$mon] $mday, $year at $hour:$min $mm"; } sub log_stamp { my @months = ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec',); my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); $year += 1900; $min < 10 and $min = '0' . $min; $hour < 10 and $hour = '0' . $hour; return "$mday$months[$mon]$year|$hour:$min"; }