#!/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, "+