urxvt-font/font

#!/usr/bin/env perl

use strict;
use warnings;
use List::Util qw(first);

# On-the-fly urxvt font resizing.  Like ⌘{+,-}, on mac computers, just
# way more complicated.
#
# Noah K. Tilton <noahktilton@gmail.com>
#
# What it does:
#
# 1) Emits escape sequences to change the font size in the running console;
# 2) Persists the changed font size to xresources file.
#
# Note: For the time being, the Monaco font is treated as a special
# case, due to Unicode compatibility issues.  Other fonts may need
# special treatment, but I'm not using them.  In particular, Monaco only
# supports unicode in certain pixel sizes.  9, 10, 12, 14 are embedded
# bitmaps, which means (Except for 10) that they lack certain unicode
# charmaps.
#
# Note: the regexes will only work on xft xrdb entries

#   For this script to work, ~/.Xdefauls should probably contain at
#   least the following:
#
#       urxvt*font
#       urxvt*boldFont
#       urxvt*boldColors: on
#
# References: man 3 urxvtperl
#
#  Debugging:   urxvt --perl-lib ${HOME}/.urxvt -pe font


use constant X_RESOURCES => "~/.config/xresources/fonts";


sub _resize_xft_string
{
  my ($self, $key, $delta)      = @_;
  my (@pieces)                  = split /:/, $self->{term}->resource($key);
  my (@resized)                 = ();
  my ($monaco)                  = undef;

  foreach my $piece (@pieces)
  {
    # Assumption: xft:fontname comes before pixelsize=whatever
    $monaco ||= $piece =~ /Monaco/;

    # matching string
    if ($piece =~ /pixelsize=(\d*)/)
    {
      my ($old_size)    =  $1;
      my ($new_size)    =  $old_size;

      # monaco font
      if ($monaco)
      {
        my (@monaco_unicode_sizes)    = (8, 9, 10, 11, 13, 15, 16, 18, 21, 22, 28);
        my ($monaco_default_size)     = &{ sub {  my @a = sort { $a <=> $b } @_;
                                                  return ($a[$#a/2] + $a[@a/2]) / 2;}
                                         }(@monaco_unicode_sizes); # median ...
        my ($old_size_index) = first {
          $monaco_unicode_sizes[$_] eq $old_size } 0..$#monaco_unicode_sizes;

        # old font size is valid
        if (defined($old_size_index))
        {
          # Do bounds checking:
          #
          # 1) avoid decrement of smallest font size index to a negative
          # value --which would undesirably wrap around and set font to
          # larger size
          if ($old_size_index > 0 || $delta > 0)
          {
            my ($new_size_index)  = $old_size_index + $delta; # +1, equivalently
            # 2) avoid increment of largest to non-existent larger
            $new_size             = exists($monaco_unicode_sizes[$new_size_index])
                                            ? $monaco_unicode_sizes[$new_size_index]
                                            : $old_size;
          }
        }
        else
        {
          # user had an invalid/non-unicode monaco size, reset to default
          $new_size  = $monaco_default_size;
        }
      }
      else
      {
        $new_size += $delta;
      }
      $piece =~ s/pixelsize=$old_size/pixelsize=$new_size/;
    }
    push @resized, $piece;
  }
  return join (":", @resized);
}

sub change_size
{
  my ($self, $delta) = @_;

  # Get xft strings with font size {+/-}1
  my ($font_resized)        = $self->_resize_xft_string(     "font", $delta);
  my ($font_resized_bold)   = $self->_resize_xft_string( "boldFont", $delta);

  # Update internal urxvt resource hash
  #     This is necessary or else the next resize won't have an updated
  #     value. "font" key is updated by urxvt when cmd_parse is called,
  #     but boldFont is *not*, at least with the escape sequences I'm
  #     emitting.
  $self->{term}->resource("font",       $font_resized);
  $self->{term}->resource("boldFont",   $font_resized_bold);

  # Emit escape sequence to change fonts in rxvt runtime
  $self->{term}->cmd_parse("\e]710;" . $font_resized . "\007");

  # Persist the changes to xrdb
  system("xrdb -load " . X_RESOURCES);
  open(XRDB_MERGE, "| xrdb -merge") || die "can't fork: $!";
  local $SIG{PIPE} = sub { die "xrdb pipe broke" };
  print XRDB_MERGE "urxvt\*font:        $font_resized\n"
                 . "urxvt\*boldFont:    $font_resized_bold\n";
  close XRDB_MERGE || die "bad xrdb: $! $?";
  system("xrdb -edit " . X_RESOURCES);
}

sub on_user_command
{
  # This function is called whenever some urxvt.keysym.*: perl:x:y
  # mapped in X_RESOURCES is called; where x is this "module" (file,
  # translation unit...), y is some function in this file (and this
  # function, if defined), and $cmd is the argument z.
  #
  my ($self, $cmd) = @_;

  if ($cmd =~ /font:(..crement)/)   # {in, de, ex}
  {
    $self->change_size(($1 eq "increment") ? +1 : -1);
  }
}