From 75229ac7f76a7dbd1f9c0455535600ef0ee789a1 Mon Sep 17 00:00:00 2001 From: historia <[not public]> Date: Thu, 11 Jun 2026 22:35:30 -0400 Subject: feat: added tui, fixed archive --- when.pl | 2013 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2013 insertions(+) create mode 100644 when.pl (limited to 'when.pl') diff --git a/when.pl b/when.pl new file mode 100644 index 0000000..f5197c1 --- /dev/null +++ b/when.pl @@ -0,0 +1,2013 @@ +#!/usr/bin/perl + +binmode STDOUT, ":utf8"; # eliminates "Wide character in print" error in Czech +use open ":encoding(utf8)"; # otherwise utf8 in input files is read as if 1 character==1 byte + +use utf8; # Indicates that source can contain utf8, which we use for the Greek translation. +use locale; + +use strict; +use Getopt::Long; # Comes with the Perl distribution. + +#---------------------------------------------------------------- +# Defaults for the preferences: +#---------------------------------------------------------------- + +our %preferences=( + 'language'=>'en', # user's language; this is normally overridden by $LANG environment var. + 'past'=>-1, # how many days into the past the report extends + 'future'=>14, # ...and how far into the future + 'calendar'=>'~/.when/calendar', # where to find the calendar file + 'wrap'=>80, # 0 means don't wrap; otherwise, wrap display to this many columns + 'wrap_auto'=>0, # Try to detect width of terminal automatically, if it's a TTY. + 'wrap_max'=>-1, # If positive, sets a maximum with, overriding wrap_auto if necessary. + 'rows'=>40, # try to limit output to less than this number of lines + 'rows_auto'=>1, # Try to detect width of terminal automatically, if it's a TTY. + 'paging'=>1, # Use a pager, if it's a TTY and the output is too long. + 'header'=>1, # Print headers. + 'paging_less_options'=>'-rXFE', # Extra options for the pager, if the pager is "less." + 'editor'=>'emacs -nw', # editor + 'now'=>'', # pretend it's some other day today + 'filter_accents_on_output'=>!($ENV{TERM}=~m/(mlterm|xterm)/), + # ...since most Unix terminals show accented Unicode chars as garbage. + # Testing with rxvt 2.7.10 shows that this does seem necessary for rxvt; + # see https://github.com/bcrowell/when/pull/10 . + 'styled_output'=>1, # Do they want ANSI styling if the output is a TTY? + 'styled_output_if_not_tty'=>0, # Do they want ANSI styling if the output isn't a TTY? + 'calendar_today_style'=>'bold', # ANSI styling for today's date on the calendar. + 'items_today_style'=>'bold', # ANSI styling for today's items on the calendar. + 'prefilter'=>'', # pipe calendar file through this program before feeding it to When + 'monday_first'=>0, # display Monday rather than Sunday as the first day of the week? + 'orthodox_easter'=>0, # use Orthodox Eastern Church's date for easter? + 'neighboring_months'=>1, # print 3 months when doing a "when c"? + 'ampm'=>1, # use 12-hour time? + 'auto_pm'=>0, # if nonzero, then times with hours less than this are assumed to be PM + 'literal_only'=>0, # only display items given as literal dates? + 'test_expression'=>0, # used by 'make test' +); + +our %options=( + 'help'=>0, # print documentation + 'version'=>0, # print version number, and other info + 'bare_version'=>0, # print version number + 'make_filter_regex'=>0, # to make unicode filtering efficient + 'test_accent_filtering'=>0, # to make sure it really catches all the accented characters that are present in the translations +); + +# The following is for use by Getopt::Long. ! means negatable. =s means it requires a string value, =i an integer. +our %command_line_options = ( + 'help'=>\$options{'help'}, + 'version'=>\$options{'version'}, + 'bare_version'=>\$options{'bare_version'}, + 'make_filter_regex'=>\$options{'make_filter_regex'}, + 'test_accent_filtering'=>\$options{'test_accent_filtering'}, + 'language=s'=>\$preferences{'language'}, + 'past=i'=>\$preferences{'past'}, + 'future=i'=>\$preferences{'future'}, + 'calendar=s'=>\$preferences{'calendar'}, + 'wrap=i'=>\$preferences{'wrap'}, + 'wrap_auto!'=>\$preferences{'wrap_auto'}, + 'wrap_max=i'=>\$preferences{'wrap_max'}, + 'rows=i'=>\$preferences{'rows'}, + 'rows_auto!'=>\$preferences{'rows_auto'}, + 'paging!'=>\$preferences{'paging'}, + 'header!'=>\$preferences{'header'}, + 'paging_less_options=s'=>\$preferences{'paging_less_options'}, + 'editor=s'=>\$preferences{'editor'}, + 'now=s'=>\$preferences{'now'}, + 'calendar_today_style=s'=>\$preferences{'calendar_today_style'}, + 'items_today_style=s'=>\$preferences{'items_today_style'}, + 'prefilter=s'=>\$preferences{'prefilter'}, + 'filter_accents_on_output!'=>\$preferences{'filter_accents_on_output'}, + 'styled_output!'=>\$preferences{'styled_output'}, + 'styled_output_if_not_tty!'=>\$preferences{'styled_output_if_not_tty'}, + 'monday_first!'=>\$preferences{'monday_first'}, + 'orthodox_easter!'=>\$preferences{'orthodox_easter'}, + 'neighboring_months!'=>\$preferences{'neighboring_months'}, + 'ampm!'=>\$preferences{'ampm'}, + 'auto_pm=i'=>\$preferences{'auto_pm'}, + 'literal_only!'=>\$preferences{'literal_only'}, + 'test_expression=s'=>\$preferences{'test_expression'}, + 'test_mode!'=>\$preferences{'test_mode'}, +); + +#---------------------------------------------------------------- +# Strings are all collected here for ease of internationalization: +#---------------------------------------------------------------- + +# When adding characters to the following list, make sure to add them to +# UnicodeTools::filter(), then run "./when --make_filter_regex" and cut and paste the output into UnicodeTools::filter_out_accents(). +our $e_acute = "\x{e9}"; +our $u_circumflex = "\x{fb}"; + +# German characters: +our $A_uml = "\x{c4}"; +our $a_uml = "\x{e4}"; +our $O_uml = "\x{d6}"; +our $o_uml = "\x{f6}"; +our $U_uml = "\x{dc}"; +our $u_uml = "\x{fc}"; +our $s_zlig = "\x{df}"; + +# Polish characters: +our $a_polish = "\x{105}"; +our $c_polish = "\x{107}"; +our $e_polish = "\x{119}"; +our $l_polish = "\x{142}"; +our $n_polish = "\x{144}"; +our $o_polish = "\x{0f3}"; +our $s_polish = "\x{15b}"; +our $z_polish = "\x{17a}"; +our $zz_polish = "\x{17c}"; + +# Czech characters: +our $a_acute = "\x{e1}"; +our $i_acute = "\x{ed}"; +our $u_acute = "\x{fa}"; +our $y_acute = "\x{fd}"; +our $U_acute = "\x{da}"; +our $C_wedge = "\x{10c}"; +our $c_wedge = "\x{10d}"; +our $e_wedge = "\x{11b}"; +our $R_wedge = "\x{158}"; +our $r_wedge = "\x{159}"; + +# Danish characters: +our $a_ring = "\x{e5}"; +our $A_ring = "\x{c5}"; +our $o_slash = "\x{f8}"; +our $O_slash = "\x{d8}"; +our $ae = "\x{e6}"; +our $AE = "\x{c6}"; + +# Swedish characters: +our $a_ring = "\x{e5}"; +our $A_ring = "\x{c5}"; +our $a_uml = "\x{e4}"; +our $A_uml = "\x{c4}"; +our $o_uml = "\x{f6}"; +our $O_uml = "\x{d6}"; + +# Spanish characters: +our $A_acute = "\x{c1}"; +our $E_acute = "\x{c9}"; +our $I_acute = "\x{cd}"; +our $O_acute = "\x{d3}"; +our $U_acute = "\x{da}"; +our $a_acute = "\x{e1}"; +our $e_acute = "\x{e9}"; +our $i_acute = "\x{ed}"; +our $o_acute = "\x{f3}"; +our $u_acute = "\x{fa}"; +our $n_tilde = "\x{f1}"; + +# French characters: +our $a_grave = "\x{e0}"; + +# Romanian diacritics +our $A_breve = "\x{102}"; +our $A_circumflex = "\x{c2}" ; +our $I_circumflex = "\x{ce}" ; +our $S_commabelow = "\x{218}" ; +our $T_commabelow = "\x{21a}" ; +our $a_breve = "\x{103}"; +our $a_circumflex = "\x{e2}" ; +our $i_circumflex = "\x{ee}" ; +our $s_commabelow = "\x{219}" ; +our $t_commabelow = "\x{21b}" ; +# Some time S and T with comma below are not present in the font. +# Some people are using the cedilla gliphs instead. They are wrong +# (the gliphs). +our $quot_open = "\x{201e}" ; +our $quot_close = "\x{201c}" ; +our $quotalt_open = "\x{ab}" ; +our $quotalt_close = "\x{bb}" ; +our $nonbreaking_hyphen = "\x{2011}" ; + + +#********************************************************************** +# When adding a language, make sure to update the list of languages +# in the man page as well! +#********************************************************************** + +our %month_name = + ( + 'en'=>'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec', # English + ); +our %month_name_long = + ( + # English: + 'en'=>'January February March April May June July August September October November December', + # Polish: + ); +our %wday_name = + ( + 'en'=>'Sun Mon Tue Wed Thu Fri Sat', # English + ); + +#------------------------------------------------------------------------ +# This subroutine is used every time we need to print out some text in the +# user's chosen language. +#------------------------------------------------------------------------ +sub w { + my $what = shift; # can be either a string representing a key, or [key,language] + my @stuff = @_; + my $lingo = $preferences{'language'}; + my %strings; + if (ref $what) { + $lingo = $what->[1]; + $what = $what->[0]; + } + %strings = + ( + 'date_syntax_error'=>"The date %s is not in the required format, which is 'y m d', with blanks separating the three parts.", + 'multiple_wildcards_in_date'=>"The date %s contains more than one wildcard character *. Try testing variables instead of using wildcards.", + 'error_opening_prefs'=>"The preferences file %s exists, but there was an error opening it for input.", + 'syntax_err_in_prefs'=>"Syntax error in preferences file %s:\n%s", + 'prefs_file_not_found'=>"Preferences file %s not found.\n", + 'illegal_command'=>"Illegal command, %s\n", + 'error_opening_calendar'=>"Couldn't open the file %s for input\n", + 'error_prefiltering'=>"Couldn't execute the prefilter %s\n", + 'not_utf8'=>"The file %s does not appear to be encoded in utf8 (or ascii, which is a subset of utf8). The unix 'file' utility can probably tell you what its encoding is.\n", + 'yesterday'=>'yesterday', + 'today'=>'today', + 'tomorrow'=>'tomorrow', + 'syntax_error_in_calendar'=>"Syntax error in calendar: %s\n", + 'illegal_year'=>"Illegal year: %s\n", + 'illegal_month'=>"Illegal month: %s\n", + 'illegal_day_of_month'=>"Illegal day of the month: %s\n", + 'first_time_not_tty'=>"To set up your calendar, do the command ``when'' in an interactive terminal window.\n", + 'ask_if_set_up'=>("You can now set up your calendar. This involves creating a directory ~/.when\n". + "(or somewhere else as set by an environment variable, see documentation), and making\n". + "a couple of files in it. If you want to do this, type y and hit return.\n"), + 'error_creating_dir'=>"Error creating the directory %s\n", + 'ask_for_editor'=>("You can edit your calendar file using your favorite editor. Please enter the command you\n" + ."want to use to run your editor, or hit return to accept this default:\n"), + 'error_creating_prefs'=>"Error creating the file %s\n", + 'error_creating_cal'=>"Error creating the file %s\n", + 'getting_started'=>("You can now add items to your calendar file. Do ``when --help'' for more information.\n"), + 'not_unique_w_match'=>'%s does not match a unique day of the week from %s', + 'no_w_match'=>'%s does not match any day of the week from %s', + 'not_valid_expression'=>'%s is not a valid date or expression', + 'illegal_var'=>'illegal variable: %s', + 'illegal_month_in_expression'=>'illegal month in expression: %s', + 'expression_syntax_error'=>'syntax error: %s', + 'error_running_editor'=>"Error executing command %s, %s. Perhaps %s isn't installed?\nYou selected this command in the file %s.\n", + 'describe_julian_day'=>"The date %s corresponds to modified julian day %d.\n", + ) + } + if ($what eq '__give_all_strings') {return values %strings} # used by UnicodeTools::collect_all_strings() + if (exists $strings{$what}) {$what = $strings{$what}} else {$what = w([$what,'en'],@stuff)} # fall back to English + return sprintf($what,@stuff); +} + + +#---------------------------------------------------------------- +# Some constants for ANSI terminal styling. +#---------------------------------------------------------------- +our %ansi_terminal_styling = ( + 'bold'=>1, 'underlined'=>4,'flashing'=>5, + 'fgblack'=>30,'fgred'=>31,'fggreen'=>32,'fgyellow'=>33,'fgblue'=>34,'fgpurple'=>35,'fgcyan'=>36,'fgwhite'=>37, + 'bgblack'=>40,'bgred'=>41,'bggreen'=>42,'bgyellow'=>43,'bgblue'=>44,'bgpurple'=>45,'bgcyan'=>46,'bgwhite'=>47, +); + + +#---------------------------------------------------------------- +# Read the preferences file. +#---------------------------------------------------------------- +sub find_config_dir() { + my @locations = (); # follow XDG standard, https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html + if ($ENV{WHEN_CONFIG_HOME}) { push @locations,$ENV{WHEN_CONFIG_HOME} } + if ($ENV{XDG_CONFIG_HOME}) { push @locations,"$ENV{XDG_CONFIG_HOME}/when" } + push @locations,glob "~/.config/when"; + push @locations,glob "~/.when"; + foreach my $loc(@locations) { + if (-d $loc) { return $loc } + } + return $locations[-1]; # doesn't exist, but it's the typical location, so return it and expect an error +} + +my $dir = find_config_dir(); +my $prefs_file = glob "$dir/preferences"; +our $quickie = 0; +our $got_command_line_options = 0; + +our $explicitly_set_future = 0; + # ...This is set in two places, and used in one place -- see there for an explanation of what it's for. + +if (! -e $prefs_file) { + # Normally we read command-line options after reading the prefs file, to + # allow them to override the file. However, if the prefs file doesn't exist, + # we want to do that now, and find out if this is a run where all we need to + # do is a --version or something. The reason for this complication is that we + # need to handle the case where the root user (who doesn't want to set up his + # own calendar file) is installing when, and when is being run from inside the + # makefile in order to find out what version it is. + my $old_future = $preferences{'future'}; + GetOptions(%command_line_options); # from Getops::Long + my $new_future = $preferences{'future'}; + $explicitly_set_future ||= ($old_future != $new_future); + $got_command_line_options = 1; + $quickie = + ($options{'version'} || $options{'bare_version'} || $options{'make_filter_regex'} || $options{'test_accent_filtering'} || $options{'help'} || $options{'test_expressions'}); +} + +# Note that $ENV{LANG} won't exist on non-Linux systems (e.g., doesn't exist on BSD). Debian +# systems have it set to, e.g., "en_US", but apparently Red Hat does something like "en_US.utf8". +if (exists $ENV{LANG}) { + if ($ENV{LANG} =~ m/^(..)/) { + my $l = lc($1); + $preferences{'language'} = $l; + } +} +# Later on, we check whether the language has been set in the preferences +# file or in a command line option. If the end result is that the language +# is set to something goofy (e.g., because we failed to parse $LANG correctly, +# or because the user's language isn't one we support), then the language defaults +# back to English anyway. + +if (!$quickie && (! -e $dir or ! -e $prefs_file) && !$preferences{'test_mode'}) { + run_first_time($preferences{'calendar'}); +} +if (-e $prefs_file) { + UnicodeTools::file_is_valid_utf8($prefs_file) or die w('not_utf8',$prefs_file); + open (FILE,"<$prefs_file") or die w('error_opening_prefs',$prefs_file); + while (my $line = ) { + if ($line =~ m/^\s*(\w+)\s*\=\s*([^\s].*)*/) { + my ($option,$value) = ($1,$2); + $value =~ s/#.*$//; # strip comment marked by # + $value =~ s/\s+$//; # strip trailing blanks + $preferences{lc($option)} = $value; + if (lc($option) eq 'future') {$explicitly_set_future=1} + } + else { + if (!($line =~ m/^\s*(#.*)?$/)) {die w('syntax_err_in_prefs',$prefs_file,$line)} + # The (#.*)? is to allow lines consisting of only a comment prefaced by #. + } + } + close FILE; +} +else { + do_output(w('prefs_file_not_found',$prefs_file)) if !($quickie || $preferences{'test_mode'}); +} + +#---------------------------------------------------------------- +# Some global variables. +#---------------------------------------------------------------- +our $date_delimiter = ' '; # e.g. 2003 Feb 1 +our $use_month_names = 1; + +our @month_length = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + +#---------------------------------------------------------------- +# Figure out what the user wants to do. +#---------------------------------------------------------------- + +my $cmds = ''; + +foreach my $arg(@ARGV) { + if (! ($arg =~ m/^\-/)) { + $cmds = $cmds . lc($arg); + } +} + +if (!$got_command_line_options) { + my $old_future = $preferences{'future'}; + GetOptions(%command_line_options); # from Getops::Long + my $new_future = $preferences{'future'}; + $explicitly_set_future ||= ($old_future != $new_future); +} + +if ($preferences{'rows_auto'} && -t STDOUT) { + $preferences{'rows'} = Terminal::rows(); +} +if ($explicitly_set_future) { + $preferences{'rows'} = 9999; # They explicitly set number of days into future, so don't chop it off. +} + +my $want_styling = ($preferences{'styled_output'} && -t STDOUT) || ($preferences{'styled_output_if_not_tty'} && ! -t STDOUT); + +my @do_what = (); + +if ($cmds eq '') {$cmds = 'i'} + +my %periods = ('w'=>7,'m'=>31,'y'=>366); +#loop over chars in arg: +while ($cmds =~ m/(.)/g) { + my $cmd = $1; + my $recognized = 0; + if (exists $periods{$cmd}) { + $recognized = 1; + push @do_what,'normal'; + $preferences{'future'} = $periods{$cmd}; + $preferences{'rows'} = 9999; # If they say they want a year in advance, don't chop it off. + } + else { + if ($cmd eq 'd') { + $recognized = 1; + push @do_what,'date'; + } + if ($cmd eq 'i') { + $recognized = 1; + push @do_what,'normal'; + } + if ($cmd eq 'c') { + $recognized = 1; + push @do_what,'calendar'; + } + if ($cmd eq 'e') { + $recognized = 1; + push @do_what,'edit'; + } + if ($cmd eq 'j') { + $recognized = 1; + push @do_what,'modified_julian_day'; + } + } + if (!$recognized) { + die w('illegal_command',$cmd); + } +} + +# Setting the calendar file after the command-line options have been read +my $file = glob $preferences{'calendar'}; +if (!$quickie && ! -e $file && !$preferences{'test_mode'}) { + run_first_time($file); +} + +#---------------------------------------------------------------- +# Do it. +#---------------------------------------------------------------- + +my $now = When::current_date(); +if ($preferences{'now'} ne '') { + my $r = When::parse_blank_delimited($preferences{'now'}); + if ($r->[0]) { + die $r->[0]; + } + $now = $r->[1]; +} + +if ($options{'help'}) { + print documentation(); + exit(0); +} + +if ($preferences{'test_expression'}) { + $preferences{'test_expression'} =~ m/^([^,]+),([^,]+),([^,]+),(.*)$/; + my ($date,$result,$expr,$comment) = ($1,$2,$3,$4); + # result is 0, 1, or e if an error is expected + my $expect_err = ($result=~m/e/i); + my $failure = sub { + my $info = shift; + print "Failed test\n $comment\n"; + print " date=$date\n expect_err=$expect_err\n result=$result\n expr=$expr\n"; + print "$info\n"; + exit(-1); + }; + my $match = DateMatch->new('condition',$expr); + if ($match->{ERR} && ! $expect_err) { + my $err = $match->{ERR}; + $failure->("unexpected error, $err"); + } + if ((!($match->{ERR})) && $expect_err) { + $failure->("error expected, but none occurred"); + } + if (!($match->{ERR})) { + my $x = When::parse_blank_delimited($date); + my $err = $x->[0]; + $failure->("error parsing date $date, $err") if $err; + my $when = $x->[1]; + my $got_result = $match->evaluate($when,{},$when->day_of_week); + $failure->("expected result '$result', got '$got_result'") if ($got_result xor $result); + } + exit(0); +} + +if ($options{'version'}) { + print "When version $version, (c) 2003-2011 Benjamin Crowell.\nDo 'when --help' for help and copyleft information.\n"; + exit(0); +} +if ($options{'bare_version'}) { + print $version; + exit(0); +} +if ($options{'make_filter_regex'}) { + print UnicodeTools::make_filter_regex()."\n"; + exit(0); +} +if ($options{'test_accent_filtering'}) { + my @lingos = keys %month_name; + my @strings = (); + foreach my $lingo(@lingos) { + @strings = (@strings,$month_name{$lingo},$month_name_long{$lingo},$wday_name{$lingo}); + my $save = $preferences{'language'}; + $preferences{'language'} = $lingo; + @strings = (@strings,w('__give_all_strings')); + $preferences{'language'} = $save; + } + my $result = UnicodeTools::test_accent_filtering(@strings); # All this does is make sure it ends up pure ascii. + if ($result eq '') { + exit(0); + } + else { + print STDERR $result; + exit(-1); + } +} + +my $first_one = 1; +foreach my $cmd(@do_what) { + if (!$first_one) { + do_output("\n"); + } + $first_one = 0; + if ($cmd eq 'date') { + do_output(describe_date()."\n"); + } + if ($cmd eq 'normal') { + if (normal_behavior($now,$want_styling)!=0) {exit(-1)}; + } + if ($cmd eq 'calendar') { + calendar(NOW=>$now,WANT_STYLING=>$want_styling,TODAY_STYLE=>$preferences{'calendar_today_style'},PAST=>$preferences{'past'},FUTURE=>$preferences{'future'}); + } + if ($cmd eq 'edit') { + my $c = $preferences{'editor'}." ".$preferences{'calendar'}; + unless(system($c)==0) { + print STDERR w('error_running_editor',$c,$!,$preferences{editor},$prefs_file); + exit(-1); + } + } + if ($cmd eq 'modified_julian_day') { + #print "The date ".$now->string_human()." corresponds to modified julian day ".$now->modified_julian_day().".\n"; + print w('describe_julian_day',$now->string_human(),$now->modified_julian_day()); + } +} + +sub describe_date { + my $describe_wday = $now->day_of_week_name; + my $describe_today = $now->string_human(); + my @tm = localtime; + my ($hour,$minute) = ($tm[2],$tm[1]); + $hour = (($hour-1) % 12)+1 if ($preferences{'ampm'}); + my $describe_time = sprintf "%d:%02d",$hour,$minute; + return "$describe_wday $describe_today $describe_time"; +} + +sub do_output { + my $x = shift; + print filter_accents_if_desired($x); +} + +sub do_output_to_stderr { + my $x = shift; + print STDERR filter_accents_if_desired($x); +} + +sub filter_accents_if_desired { + my $x = shift; + if ($preferences{'filter_accents_on_output'}) { + $x = UnicodeTools::filter_out_accents($x); + } + return $x; +} + +#---------------------------------------------------------------- +# The program's normal behavior is to print out all your appointments +# for a certain period (by default, the next two weeks). +#---------------------------------------------------------------- + +sub normal_behavior { + my $now = shift->clone; + my $want_styling = shift; + + my $complete_output = ''; + my $lines_done = 2; # header and blank line under it + + if ($preferences{'header'}) { + $complete_output = $complete_output . filter_accents_if_desired(describe_date())."\n\n"; + $lines_done += 2; # header and blank line under it + } + + my @find_longest = (w('yesterday'),w('today'),w('tomorrow')); + for (my $day_num=1; $day_num<=7; $day_num++) { + push @find_longest,When::short_wday_name($day_num); + } + my $max_wday_length = 8; + foreach my $day(@find_longest) { + my $length = AnsiTerminalStyling::length(filter_accents_if_desired($day)); # filter_accents_if_desired may change length of string + $max_wday_length = $length if $length>$max_wday_length; + } + + -r $file or die w('error_opening_calendar',$file); + + # Make sure the calendar file is utf8. Horrible things happen if, e.g., it's iso-8859. + # This involves reading the file again. We do this after the original reading of the file, + # since that's where the error handling is if the file doesn't exist, etc. + UnicodeTools::file_is_valid_utf8($file) or die w('not_utf8',$file); + + my $prefilter = $preferences{'prefilter'}; + my $calendar_input; + if ($prefilter eq '') { + $calendar_input = "<$file"; + } + else { + $calendar_input = "$prefilter <$file |"; + } + + open (FILE, $calendar_input) or die w('error_opening_calendar',$file); + my @lines = ; # in array context, returns all lines from file + close FILE or die w("error_prefiltering",$calendar_input); + + my @show; + my @condition_lines; + + my $list_one = sub { + my $when = shift; + my $delta = shift; + my $what = shift; + my $describe = $when->day_of_week_name; + if ($delta == -1) {$describe = w('yesterday')} + if ($delta == 0) {$describe = AnsiTerminalStyling::style_text(w('today'),$preferences{'items_today_style'},$want_styling)} + if ($delta == 1) {$describe = w('tomorrow')} + $describe = filter_accents_if_desired($describe); + $describe = AnsiTerminalStyling::pad_to_desired_length($describe,$max_wday_length+1,' '); + my $say = sprintf "%s %s %s\n",$describe,$when->string_human,$what; + push @show,[$when->clone,$say,$what]; + }; + foreach my $line(@lines) { + chomp $line; + if ($line =~ m/^\s*([^,#]*)\s*,\s*(([^\s].*)?)/) { + my ($date,$what) = ($1,$3); + my $match; + my $exact = !($date=~m/[=<>%]/); # exact includes both dates of the form "2008 jul 4" and those like "2008* jul 4" and "* jul 4" + my $literal = $exact && !($date=~/\*/); # literal means only dates of the form "2008 jul 4" + my $only_if_literal = $preferences{literal_only}; + my $ignore = (!$literal) && $only_if_literal; + if (!$ignore) { + if ($exact) { + $match = DateMatch->new('exact',$date); + if ($match->{ERR} ne '') { + my $err = $match->{ERR}; + do_output_to_stderr("****** $err\n****** $line\n\n"); + return -1; + } + } + else { + $match = DateMatch->new('condition',$date); + if ($match->{ERR}) { + my $err = $match->{ERR}; + do_output_to_stderr("****** $err\n****** $line\n\n"); + return -1; + } + } + if ($match->{TYPE} eq 'condition') { + push @condition_lines,[$match,$what]; + } + if ($match->{TYPE} eq 'exact') { + my $when = $match->{WHEN}; + if ($when->y =~ m/\*/) { + my $that_year = ''; + if ($when->y =~ m/(\d+)/) {$that_year=$1}; # "1996*" syntax + $when->y($now->y); + if ($when->delta_days($now)<$preferences{'past'}) {$when->y($when->y+1)} + if ($when->delta_days($now)>$preferences{'future'}) {$when->y($when->y-1)} + if ($when->y =~ m/(\d+)/) { + my $years_since = $when->y()-$that_year; + $what =~ s/\\a/$years_since/g; + $what =~ s/\\y/$that_year/g; + } + } + my $delta = $when->delta_days($now); + if ($delta >= $preferences{'past'} && $delta <=$preferences{'future'}) { + &$list_one($when,$delta,$what); + } + } + } # end if not ignored + } # end if line has the syntax of a calendar entry + else { # Ignore lines consisting only of whitespace and lines that begin with # (comments). + if (!($line =~ m/^\s*$/ || $line =~ m/^#/)) {die w('syntax_error_in_calendar',$line)} + } + } + + if (@condition_lines) { + my $then = $now->clone; + my ($d1,$d2) = ($preferences{'past'},$preferences{'future'}); + $then->add_delta_days_in_place($d1); + my $day_of_week = $then->day_of_week; + for (my $delta=$d1; $delta<=$d2; $delta++) { + my %vars = (); + foreach my $cond(@condition_lines) { + my ($match,$what) = @$cond; + my $result = $match->evaluate($then,\%vars,$day_of_week); + &$list_one($then,$delta,$what) if $result; + } # end loop over condition lines + $then->increment_day_in_place(); + $day_of_week = ($day_of_week%7)+1; # we go 1..7, not 0..6; this is like ((x-1+1)%7)+1 + } # end loop over days + } # end if condition lines + + # For purposes of sorting entries, we recognize when the text of an entry begins with a time in h:mm format, with an optional a or p for am or pm. + # This subroutine returns 9999 if the string doesn't begin with a time, or the time in minutes otherwise. + my $get_time = sub { + my $x = shift; + my $match_ampm = $preferences{'ampm'} ? '[ap]?' : ''; + return 9999 unless $x =~ /^\s*(\d+):(\d+)($match_ampm)/i; + my ($h,$m,$am_pm) = ($1,$2,$3); + if (!$am_pm && $h<$preferences{'auto_pm'}) {$h+=12} + if ($am_pm=~/p/ && $h != 12 ) {$h+=12} + if ($am_pm=~/a/ && $h == 12) { $h-=12 } + return 9999 unless ($h<=23 && $m<=59); + return $h*60+$m; + }; + @show = sort { + my $time_order = $a->[0]->compare($b->[0]); + return $time_order if $time_order; + my ($txt_a,$txt_b) = ($a->[2],$b->[2]); # the texts of the two calendar entries + &$get_time($txt_a) <=> &$get_time($txt_b) + # In the case where they're both times, this makes the earlier one come first. + # In the case where one is a time and one isn't, the timed one comes first. + # In the case where neither is timed, this also does the right thing. + } @show; + + my $wrap = $preferences{'wrap'}; + if ($wrap==0) {$wrap=9999} + if ($preferences{'wrap_auto'}) { + my $terminal_width = Terminal::columns(); + if ($terminal_width>0) {$wrap=$terminal_width} + } + if ($preferences{'wrap_max'}>0 && $wrap>$preferences{'wrap_max'}) { + $wrap=$preferences{'wrap_max'} + } + my $rows = $preferences{'rows'}; + if ($rows==0) {$rows=9999} + my $margin = $max_wday_length+14; # This is the width of the column containing the date. + if ($wrap<$margin+10) {$wrap=$margin+10} # otherwise you get an endless loop + foreach my $thing(@show) { + my ($when,$say) = @$thing; + my $output = format_item($say,$wrap,$margin); + $lines_done += split /\n/,$output; + last if $lines_done>$rows && $when->delta_days($now)>3; + $complete_output = $complete_output . filter_accents_if_desired($output); + } + my $did_it = 0; + if ($preferences{'paging'} && -t STDOUT && Terminal::rows()>0 && $lines_done>Terminal::rows()-1) { + my $pager = $ENV{PAGER}; + if (!defined $pager) {$pager = "less"} + if ($pager eq 'less') {$pager = "$pager ".$preferences{'paging_less_options'}} + if (open(FILE,"| $pager")) { + print FILE $complete_output; + close FILE; + $did_it = 1; + } + } + if (!$did_it) {print $complete_output} + return 0; +} + +#---------------------------------------------------------------- +# Print a calendar. +#---------------------------------------------------------------- +sub calendar { + my %args = ( + NOW=>'', + WANT_STYLING=>0, + TODAY_STYLE=>'', + PAST=>0, + FUTURE=>0, + @_, + ); + + my $now = $args{NOW}->clone; + my $past = $args{PAST}; + my $future = $args{FUTURE}; + + # Normally we just print out three months, next to each other horizontally. + # However, if the user specified some other time period than the default, we + # print out multiple rows, e.g., they may want a full year's worth of calendars (four lines). + # The following are generous limits -- we check more carefully later: + my $row_start = int($past/90)-2; + my $row_end = int($future/90)+2; + + for (my $row=$row_start; $row<=$row_end; $row++) { + + my $middle_month = $now->clone; + for (my $i=1; $i<=abs($row); $i++) { + if ($row<0) { + $middle_month->decrement_month_in_place(); + $middle_month->decrement_month_in_place(); + $middle_month->decrement_month_in_place(); + } + if ($row>0) { + $middle_month->increment_month_in_place(); + $middle_month->increment_month_in_place(); + $middle_month->increment_month_in_place(); + } + } + my $last_month = $middle_month->clone; + my $next_month = $middle_month->clone; + $last_month->decrement_month_in_place(); + $next_month->increment_month_in_place(); + + # Check whether we really need to print this row in order to cover their chosen time period: + my $range_lo = $last_month->clone; + my $range_hi = $next_month->clone; + $range_lo->d(1); + $range_hi->d($range_hi->days_in_month); + my $needed = $range_hi->delta_days($now)-$past>=0 && $range_lo->delta_days($now)-$future<=0; + + if ($needed) { + my @cals; + for (my $i=-1; $i<=1; $i++) { + my $month = [$last_month,$middle_month,$next_month]->[$i+1]; + my @cal = make_one_month_calendar(WHEN=>$month,WANT_STYLING=>$args{WANT_STYLING},TODAY_STYLE=>$args{TODAY_STYLE},MARK_TODAY=>($i==0 && $row==0)); + my $month_needed = 1; + if (!$preferences{'neighboring_months'}) { + my $first_day_of_month = $month->clone; + $first_day_of_month->d(1); + my $last_day_of_month = $month->clone; + $last_day_of_month->d($month->days_in_month); + $month_needed=0 if $first_day_of_month->delta_days($now)-$future>0 || $last_day_of_month->delta_days($now)-$past<0; + } + push @cals,\@cal if $month_needed; + } + do_output(combine_calendars_for_several_months(@cals)); + } # end if $needed + + } # end loop over $row + +} + +sub combine_calendars_for_several_months { + my @cals = @_; + my $output = ''; + for (my $line_num=0; $line_num<=10; $line_num++) { + my $have_one = 0; + foreach my $cal(@cals) { + $have_one = $have_one || exists $cal->[$line_num]; + } + if ($have_one) { + my $full_line = ''; + foreach my $cal(@cals) { + my $part; + if (exists $cal->[$line_num]) { + $part = $cal->[$line_num]; + } + else { + $part = (' ' x 21); #### constant shouldn't be hardcoded + } + if ($full_line ne '') {$full_line = "$full_line "} + $full_line = $full_line . $part; + } + $output = $output . $full_line . "\n"; + } + else { + last + } + } # end loop over $line_num + return $output; +} + +sub make_one_month_calendar { + my %args = ( + MARK_TODAY=>0, + WANT_STYLING=>0, + TODAY_STYLE=>'', + @_, + ); + my $when = $args{WHEN}->clone; + my $mark_today = $args{MARK_TODAY}; + my @cal = (); + + my $today = $when->clone; + + my $columns = 21; # 3 columns for each day of the week + + my $month_name_long = When::month_name_long($when->m); + # Pad it on the front and back so it's roughly centered: + my $pad_character = '-'; + while (AnsiTerminalStyling::length($month_name_long)<$columns) { + if (AnsiTerminalStyling::length($month_name_long)%2==0) { + $month_name_long = "$month_name_long$pad_character"; + } + else { + $month_name_long = "$pad_character$month_name_long"; + } + } + push @cal,$month_name_long if $preferences{'header'}; + + my $line = ''; + for (my $wday=1; $wday<=7; $wday++) { + $line = $line . ' '.When::short_wday_name($wday).' '; + } + push @cal,$line if $preferences{'header'}; + + $line = ''; + $when->d(1); + for (my $wday=1; $wday<$when->day_of_week && $wday<=7; $wday++) { + $line = $line . ' '; + } + my $this_month = $when->m; + while ($when->m == $this_month) { + my $display = sprintf('%2d',$when->d); + if ($when->compare($today)==0 && $mark_today) { + if ($args{WANT_STYLING} && $args{TODAY_STYLE} ne '') { + $display = AnsiTerminalStyling::style_text($display,$args{TODAY_STYLE},$args{WANT_STYLING}); + } + else { + $display = ' *'; + } + } + $line = "$line$display "; + $when->increment_day_in_place(); + # The first day of a second and the subsequent weeks in this month + # will be printed on the next line in the calendar + if ($when->day_of_week==1) {push @cal,$line; $line = ''} + } + if ($line ne '') {push @cal,$line; $line = ''} + + # Make sure all the lines are equal in length: + for (my $i=0; $i<=$#cal; $i++) { + my $line = $cal[$i]; + while (AnsiTerminalStyling::length($line)<$columns) { + $line = "$line "; + } + $cal[$i] = $line; + } + + return @cal; +} + + +#---------------------------------------------------------------- +# Help them set up the first time through. +#---------------------------------------------------------------- +sub run_first_time { + my $cal_file = glob shift; + + if (!(-t STDIN && -t STDOUT)) { + die w('first_time_not_tty'); + } + + print w('ask_if_set_up'); + my $want_to = ; + chomp $want_to; + if (lc($want_to) ne 'y') {exit(-1)} + + my $dir = glob "~/.when"; + if (! -d $dir) { + mkdir($dir) or die sprintf w('error_creating_dir'),$dir; + } + + my $editor = $preferences{'editor'}; + print w('ask_for_editor'); + print " $editor\n"; + my $want_editor = ; + chomp $want_editor; + if ($want_editor ne '') {$editor=$want_editor} + + my $prefs = glob "~/.when/preferences"; + if (! -e $prefs) { + open(PREFS,">$prefs") or die sprintf w('error_creating_prefs'),$prefs; + print PREFS "calendar = $cal_file\n"; + print PREFS "editor = $editor\n"; + close(PREFS); + } + if (! -e $cal_file) { + open(CAL,">$cal_file") or die w('error_creating_cal'),$cal_file; + close(CAL); + } + + print w('getting_started'); +} + +#---------------------------------------------------------------- +# Routines for wrapping long lines: +#---------------------------------------------------------------- + +# Format a line of text for output. Wrap long lines nicely. +sub format_item { + my $text = shift; + my $wrap = shift; + my $margin = shift; + chomp $text; + my @stuff = split_a_line($text,$wrap,2); + my $result = (shift @stuff)."\n"; + my @the_rest = (); + if (@stuff) { + @the_rest = split_a_line((shift @stuff),$wrap-$margin,9999); + } + foreach my $line(@the_rest) { + $result = $result . (' ' x $margin) . "$line\n"; + } + return $result; +} + +# Split a long line into shorter pieces, preferably at word breaks. Do unicode->ascii +# filtering here (if it's turned on), because sometimes filtering turns a single +# unicode character to two ascii characters (e.g., Danish o_slash => oe). +sub split_a_line { + my $text = shift; + my $width = shift; + my $max_pieces = shift; + if ($preferences{'filter_accents_on_output'}) { + $text = UnicodeTools::filter_out_accents($text); # see comment above + } + if (AnsiTerminalStyling::length($text)<=$width || $max_pieces==1) {return ($text,)} + if ($text =~ m/^(.{0,$width})(\s+(.*))?$/) { + my ($a,$b) = ($1,$3); + return ($a,split_a_line($b,$width,$max_pieces-1)) + } + # The only reason we'd get to this point is if the input starts with an extremely long line + # consisting of one extremely long word with no blanks in it. This means we can't + # break at a word boundary. This typically happens with URLs. + $text =~ m/^(.{0,$width})(.*)$/; + my ($a,$b) = ($1,$2); + return ($a,split_a_line($b,$width,$max_pieces-1)); +} + + +#---------------------------------------------------------------- +# A DateMatch object knows how to test whether a given date +# matches it or not. +#---------------------------------------------------------------- +package DateMatch; + +# Error handling: ERR field is set to a null string or a string containing a fully processed, internationalized error message +sub new { + my $class = shift; + my $self = {}; + bless($self,$class); + $self->{TYPE} = shift; # can be 'exact' or 'condition' + $self->{ERR} = undef; + my $source = shift; + if ($self->{TYPE} eq 'exact') { + my $parsed_date = When::parse_blank_delimited($source); + my ($err,$when) = @$parsed_date; + $self->{WHEN} = $when; + $err =~ s/\n$//; + $self->{ERR} = $err; + return $self; + } + if ($self->{TYPE} eq 'condition') { + $self->{SOURCE} = $source; + my $expr = compile_expression($source); + my $e = $expr->[0]; + if (!defined $e) {$e = ''} + if (ref $e) {$e = main::w(@$e)} + $self->{ERR} = $e; + $self->{PARSED} = $expr->[1]; + return $self; + } # end if it's a condition +} + +sub evaluate { + my $self = shift; + my $when = shift; + my $vars = shift; # for efficiency; avoid recalculating these if possible + my $day_of_week = shift; # for efficiency, must be provided by caller + my @stack = (); + my $parsed = $self->{PARSED}; + foreach my $rpn (@$parsed) { + #---- push variable onto stack + if ($rpn =~ m/^[a-z]$/) { + if ($rpn =~ m/^[abdjmywcnez]$/) { + if (!exists $vars->{$rpn}) { + # parser should have caught it if it wasn't one of these vars: + if ($rpn eq 'w') {$vars->{$rpn}=$day_of_week} + if ($rpn eq 'y') {$vars->{$rpn}=$when->y} + if ($rpn eq 'm') {$vars->{$rpn}=$when->m} + if ($rpn eq 'd') {$vars->{$rpn}=$when->d} + if ($rpn eq 'j') {$vars->{$rpn}=$when->modified_julian_day} + if ($rpn eq 'a') {$vars->{$rpn}=$when->week_a} + if ($rpn eq 'b') {$vars->{$rpn}=$when->week_b} + if ($rpn eq 'c') {$vars->{$rpn}=$when->adjacent_weekend_day} + if ($rpn eq 'n') {$vars->{$rpn}=$when->days_in_month} + if ($rpn eq 'e') {$vars->{$rpn}=Easter::easter($when->y)->delta_days($when)} + if ($rpn eq 'z') {$vars->{$rpn}=$when->day_of_year} + } + push @stack,$vars->{$rpn}; + } + else { + die "Illegal variable $rpn in expression @$parsed"; # kludge, not internationalized; parser should have caught it before this anyway + } + } + #---- push constant onto stack + elsif ($rpn =~ m/^\d+$/) { push @stack, $rpn } + #---- unary op: ! + elsif ($rpn eq '!') { + my $a = pop @stack; + push @stack, !$a; + } + #---- binary op: =, <, etc. + else { + my $b = pop @stack; + my $a = pop @stack; + # the one that came first in the source is second to come off the stack + my $result; + if ($rpn eq '=') { $result = $a == $b } + elsif ($rpn eq '<') { $result = $a < $b } + elsif ($rpn eq '>') { $result = $a > $b } + elsif ($rpn eq '<=') { $result = $a <= $b } + elsif ($rpn eq '>=') { $result = $a >= $b } + elsif ($rpn eq '!=') { $result = $a != $b } + elsif ($rpn eq '%') { $result = $a % $b } + elsif ($rpn eq '-') { $result = $a - $b } + elsif ($rpn eq '&') { $result = $a && $b } + elsif ($rpn eq '|') { $result = $a || $b } + push @stack, $result; + } + } # end loop over RPN + return pop @stack; +} + +sub priority($) { + my $op = shift; + #if ($op eq '!') { return 1 } + if ($op eq '%') { return 2 } + if ($op eq '-') { return 3 } + if ($op eq '>' || $op eq '<' || $op eq '<=' || $op eq '>=') { return 4 } + if ($op eq '=' || $op eq '!=') { return 5 } + if ($op eq '!') { return 6 } + if ($op eq '&') { return 7 } + if ($op eq '|') { return 8 } + if ($op eq '(') { return 9 } + return 0; +} + +# Error handling: first element of return value is either undef or an array to be passed to w() for internationalization. +sub compile_expression { # a test such as 'm=dec & d=25' + my $source = lc shift; + my @ex = split / */, $source; # split into individual characters, stripping whitespace + my @rpn; + my @opst = ('('); # bottom for the stack + my ($op, $op2, $pr, $err); + + my $i = 0; + while ($i < @ex) { + my $single_alpha_token = ($ex[$i] =~ /[[:alpha:]]/ && $ex[$i+1] !~ /[[:alpha:]]/); # this char is alphabetic but the next char is not, i.e., we're looking at a one-character token + my $multiple_alpha_token = ($ex[$i] =~ /[[:alpha:]]/ && $ex[$i+1] =~ /[[:alpha:]]/); + my $left = $rpn[-1]; + my $testing_equality = $i>0 && $ex[$i-1] =~ /^[=<>]$/; + my $expect_literal = ($left=~/^[mw]$/) && $testing_equality && $ex[$i] ne '='; # we're parsing the right-hand-side of something like m=jan or w=thu + if ($ex[$i] =~ /\d/) { + my $num = 0; + while ($i < @ex && $ex[$i] =~ /\d/) { + $num = 10 * $num + $ex[$i]; + $i++; + } + push @rpn, $num; + } + elsif ($single_alpha_token && !$expect_literal) { + if ($ex[$i] =~ /[abcdjmnywez]/) { push @rpn, $ex[$i++] } + else {$err = ['illegal_var', $ex[$i++]] } + } + elsif ($multiple_alpha_token || $expect_literal) { # this is or should be a month or weekday literal like jan or thu + if ($multiple_alpha_token && !$expect_literal) {return [['expression_syntax_error',$source],undef]} # literals like jan or thu can only appear on r.h.s. of m= or w= + my $lvar; + while ($i < @ex && $ex[$i] =~ /[[:alpha:]]/) { + $lvar .= $ex[$i]; + $i++; + } + # $left is guaranteed to be m or w at this point + if ($left eq 'm') { + my $parsed_month = When::parse_month_name($lvar); + if (!$parsed_month) {$err = ['illegal_month_in_expression',$lvar]} + $lvar = $parsed_month; + } + if ($left eq 'w') { + my $r = When::parse_wday_name($lvar); + if ($r->{'err'}) { + $err = [$r->{'err'},$lvar, $wday_name{$preferences{'language'}}]; + } + $lvar = $r->{'match'}; + } + push @rpn, $lvar; # $lvar may be null in cases like w=t, where t is ambiguous and causes an error + } + elsif ($ex[$i] eq '(') { + push @opst, '('; + $i++; + } + elsif ($ex[$i] eq ')') { + $op = pop @opst; + while ($op ne '(') { + push @rpn, $op; + $op = pop @opst; + } + $i++; + } + elsif ($ex[$i] eq '!' && $ex[$i+1] ne '=') { + # '!' has right associativity, so it is in a separate case + $pr = priority '!'; + $op2 = pop @opst; + while ($pr > priority $op2) { + push @rpn, $op2; + $op2 = pop @opst; + } + push @opst, $op2; + push @opst, '!'; + $i++; + } + elsif ($ex[$i] =~ /[!%\-\&\|<>=]/) { + $op = $ex[$i]; + if ($op =~ /[\!<>]/ && $ex[$i+1] eq '=') { + $op .= '='; + $i++; + } + $pr = priority $op; + $op2 = pop @opst; + while ($pr >= priority $op2) { + push @rpn, $op2; + $op2 = pop @opst; + } + push @opst, $op2; + push @opst, $op; + $i++; + } + else { return [['not_valid_expression',$source]] } + } + while ($op = pop @opst and $op ne '(') { push @rpn, $op } + if (@opst) { $err = ['not_valid_expression',$source] } + return [$err, \@rpn]; +} + +#---------------------------------------------------------------- +# A When object stores year, month, day, time (ymdt). +# Month is 1..12 +# Time is null, or hour, or hour:min; hour is on 24-hour time. +# There are methods for doing calculations with the Gregorian calendar. +#---------------------------------------------------------------- + +package When; + + +sub new { + my $class = shift; + my $self = {}; + bless($self,$class); + $self->{Y} = shift; + $self->{M} = shift; + $self->{D} = shift; + if (@_) { + $self->{T}=shift + } + else { + $self->{T} = ''; + } + return $self; +} + +# Returns [e,w], where w is a When object and e is a null string or a fully processed, internationalized error message +sub parse_blank_delimited { + my $date = shift; + chomp $date; + my @a = split / +/,$date; + if ($date=~/\*.*\*/) {return [main::w('multiple_wildcards_in_date',$date)]} + if ($#a+1!=3) {return [main::w('date_syntax_error',$date)]} # should have exactly three parts, y m d + if ($a[0] ne '*' && ($a[0]<1900 || $a[0]>2200)) {return [main::w('illegal_year',$a[0])]} + $a[1] = parse_month_name($a[1]); + if ($a[1] eq '' || $a[1]<1 || $a[1]>12) {return [main::w('illegal_month',$a[1])]} + my $w = When->new(@a); + my $len = $w->days_in_month; # returns 29 if input is * feb 29 + if ($a[2]<1 || $a[2]>$len) {return [main::w('illegal_day_of_month',$date)]} + return ['',$w]; +} + +# can be number or name +# if it's a name, ignores case, trailing dot, and extra characters not needed for uniqueness +BEGIN { +my %cache = (); # cache results, because this routine tends to be a cpu hog +sub parse_month_name { + my $name = shift; + my $orig_name = $name; + if ($name =~ m/\d+/) {return $name} + return $cache{$name} if exists $cache{$name}; + $name = UnicodeTools::filter_out_accents($name); + $name =~ s/\.$//; # remove trailing dot + my $language = $preferences{'language'}; + # Special case for czech, where Cerven/Cervenec tie us up in knots: + if ($language eq 'cs') { + return 6 if lc($name) eq 'cer'; + return 7 if lc($name) eq 'cec'; + } + my @try_langs = (); + push @try_langs,$language if exists $month_name{$language}; + if ($language ne 'en') { + push @try_langs,'en'; + } + my %matches = (); + foreach my $try_lang(@try_langs) { + for (my $m=1; $m<=12; $m++) { + my $n = UnicodeTools::filter_out_accents(month_name_long($m,$try_lang)); + if ($name =~ m/^$n/i || $n =~ m/^$name/i) {$matches{$m}=1} + } + my @matches = keys %matches; + if (@matches==1) {my $result = $matches[0]; $cache{$orig_name}=$result; return $result} + if (@matches>1) {return ''} # ambiguous + } + return ''; +} +} + +# ignores case, trailing dot, and extra characters not needed for uniqueness +sub parse_wday_name { + my $name = shift; + $name = UnicodeTools::filter_out_accents($name); + $name =~ s/\.$//; # remove trailing dot + my $language = $preferences{'language'}; + my @try_langs = (); + push @try_langs,$language if exists $wday_name{$language}; + if ($language ne 'en' || @try_langs==0) { + push @try_langs,'en'; + } + my @matches = (); + my $n_matches = 0; + foreach my $try_lang(@try_langs) { + for (my $w=1; $w<=7; $w++) { + my $n = UnicodeTools::filter_out_accents(wday_name($w,$try_lang)); + if ($name =~ m/^$n/i || $n =~ m/^$name/i) {push @matches,$w; ++$n_matches;} + } + if ($n_matches==1) { return {'match'=>$matches[0]}} + if ($n_matches>1) { return {'err'=>'not_unique_w_match'} } # ambiguous + } + return {'err'=>'no_w_match'}; +} + +sub clone { + my $self = shift; + return When->new($self->array); +} + +sub array { + my $self = shift; + return ($self->y,$self->m,$self->d,$self->t); +} + +sub y { + my $self = shift; + if (@_) {$self->{Y} = shift} + return $self->{Y}; +} + +sub m { + my $self = shift; + if (@_) {$self->{M} = shift} + return $self->{M}; +} + +sub d { + my $self = shift; + if (@_) {$self->{D} = shift} + return $self->{D}; +} + +sub t { + my $self = shift; + if (@_) {$self->{T} = shift} + return $self->{T}; +} + +sub hour { + my $self = shift; + my $t = $self->t; + $t =~ m/^\d+/; + return $1; +} + +# returns null string if not set +sub min { + my $self = shift; + my $t = $self->t; + if ($t =~ m/\d+\:(\d_)/) { + return $1; + } + else { + return ''; + } +} + +sub min_no_null { + my $self = shift; + my $m = $self->min; + if ($m eq '') {$m=0} + return $m; +} + +sub current_date { + my @tm = localtime; + my $y = $tm[5]; + my $m = $tm[4]+1; + my $d = $tm[3]; + if ($y<1900) {$y=$y+1900} # works in Perl 5 and 6 + return When->new($y,$m,$d); +} + + +sub string_sortable { + my $self = shift; + return sprintf "%04d-%02d-%02d %02d:%02d", $self->y,$self->m,$self->d,$self->hour,$self->min_no_null; +} + +# y,m,d = numbers, m=1..12; t is h or h:m, on 24-hour time +sub string_human { + my $when = shift; + my ($y,$m,$d,$t) = $when->array; + if ($use_month_names) {$m=month_name($m)} + if (length($d)==1) {$d=" $d"} + my $result = $y.$date_delimiter.$m.$date_delimiter.$d; + if ($t ne '') {$result = $result . ' '.time_string_human($t)} + return $result; +} + +sub time_string_human { + my $self = shift; + my ($h,$m) = ($self->hour,$self->min); + my $suffix = ''; + if ($preferences{ampm}) { + if ($h>12) { + $h=$h-12; + $suffix = 'pm' + } + else { + $suffix = 'am'; + } + } + if ($m ne '') { + return sprintf '%d:%02d%s',$h,$m,$suffix; + } + else { + return sprintf '%d%s',$h,$suffix; + } +} + +sub month_name { + my $m = shift; + return month_name_short_or_long($m,'short',@_); +} + +sub month_name_long { + my $m = shift; + return month_name_short_or_long($m,'long',@_); +} + +sub month_name_short_or_long { + my $m = shift; + my $short_or_long = shift; + my $list_of_names; + if ($short_or_long eq 'short') { + $list_of_names = \%month_name; + } + if ($short_or_long eq 'long') { + $list_of_names = \%month_name_long; + } + if (! ref $list_of_names) {return ''} + my $language = $preferences{'language'}; + if (@_) {$language = shift} + if ($m<1 || $m>12) {return ''} + my $names; + if (exists $list_of_names->{$language}) { + $names = $list_of_names->{$language} + } + else { + $names = $list_of_names->{'en'}; + } + my @names = split / /,$names; + return $names[$m-1]; +} + +sub wday_name { + my $d = shift; + my $lang; + if (@_) { + $lang = shift; + } + else { + $lang = $preferences{'language'}; + } + if (!exists $wday_name{$lang}) {$lang='en'} + my $names = $wday_name{$lang}; + if ($d<1 || $d>7) {return ''} + my @names = split / /,$names; + my $offset = $preferences{'monday_first'} ? 1 : 0; + # FIXME -- shouldn't really be referring to this global + return $names[($d-1+$offset)%7]; +} + +sub short_wday_name { + my $d = shift; + if ($d<1 || $d>7) {return ''} + wday_name($d) =~ m/^(.)/; # extract first character + return $1; +} + +sub compare { + my $a = shift; + my $b = shift; + if ($a->y != $b->y) {return $a->y <=> $b->y} + if ($a->m != $b->m) {return $a->m <=> $b->m} + return $a->d <=> $b->d; +} + +sub increment_day_in_place { + my $self = shift; + $self->d($self->d+1); + if ($self->d <= $self->days_in_month()) {return} + $self->m($self->m+1); + $self->d(1); + if ($self->m <= 12) {return} + $self->y($self->y+1); + $self->m(1); +} + +sub add_delta_days_in_place { + my $self = shift; + my $d = shift; + $self->d($self->d+$d); + while ($self->d > $self->days_in_month()) { + $self->d($self->d - $self->days_in_month()); + $self->m($self->m+1); + if ($self->m > 12) { + $self->m(1); + $self->y($self->y+1); + } + } + while ($self->d < 1) { + $self->m($self->m-1); + if ($self->m < 1) { + $self->m(12); + $self->y($self->y-1); + } + $self->d($self->d + $self->days_in_month()); + } +} + +sub increment_month_in_place { + my $self = shift; + $self->m($self->m+1); + if ($self->m > 12) { + $self->y($self->y+1); + $self->m(1); + } + while ($self->d > $self->days_in_month()) { + $self->d($self->d-1) + } +} + +sub decrement_month_in_place { + my $self = shift; + $self->m($self->m-1); + if ($self->m < 1) { + $self->y($self->y-1); + $self->m(12); + } + while ($self->d > $self->days_in_month()) { + $self->d($self->d-1) + } +} + +sub modified_julian_day { + my $self = shift; + return $self->delta_days(When->new(2003,2,14))+52685; +} + +sub day_of_year { + my $self = shift; + return $self->delta_days(When->new($self->y,1,1))+1; +} + +sub week_a { + my $self = shift; + return int((($self->d)-1)/7)+1; +} + +sub week_b { + my $self = shift; + return int(($self->days_in_month()-($self->d))/7)+1; +} + +sub adjacent_weekend_day { + my $self = shift; + my $w = $self->day_of_week(); + if ($w==2) {return ($self->d)-1} + if ($w==6) {return ($self->d)+1} + return -1; +} + +sub delta_days { + my $a = shift; + my $b = shift; + my $compared = $a->compare($b); + if ($compared == 0) {return 0} + if ($compared == -1) {return -($b->delta_days($a))} + if ($a->d != 1 || $b->d !=1) { + my $aa = $a->clone; + my $bb = $b->clone; + $aa->{D} = 1; + $bb->{D} = 1; + return ($aa->delta_days($bb))+($a->d)-($b->d); + } + if ($a->m != 1 || $b->m !=1) { + my $aa = $a->clone; + my $bb = $b->clone; + my $correction = 0; + while ($aa->m > 1) { + $aa->m($aa->m-1); + $correction = $correction + $aa->days_in_month; + } + while ($bb->m > 1) { + $bb->m($bb->m-1); + $correction = $correction - $bb->days_in_month; + } + return ($aa->delta_days($bb))+$correction; + } + # From Jan 1 of one year to Jan 1 of another; $a is after $b + my $aa = $a->clone; + my $result = 0; + while ($aa->y > $b->y) { + $aa->y($aa->y-1); + if ($aa->is_leap_year) { + $result = $result+366; + } + else { + $result = $result+365; + } + } + return $result; +} + +sub days_in_month { + my $self = shift; + if ($self->m != 2) {return $month_length[($self->m)-1]} + if ($self->y eq '*' || $self->is_leap_year) { # I use this routine for error checking; * feb 29 is OK. + return 29; + } + else { + return 28; + } +} + +sub is_leap_year { + my $self = shift; + my $y = $self->y; + if ($y%4!=0) {return 0} + if ($y%100!=0) {return 1} + if ($y%400!=0) {return 0} + return 1; +} + +# Sun=1, ... Sat=7 +sub day_of_week { + my $self =shift; + my $offset = $preferences{'monday_first'} ? -1 : 0; # FIXME -- shouldn't really be referring to this global + return (($self->delta_days(When->new(2003,2,2))+$offset)%7)+1; # Compare against Feb. 2, 2003, which we know was a Sunday. +} + +sub day_of_week_name { + my $self =shift; + return wday_name($self->day_of_week); +} + +#---------------------------------------------------------------- +# ANSI terminal styling +#---------------------------------------------------------------- + +package AnsiTerminalStyling; + +sub style_text { + my $x = shift; + my $style = lc(shift); + my $are_you_sure = shift; + if (!$are_you_sure) {return $x} + my ($before,$after) = ('',''); + while ($style =~ m/([a-z]+)/g) { + my $this_style = $1; + if (exists $ansi_terminal_styling{$this_style}) { + my $code=$ansi_terminal_styling{$this_style}; + $before = "$before\e[${code}m"; + } + } + if ($before ne '') {$after="\e[0m"} + return "$before$x$after"; +} + +sub length { + my $x = shift; + if (!($x =~ m/\e/)) {return length $x} + $x =~ s/\e\[\d+m//g; + return length $x; +} + +sub pad_to_desired_length { + my $x = shift; + my $desired_length = shift; + my $pad_with = shift; + my $current_length = AnsiTerminalStyling::length($x); + if ($current_length>=$desired_length) {return $x} + return $x . ($pad_with x ($desired_length-$current_length)); +} + +#---------------------------------------------------------------- +# Unicode helper routines: +#---------------------------------------------------------------- + +package UnicodeTools; + +# Note that this may turn a single unicode character into two characters, e.g., with Danish o_slash going to 'oe'. +# It doesn't just do what it says, it basically transliterates everything into ascii, e.g., Greek +# lambda becomes l. +# This gets tested by "when --test_accent_filtering", which is done by "make test". +# Doesn't do anything to Cyrillic. +sub filter_out_accents { + my $x = shift; + + + # First do everything that translates into a single character: + + my @t = ( + ["\x{c2}",'A'],["\x{c4}",'A'],["\x{ce}",'I'],["\x{d6}",'O'],["\x{da}",'U'], + ["\x{dc}",'U'],["\x{df}",'s'],["\x{e0}",'a'],["\x{e1}",'a'],["\x{e2}",'a'], + ["\x{e4}",'a'],["\x{e3}",'a'],["\x{e7}",'c'], + ["\x{e9}",'e'],["\x{ea}",'e'],["\x{ed}",'i'],["\x{ee}",'i'],["\x{f1}",'n'], + ["\x{f3}",'o'],["\x{f5}",'e'],["\x{f6}",'o'],["\x{fa}",'u'],["\x{fb}",'u'],["\x{fc}",'u'], + ["\x{fd}",'y'],["\x{2011}",'-'],["\x{105}",'a'],["\x{103}",'a'],["\x{102}",'A'], + ["\x{107}",'c'],["\x{10d}",'c'],["\x{10c}",'C'],["\x{11b}",'e'],["\x{119}",'e'], + ["\x{142}",'l'],["\x{144}",'n'],["\x{159}",'r'],["\x{158}",'r'],["\x{15b}",'s'], + ["\x{219}",'s'],["\x{218}",'S'],["\x{21b}",'t'],["\x{21a}",'T'],["\x{17a}",'z'], + ["\x{391}",'A'],["\x{3b1}",'a'],["\x{3ac}",'a'],["\x{392}",'B'],["\x{3b2}",'b'], + ["\x{393}",'g'],["\x{3b3}",'g'],["\x{394}",'D'],["\x{3b4}",'d'],["\x{395}",'E'], + ["\x{3b5}",'e'],["\x{3ad}",'e'],["\x{396}",'Z'],["\x{3b6}",'z'],["\x{397}",'H'], + ["\x{3b7}",'n'],["\x{3ae}",'n'],["\x{399}",'I'],["\x{3b9}",'i'],["\x{3af}",'i'], + ["\x{39a}",'K'],["\x{3ba}",'k'],["\x{39b}",'L'],["\x{3bb}",'l'],["\x{39c}",'M'], + ["\x{3bc}",'m'],["\x{39d}",'N'],["\x{3bd}",'v'],["\x{39f}",'O'],["\x{3bf}",'o'], + ["\x{3cc}",'o'],["\x{3a0}",'P'],["\x{3c0}",'p'],["\x{3a1}",'R'],["\x{3c1}",'r'], + ["\x{3a3}",'S'],["\x{3c3}",'s'],["\x{3c2}",'s'],["\x{3a4}",'T'],["\x{3c4}",'t'], + ["\x{3a5}",'Y'],["\x{3c5}",'u'],["\x{3cd}",'u'],["\x{3a6}",'F'],["\x{3c6}",'f'], + ["\x{3a7}",'X'],["\x{3c7}",'x'],["\x{3a9}",'W'],["\x{3c9}",'w'],["\x{3ce}",'w'] + ); + + my $b = ''; + foreach my $c(split('',$x)) { + foreach my $t(@t) { + if ($c eq $t->[0]) {$c=$t->[1]} + } + $b = $b . $c; + } + $x = $b; + + $x =~ s/\x{201c}/''/go; + $x =~ s/\x{ab}/<>/go; + $x =~ s/\x{c5}/AA/go; + $x =~ s/\x{c6}/AE/go; + $x =~ s/\x{d8}/OE/go; + $x =~ s/\x{e5}/aa/go; + $x =~ s/\x{e6}/ae/go; + $x =~ s/\x{f8}/oe/go; + $x =~ s/\x{201e}/,,/go; + $x =~ s/\x{17c}/zz/go; + $x =~ s/\x{398}/Th/go; + $x =~ s/\x{3b8}/th/go; + $x =~ s/\x{39e}/Ks/go; + $x =~ s/\x{3be}/ks/go; + $x =~ s/\x{3a8}/Ps/go; + $x =~ s/\x{3c8}/ps/go; + return $x; +} + +sub test_accent_filtering { + my @strings = @_; + my $result = ''; + foreach my $x(@strings) { + chomp $x; + my $y = filter_out_accents($x); + while ($y=~/(\P{IsASCII})/g) { + my $c = $1; + if (is_cyrillic($c)) {next} + my $describe_c = sprintf("%04x", ord($c)); + $result = $result . "In the string '$x', the character $1, character code 0x$describe_c, was not properly filtered by UnicodeTools::filter_out_accents().\n"; + } + } + return $result; +} + +sub is_cyrillic { + # tests a single character + my $x = shift; + if ($x=~/[АаБбВвГгДдЕеЁёЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяієћњјљї]/) {return 1} else {return 0} + # list from https://codegolf.stackexchange.com/questions/127677/print-the-russian-cyrillic-alphabet , plus a few more in strings people submitted +} + +sub make_filter_regex { + my $filter = filter(); + my @a = sort keys %$filter; + + my $from = ''; + my $to = ''; + my $doubles = ''; + foreach my $a(@a) { + my $b = $filter->{$a}; + my $hex = sprintf('%x',ord($a)); + if ($a eq $b) {print "Warning, $a and $b are the same, in make_filter_regex.\n"} + if (length($b)==1) { + $from = $from . "\\x{$hex}"; + $to = $to . $b; + } + else { + $doubles = $doubles . " \$x =~ s/\\x{$hex}/$b/go;\n"; + } + } + return " \$x =~ tr/$from/$to/;\n # ... everything that translates into a single character\n$doubles"; +} + +BEGIN { + my $filter; + sub filter { + return $filter if $filter; + my %filter = ( + $e_acute=>'e',$A_uml=>'A',$a_uml=>'a',$O_uml=>'O',$o_uml=>'o',$U_uml=>'U',$u_uml=>'u',$s_zlig=>'s',$u_circumflex=>'u', + $a_polish=>'a',$c_polish=>'c',$e_polish=>'e',$l_polish=>'l',$n_polish=>'n',$o_polish=>'o',$s_polish=>'s',$z_polish=>'z',$zz_polish=>'zz', + $a_acute=>'a',$i_acute=>'i',$u_acute=>'u',$U_acute=>'U',$y_acute=>'y',$C_wedge=>'C',$c_wedge=>'c',$e_wedge=>'e',$R_wedge=>'r',$r_wedge=>'r', + $a_ring=>'aa',$A_ring=>'AA',$o_slash=>'oe',$O_slash=>'OE',$ae=>'ae',$AE=>'AE',$n_tilde=>'n', + # Greek. Note that some letters that look like latin really aren't. + 'Α'=>'A','α'=>'a','ά'=>'a','Β'=>'B','β'=>'b','Γ'=>'g','γ'=>'g','Δ'=>'D','δ'=>'d','Ε'=>'E','ε'=>'e','έ'=>'e', + 'Ζ'=>'Z','ζ'=>'z', + 'Η'=>'H','η'=>'n','ή'=>'n','Θ'=>'Th','θ'=>'th', + 'Ι'=>'I','ι'=>'i','ί'=>'i','Κ'=>'K','κ'=>'k','Λ'=>'L','λ'=>'l','Μ'=>'M','μ'=>'m','Ν'=>'N','ν'=>'v', + 'Ξ'=>'Ks','ξ'=>'ks','Ο'=>'O','ο'=>'o','ό'=>'o', + 'Π'=>'P','π'=>'p','Ρ'=>'R','ρ'=>'r','Σ'=>'S','σ'=>'s','ς'=>'s','Τ'=>'T','τ'=>'t','Υ'=>'Y','υ'=>'u','ύ'=>'u', + 'Φ'=>'F','φ'=>'f','Χ'=>'X','χ'=>'x', + 'Ψ'=>'Ps','ψ'=>'ps','Ω'=>'W','ω'=>'w','ώ'=>'w', + # Romanian + $A_breve=>'A',$A_circumflex=>'A',$I_circumflex=>'I',$S_commabelow=>'S',$T_commabelow=>'T', + $a_breve=>'a',$a_circumflex=>'a',$i_circumflex=>'i',$s_commabelow=>'s',$t_commabelow=>'t', + $nonbreaking_hyphen=>'-',$quot_open=>',,',$quot_close=>"''",$quotalt_open=>'<<',$quotalt_close=>'>>' + ); + $filter = \%filter; + return $filter; + } +} + +sub file_is_valid_utf8 { + my $f = shift; + open(F,"<:raw",$f) or return 0; + local $/; + my $x=; + close F; + return is_valid_utf8($x); +} + +# What's passed to this routine has to be a stream of bytes, not a utf8 string in which the characters are complete utf8 characters. +# That's why you typically want to call file_is_valid_utf8 rather than calling this directly. +sub is_valid_utf8 { + my $x = shift; + return utf8::decode(my $dummy = $x); +} + +#----------------------------------------- +# Easter +#----------------------------------------- + +package Easter; + +sub easter { + my $year = shift; + my $sub = $preferences{'orthodox_easter'} ? \&eastern_easter : \&western_easter; + return &$sub($year); +} + +# The following code for Easter is based on Rick Measham's DateTime::Event::Easter module, +# http://search.cpan.org/dist/DateTime-Event-Easter/lib/DateTime/Event/Easter.pm , +# which is available under the same license as Perl itself, and therefore compatible with +# the licensing scheme of When. +# For testing, see: http://en.wikipedia.org/wiki/Easter#Date_of_Easter + +sub western_easter { + my $year = shift; + my $golden_number = $year % 19; + my $quasicentury = int($year / 100); + my $epact = ($quasicentury - int($quasicentury/4) - int(($quasicentury * 8 + 13)/25) + ($golden_number*19) + 15) % 30; + my $interval = $epact - int($epact/28)*(1 - int(29/($epact+1)) * int((21 - $golden_number)/11) ); + my $weekday = ($year + int($year/4) + $interval + 2 - $quasicentury + int($quasicentury/4)) % 7; + my $offset = $interval - $weekday; + my $month = 3 + int(($offset+40)/44); + my $day = $offset + 28 - 31* int($month/4); + return When->new($year,$month,$day); +} + +# The following algorithm for Eastern Orthodox Easter is from George Vlahavas: +# If you put this in a +# spreadsheet cell (gnumeric or openoffice calc will do): +# =MOD(19*MOD(A1;19)+16;30)+MOD(2*MOD(A1;4)+4*MOD(A1;7)+6*MOD(19*MOD(A1;19)+16;30);7)+3 +# and you put the year in cell A1 you will get a number. If this number +# is <=30 then that's the April day that Easter is for that year. If the +# number is >30 then you need to subtract 30 from it and you will find +# the day in May Easter is. + +sub eastern_easter { + my $year = shift; + my $day= + (19*($year%19)+16)%30 + +( + 2*($year%4) + +4*($year%7) + +6*( + ( + 19*($year%19)+16 + )%30 + ) + )%7 + +3; + my $month; + if ($day<=30) {$month=4} else {$month=5; $day=$day-30} + return When->new($year,$month,$day); +} + +#----------------------------------------- +# Terminal +#----------------------------------------- + +package Terminal; + +# Normally returns the number of columns on the output tty. +# Return 0 if output isn't a tty. +# Returns undef if it's unable to find the width. +# Tries several methods, in an attempt to work on any platform, while being as +# efficient as possible in most cases, and avoiding dependencies. This does *not* +# introduce any dependencies on Term::ReadKey or Term::ReadLine unless you're +# using a non-POSIX system; those are used only as last-ditch backup methods in +# case, e.g., we're running Windows. +sub columns { + return (get_data())[1]; +} + +sub rows { + return (get_data())[0]; +} + +BEGIN { +my ($rows,$columns); +my $initialized = 0; + +sub get_data { + initialize_data() unless $initialized; + return ($rows,$columns); +} + +sub initialize_data { + $initialized = 1; + ($rows,$columns) = get_data_for_initialization(); + $SIG{WINCH} = sub{$initialized=0}; # If the window gets resized, we get this signal. +} + +# Return the number of rows and columns on the terminal. +sub get_data_for_initialization { + + return (0,0) unless -t STDOUT; + + my ($r, $c, $dummy); + + # The following works on linux, but seems to fail on freebsd. + # It works properly if the user resizes the terminal window while the program is running. + # No longer works in perl 5.10, so disabled with "0 &&". + # http://search.cpan.org/src/RGARCIA/perl-5.10.0/h2pl/README + if (0 && eval "require 'sys/ioctl.ph'") { + eval { + # All of the dies on the next few lines will be caught by the eval{}. + die unless defined &TIOCGWINSZ; + open(TTY, "+