diff options
Diffstat (limited to 'when.pl')
| -rw-r--r-- | when.pl | 2013 |
1 files changed, 0 insertions, 2013 deletions
diff --git a/when.pl b/when.pl deleted file mode 100644 index f5197c1..0000000 --- a/when.pl +++ /dev/null @@ -1,2013 +0,0 @@ -#!/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 = <FILE>) { - 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 = <FILE>; # 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 = <STDIN>; - 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 = <STDIN>; - 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{bb}/>>/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=<F>; - 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, "+</dev/tty") or die; - my $winsize; - die unless ioctl(TTY, &TIOCGWINSZ, $winsize=''); - ($r, $c, $dummy, $dummy) = unpack('S4', $winsize); - return ($r,$c); - } - } - - # A less efficient fallback, should work on anything unixy. - chomp(my @lines = `stty -a`); - for (@lines) { - $r = $1 if /rows (\d+);/; # linux - $r = $1 if /(\d+) rows;/; # FreeBSD - $c = $1 if /columns (\d+);/; # linux - $c = $1 if /(\d+) columns;/; # FreeBSD - } - return ($r,$c) if ((defined $c) && (defined $r)); - - # The following two methods give us a fighting chance on a non-POSIX system. I don't use them as the defaults - # because I don't want to introduce dependencies. - - # http://search.cpan.org/~kjalb/TermReadKey/ReadKey.pm - # Term::ReadKey is not a standard Perl module, and may not be installed. If the user resizes the terminal - # while the program is running, this will correctly reflect the resizing. - eval 'use Term::ReadKey; ($c, $r, $dummy, $dummy) = GetTerminalSize();'; - return ($r,$c) if ((defined $c) && (defined $r)); - - # http://search.cpan.org/~nwclark/perl-5.8.8/lib/Term/ReadLine.pm - # Term::ReadLine is a standard Perl module, but exists in different implementations under the hood. On a Linux - # system, it's implemented using Term::ReadLine::Gnu, which supports get_screen_size(). On a default FreeBSD system, - # however, the following won't work; you'd have to install the p5-ReadLine-Gnu package to get support for this function. - eval 'use Term::ReadLine; $term = new Term::ReadLine("foo"); ($r,$c)= Term::ReadLine::get_screen_size();'; - return ($r,$c) if ((defined $c) && (defined $r)); - - return undef; -} -} |