user-tools/hlcal

   1 #!/usr/bin/env perl
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 hlcal - Highlight BSD cal(1) output
   8
   9 hlncal - Highlight BSD ncal(1) output
  10
  11 =head1 SYNOPSIS
  12
  13 hlcal [OPTIONS] [CAL-OPTIONS]
  14
  15 hlncal [OPTIONS] [NCAL-OPTIONS]
  16
  17 =head1 DESCRIPTION
  18
  19 Wrap cal(1), ncal(1) around and highlight specific days.
  20
  21 =head1 OPTIONS
  22
  23 =over 4
  24
  25 =item I<DOW>=I<COLOR>
  26
  27 =item I<DATE>=I<COLOR>
  28
  29 =item I<START-DATE>...I<END-DATE>[,I<DOW>[,I<DOW>[,...]]]=I<COLOR>
  30
  31 =back
  32
  33 Where I<DOW> is a day-of-week name (3 letters),
  34 I<COLOR> is a space- or hyphen-delimited list of ANSI color or other
  35 formatting style name,
  36 I<DATE> (and I<START-DATE>, I<END-DATE>) is in I<[[YYYY-]MM-]DD> format,
  37 ie. year and month are optional,
  38 and lack of them interpreted as "every year" and "every month"
  39 respectively.
  40
  41 In single date definition, I<DATE>, may enter an asterisk C<*> as month
  42 to select a given date in every month in the given year, or in every
  43 year if you leave out the year as well.
  44 Example: C<1917-*-15>
  45
  46 In the interval definition, may add several I<DOW> days which makes only
  47 those days highlighted in the specified interval.
  48 Examples:
  49 C<04-01...06-30,WED> means every Wednesday in the second quarter.
  50 C<1...7,FRI> means the first Friday in every month.
  51
  52 =head1 SUPPORTED ANSI COLORS AND STYLES
  53
  54 Colors: black, red, green, yellow, blue, magenta, cyan, white, default.
  55
  56 May be preceded by C<bright>, eg: C<bright red>.
  57 May be followed by C<bg> to set the background color instead of the
  58 foreground, eg: C<yellow-bg>.
  59
  60 Styles: bold, faint, italic, underline,
  61 blink_slow, blink_rapid, inverse, conceal, crossed,
  62
  63 Note, not all styles are supported by all terminal emulators.
  64
  65 =head1 EXAMPLE
  66
  67   hlncal today=inverse `ncal -e`=yellow_bg-red SUN=bright-red SAT=red -bM3
  68
  69 =cut
  70
  71
  72 use Data::Dumper;
  73 use Getopt::Long qw/:config no_ignore_case bundling no_getopt_compat pass_through/;
  74 use feature qw/switch/;
  75 no if ($] >= 5.018), 'warnings' => 'experimental::smartmatch';
  76 use Pod::Usage;
  77 use Carp qw/croak/;
  78 use List::MoreUtils qw/all any none/;
  79
  80 use POSIX qw/strftime setlocale LC_TIME/;
  81 use DateTime;
  82 use DateTime::Duration;
  83 use DateTime::Format::Strptime;
  84 use DateTime::Locale;
  85 use locale;
  86
  87
  88 # take the basename of the command as procname.
  89 $0 =~ s/.*\/([^\/]+)$/$1/;
  90
  91 use constant {
  92         VERTICAL => 'v',
  93         HORIZONTAL => 'h',
  94 };
  95
  96 use constant {
  97         MON => 0,
  98         TUE => 1,
  99         WED => 2,
 100         THU => 3,
 101         FRI => 4,
 102         SAT => 5,
 103         SUN => 6,
 104 };
 105
 106 my %Months = (
 107         jan=>1,
 108         feb=>2,
 109         mar=>3,
 110         apr=>4,
 111         may=>5,
 112         jun=>6,
 113         jul=>7,
 114         aug=>8,
 115         sep=>9,
 116         'oct'=>10,
 117         nov=>11,
 118         dec=>12,
 119 );
 120 my $re_months = join '|', keys %Months;
 121 my $re_mon = qq/(0?[1-9]|1[012]|$re_months)/;
 122 my $re_dom = q/(0[1-9]|[12]\d|3[01])/;
 123 my $re_dow = 'MON|TUE|WED|THU|FRI|SAT|SUN';
 124
 125
 126 my %ANSIcolor = (
 127         black=>30, red=>31, green=>32, yellow=>33, blue=>34, magenta=>35, cyan=>36, white=>37,
 128 );
 129 my %ANSIcode = (
 130         'reset'=>0, bold=>1, faint=>2, italic=>3, underline=>4,
 131         blink_slow=>5, blink_rapid=>6, inverse=>7, conceal=>8, crossed=>9,
 132         normal=>22,
 133         noitalic=>23, nounderline=>24, noblink=>25, noinverse=>27, noconceal=>28, nocrossed=>29,
 134         %ANSIcolor,
 135         default=>39,
 136 );
 137 sub get_ansi_codes
 138 {
 139         my $str = shift;
 140         my @codes = ();
 141         $str =~ s/[- ]bg/_bg/g;
 142         $str =~ s/bright[- ]/bright_/g;
 143         for my $word (split /[\s-]+/, $str)
 144         {
 145                 my $code = 0;
 146                 if($word =~ /^(?'BRIGHT'bright_|)(?'COLOR'.+?)(?'BG'_bg|)$/ and any {$_ eq $+{'COLOR'}} (keys %ANSIcolor))
 147                 {
 148                         $code += 10 if $+{'BG'};
 149                         $code += 60 if $+{'BRIGHT'};
 150                         $word = $+{'COLOR'};
 151                 }
 152                 if(exists $ANSIcode{$word}) { $code += $ANSIcode{$word}; }
 153                 else { $code = ''; }
 154                 push @codes, $code;
 155         }
 156         return @codes;
 157 }
 158 sub ansicode
 159 {
 160         my @codes = grep {length} get_ansi_codes join " ", @_;
 161         return '' if not @codes;
 162         return sprintf "\x1B[%sm", join(';', @codes);
 163         #return join '', map { sprintf "\x1B[%sm", $_ } @codes;
 164 }
 165
 166 sub verify_color
 167 {
 168         my $color = shift;
 169         warn "$0: no ANSI code: $color\n" unless all {length} get_ansi_codes $color;
 170 }
 171
 172
 173 $OptNoHighlightToday = 0;
 174 # weeks starts on Sunday by default in cal
 175 $week_start_on = SUN;
 176 $week_start_day_explicite = 0;
 177 $calcmd = 'cal';
 178 $calcmd = 'ncal' if $0 =~ /ncal/;
 179
 180
 181 while(@ARGV)
 182 {
 183         my $arg = shift @ARGV;
 184
 185         # TODO: get highlight parameters from config files
 186         # TODO: mix dow/date/interval definitions under @Highlight list
 187
 188         $arg =~ s{(today|yesterday|tomorrow)(?=.*=)}{
 189                 my $date = $1;
 190                 $date = DateTime->now(time_zone=>'local')->strftime('%F') if $date eq 'today';
 191                 $date = DateTime->now(time_zone=>'local')->subtract(days=>1)->strftime('%F') if $date eq 'yesterday';
 192                 $date = DateTime->now(time_zone=>'local')->add(days=>1)->strftime('%F') if $date eq 'tomorrow';
 193                 $date
 194         }ige;
 195
 196         if(my ($day, $color) = $arg =~ /^($re_dow)=(.+)$/i)
 197         {
 198                 $Highlight->{'days-of-week'}->{eval $day} = $color;
 199                 verify_color $color;
 200         }
 201         elsif($arg =~ /^(((?'YEAR'\d\d\d\d)-|)(?'MON'$re_mon|\*)-|)(?'DOM'$re_dom)=(?'COLOR'.+)$/i)
 202         {
 203                 my $year = $+{'YEAR'} || '*';
 204                 my $mon = $+{'MON'} || '*';
 205                 my $dom = $+{'DOM'};
 206                 my $color = $+{'COLOR'};
 207                 $mon =~ s/^0//;
 208                 $dom =~ s/^0//;
 209                 $mon = $Months{$mon} if exists $Months{$mon};
 210                 $Highlight->{'date'}->{$year}->{$mon}->{$dom} = $color;
 211                 verify_color $color;
 212         }
 213         elsif($arg =~ /^(((?'Y1'\d\d\d\d)-|)((?'M1'$re_mon)-)|)(?'D1'$re_dom)\.\.\.(?('M1')(?('Y1')((?'Y2'\d\d\d\d)-|))((?'M2'$re_mon)-|))(?'D2'$re_dom)(?'DOW'(,($re_dow))*)=(?'COLOR'.+)$/i)
 214         {
 215                 push @{$Highlight->{'interval'}}, {
 216                         'start' => {'y'=>$+{'Y1'}, 'm'=>$Months{lc$+{'M1'}}||$+{'M1'}, 'd'=>$+{'D1'}},
 217                         'end'   => {'y'=>$+{'Y2'}, 'm'=>$Months{lc$+{'M2'}}||$+{'M2'}, 'd'=>$+{'D2'}},
 218                         'dow'   => [map {eval} grep {$_} split /,/, $+{'DOW'}],
 219                         'color' => $+{'COLOR'},
 220                 };
 221                 verify_color $+{'COLOR'};
 222         }
 223         elsif($arg =~ /=/)
 224         {
 225                 pod2usage(-exitval=>2, -verbose=>99);
 226         }
 227         else
 228         {
 229                 # unknown parameter.
 230                 # give it back to cal/ncal.
 231                 unshift @ARGV, $arg;
 232                 last;
 233         }
 234 }
 235
 236 #warn Dumper $Highlight;  # DEBUG
 237
 238
 239 @cal_args = @ARGV;
 240
 241 GetOptions(
 242         'M' => sub { $week_start_on = MON; $week_start_day_explicite = 1; },
 243         'S' => sub { $week_start_on = SUN; $week_start_day_explicite = 1; },
 244         'C' => sub { $calcmd = 'cal'; },
 245         'N' => sub { $calcmd = 'ncal'; },
 246         'b' => sub { $layout = HORIZONTAL; },
 247         'h' => \$OptNoHighlightToday,  # TODO
 248         'help|?' => sub {
 249                 pod2usage(-exitval=>'NOEXIT', -verbose=>99);
 250                 system("sh", "-c", "cal --help 2>&1");
 251                 exit 0;
 252         },
 253 ) or pod2usage(-exitval=>2, -verbose=>99);
 254
 255
 256 if(not defined $layout)
 257 {
 258         $layout = HORIZONTAL;
 259         $layout = VERTICAL if $calcmd eq 'ncal';
 260 }
 261
 262 if(!$week_start_day_explicite and $calcmd eq 'ncal')
 263 {
 264         # ncal takes locale settings for the week's first day
 265         ($first_weekday) = `locale -k first_weekday` =~ /=(\d+)/;
 266         if(defined $first_weekday)
 267         {
 268                 $week_start_on = ($first_weekday+5) % 7;
 269         }
 270 }
 271
 272
 273
 274 my $month_parser = new DateTime::Format::Strptime(pattern=>'%Y %b', on_error=>'croak', locale=>setlocale(LC_TIME));
 275
 276
 277
 278 # if this bsdcal version supports -h flag,
 279 if(system("$calcmd -h >/dev/null 2>&1") == 0)
 280 {
 281         # prevent cal to highlight today. we will do it.
 282         unshift @cal_args, "-h";
 283 }
 284
 285 open my $pipe, '-|:utf8', $calcmd, @cal_args or croak "$0: popen: $calcmd: $!";
 286 binmode STDOUT, ':utf8';
 287
 288 $title_passed = 0;
 289
 290 while(<$pipe>)
 291 {
 292         my $is_week_row = 0;
 293
 294         if(/(\d\d\d\d)/)
 295         {
 296                 $year = $1;
 297         }
 298
 299         my @words = /([^\d\s]+)/g;
 300         if(scalar @words >= 1 and scalar @words <= 3 and (not /\d/ or /\d\d\d\d/))
 301         {
 302                 # seems to be 1, 2, or 3 month names
 303                 @month_column = ();
 304                 for my $word (@words)
 305                 {
 306                         push @month_column, int $month_parser->parse_datetime("$year $word")->strftime('%m');
 307                 }
 308         }
 309
 310         my @years = /(\d\d\d\d)/g;
 311         if(@years)
 312         {
 313                 @year_column = @years;
 314         }
 315
 316         if(/([^\d\s]+\s+){7}/)
 317         {
 318                 # at least 7 groups of letters (not space or digit),
 319                 # it's probably day of week names;
 320                 # assuming horizontal layout.
 321
 322                 # TODO: any locale setting in which month names have space?
 323
 324                 $layout = HORIZONTAL;
 325                 $title_passed = 1;
 326                 $week_of_month = 0;
 327                 $is_week_row = 1;
 328
 329                 %dow_bgn = ();
 330                 %dow_end = ();
 331                 my $day_spacing = 1;
 332                 for my $dow ($week_start_on, MON..SUN)
 333                 {
 334                         my $repeats = ($dow - $week_start_on) % 7 + 1;
 335                         /^(\s*[^\d\s]+){$repeats}/;
 336                         $dow_end{$dow} = length $&;
 337                         $dow_bgn{$dow} = $dow eq $week_start_on ? 0 : $dow_end{($dow-1)%7} + $day_spacing;
 338                 }
 339         }
 340
 341         if(/^\s*$/)
 342         {
 343                 $title_passed = 0;
 344         }
 345
 346         if($layout eq HORIZONTAL)
 347         {
 348                 if(/\d/ and $title_passed)
 349                 {
 350                         # at least 1 number -> a row of a week
 351                         $week_of_month++;
 352                         $is_week_row = 1;
 353                 }
 354
 355                 if($is_week_row)
 356                 {
 357                         my $month_spacing = 2;
 358                         my $where_last_dow_column_ends = $dow_end{($week_start_on-1)%7};
 359                         my $how_many_month_columns = int(length($_) / $where_last_dow_column_ends);
 360                         my $accum_shift = 0;
 361
 362                         for my $month_column (0..$how_many_month_columns-1)
 363                         {
 364                                 my $week_start_offset = $month_column * ($where_last_dow_column_ends + $month_spacing);
 365
 366                                 my %hldow = map {$_=>$Highlight->{'days-of-week'}->{$_}} keys %{$Highlight->{'days-of-week'}};
 367                                 my $cur_year = $year_column[$month_column] || $year;
 368                                 my $cur_month = $month_column[$month_column];
 369
 370                                 for my $dow ( $week_start_on .. SUN, MON .. ($week_start_on-1) )
 371                                 {
 372                                         my $dom = int substr($_, $dow_bgn{$dow} + $week_start_offset + $accum_shift, $dow_end{$dow}-$dow_bgn{$dow});
 373                                         next unless $dom;
 374                                         my $this_date = DateTime->new(year=>$cur_year, month=>$cur_month, day=>$dom, time_zone=>'local');
 375
 376                                         for my $ival (@{$Highlight->{'interval'}})
 377                                         {
 378                                                 next if @{$ival->{'dow'}} and not $dow ~~ @{$ival->{'dow'}};
 379
 380                                                 my $s = $ival->{'start'};
 381                                                 my $e = $ival->{'end'};
 382
 383                                                 my $sy = $s->{'y'}||$cur_year;
 384                                                 my $sm = $s->{'m'}||$cur_month;
 385                                                 my $start = DateTime->new(year=>$sy, month=>$sm, day=>$s->{'d'}, time_zone=>'local');
 386                                                 my $end = DateTime->new(year=>$e->{'y'}||$sy, month=>$e->{'m'}||$sm, day=>$e->{'d'}, time_zone=>'local');
 387
 388                                                 if($end < $start)
 389                                                 {
 390                                                         if   (! $e->{'m'}) { $end->add(months=>1); }
 391                                                         elsif(! $e->{'y'}) { $end->add(years=>1); }
 392                                                 }
 393                                                 if($this_date < $start)
 394                                                 {
 395                                                         if   (! $s->{'m'}) { $_->subtract(months=>1) for $start, $end; }
 396                                                         elsif(! $s->{'y'}) { $_->subtract(years=>1) for $start, $end; }
 397                                                 }
 398
 399                                                 #warn $this_date->ymd, ": ", $start->ymd, "...", $end->ymd, "\n";  # DEBUG
 400
 401                                                 if($this_date >= $start and $this_date <= $end)
 402                                                 {
 403                                                         $hldow{$dow} .= " " . $ival->{'color'};
 404                                                 }
 405                                         }
 406                                 }
 407
 408                                 my %dates = ();
 409                                 $dates{$d} = $c while ($d, $c) = each %{$Highlight->{'date'}->{'*'}->{'*'}};
 410                                 $dates{$d} = $c while ($d, $c) = each %{$Highlight->{'date'}->{'*'}->{$cur_month}};
 411                                 $dates{$d} = $c while ($d, $c) = each %{$Highlight->{'date'}->{$cur_year}->{$cur_month}};
 412                                 for my $date (keys %dates)
 413                                 {
 414                                         my $dow = int strftime('%u', 0, 0, 0, $date, $cur_month-1, $cur_year-1900) - 1;
 415                                         my $date_at_dow_location = substr($_, $dow_bgn{$dow} + $week_start_offset + $accum_shift, $dow_end{$dow}-$dow_bgn{$dow});
 416                                         $hldow{$dow} .= " " . $dates{$date} if $date == $date_at_dow_location;
 417                                 }
 418
 419                                 for my $dow ( $week_start_on .. SUN, MON .. ($week_start_on-1) )
 420                                 {
 421                                         if(exists $hldow{$dow})
 422                                         {
 423                                                 my $color = $hldow{$dow};
 424                                                 my $insert1 = ansicode($color);
 425                                                 my $insert2 = ansicode('reset');
 426                                                 my $bgn = $dow_bgn{$dow} + $week_start_offset + $accum_shift;
 427                                                 my $end = $dow_end{$dow} + $week_start_offset + $accum_shift;
 428
 429                                                 $_ = substr($_, 0, $bgn) . $insert1 . substr($_, $bgn, $end-$bgn) . $insert2 . substr($_, $end);
 430                                                 $accum_shift += length($insert1) + length($insert2);
 431                                         }
 432                                 }
 433
 434                         }
 435                 }
 436         }
 437         else  # $layout eq VERTICAL
 438         {
 439                 if(not /\b\d\d?\b/)
 440                 {
 441                         # no 1 or 2 digit numbers, assuming month name(s) header.
 442                         # TODO: any locale setting in which month names have numbers?
 443
 444                         $day_of_week = $week_start_on - 1;
 445                         $is_date_row = 0;
 446                 }
 447
 448                 if(/(\d+\s+){4}/)
 449                 {
 450                         # at least 4 numbers -> it's a new row of days
 451                         $day_of_week = ($day_of_week + 1) % 7;
 452                         $is_date_row = 1;
 453                 }
 454
 455                 if($is_date_row)
 456                 {
 457                         # TODO: hilight dates
 458
 459                         while (my ($hldow, $color) = each %{$Highlight->{'days-of-week'}})
 460                         {
 461                                 if($day_of_week == $hldow)
 462                                 {
 463                                         s/^/ansicode($color)/e;
 464                                         s/$/ansicode('reset')/e;
 465                                 }
 466                         }
 467                 }
 468         }
 469
 470         print;
 471 }
 472
 473 close $pipe;