font-size

   1 #!/usr/bin/perl
   2 #
   3 # On-the-fly adjusting of the font size in urxvt
   4 #
   5 # Copyright (c) 2008 David O'Neill
   6 #               2012 Noah K. Tilton <noahktilton@gmail.com>
   7 #               2012 Jan Larres <jan@majutsushi.net>
   8 #
   9 # Permission is hereby granted, free of charge, to any person obtaining a copy
  10 # of this software and associated documentation files (the "Software"), to
  11 # deal in the Software without restriction, including without limitation the
  12 # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  13 # sell copies of the Software, and to permit persons to whom the Software is
  14 # furnished to do so, subject to the following conditions:
  15 #
  16 # The above copyright notice and this permission notice shall be included in
  17 # all copies or substantial portions of the Software.
  18 #
  19 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  20 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  21 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  22 # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  23 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  24 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
  25 # IN THE SOFTWARE.
  26 #
  27 # URL: https://github.com/majutsushi/urxvt-font-size
  28 #
  29 # Based on:
  30 # https://github.com/dave0/urxvt-font-size
  31 # https://github.com/noah/urxvt-font
  32 #
  33 #
  34 # USAGE
  35 #
  36 # Add font-size to the list of perl extensions:
  37 # URxvt.perl-ext-common: ...,font-size
  38 #
  39 # Add some keybindings:
  40 # URxvt.keysym.C-Up:     perl:font-size:increase
  41 # URxvt.keysym.C-Down:   perl:font-size:decrease
  42 # URxvt.keysym.C-S-Up:   perl:font-size:incglobal
  43 # URxvt.keysym.C-S-Down: perl:font-size:decglobal
  44 #
  45 # Supported functions:
  46 # - increase/decrease:
  47 #       increase or decrease the font size of the current terminal.
  48 # - incglobal/decglobal:
  49 #       same as above and also adjust the X server values so all newly started
  50 #       terminals will use the same fontsize.
  51 # - incsave/decsave:
  52 #       same as incglobal/decglobal and also modify the ~/.Xresources file so
  53 #       the changed font sizes will persist over a restart of the X server or
  54 #       a reboot.
  55
  56 use strict;
  57 use warnings;
  58
  59 my %escapecodes = (
  60     "font"           => 710,
  61     "boldFont"       => 711,
  62     "italicFont"     => 712,
  63     "boldItalicFont" => 713
  64 );
  65
  66 sub on_user_command
  67 {
  68     my ($self, $cmd) = @_;
  69
  70     if ($cmd eq "font-size:increase") {
  71         fonts_change_size($self,  1, 0);
  72     } elsif ($cmd eq "font-size:decrease") {
  73         fonts_change_size($self, -1, 0);
  74     } elsif ($cmd eq "font-size:incglobal") {
  75         fonts_change_size($self,  1, 1);
  76     } elsif ($cmd eq "font-size:decglobal") {
  77         fonts_change_size($self, -1, 1);
  78     } elsif ($cmd eq "font-size:incsave") {
  79         fonts_change_size($self,  1, 2);
  80     } elsif ($cmd eq "font-size:decsave") {
  81         fonts_change_size($self, -1, 2);
  82     }
  83 }
  84
  85 sub fonts_change_size
  86 {
  87     my ($term, $change, $save) = @_;
  88
  89     my @newfonts = ();
  90
  91     my $curres = $term->resource('font');
  92     if (!$curres) {
  93         return;
  94     }
  95     my @curfonts = split(/,/, $curres);
  96
  97     my $basefont = shift(@curfonts);
  98     my ($newbasefont, $newbasesize) = handle_font($term, $basefont, $change, 0);
  99     push @newfonts, $newbasefont;
 100
 101     # Only adjust other fonts if base font changed
 102     if ($newbasefont ne $basefont) {
 103         foreach my $font (@curfonts) {
 104             my ($newfont, $newsize) = handle_font($term, $font, $change, $newbasesize);
 105             push @newfonts, $newfont;
 106         }
 107         my $newres = join(",", @newfonts);
 108         font_apply_new($term, $newres, "font", $save);
 109
 110         handle_type($term, "boldFont",       $change, $newbasesize, $save);
 111         handle_type($term, "italicFont",     $change, $newbasesize, $save);
 112         handle_type($term, "boldItalicFont", $change, $newbasesize, $save);
 113     }
 114
 115     if ($save > 1) {
 116         # write the new values back to the file
 117         my $xresources = readlink $ENV{"HOME"} . "/.Xresources";
 118         system("xrdb -edit " . $xresources);
 119     }
 120 }
 121
 122 sub handle_type
 123 {
 124     my ($term, $type, $change, $basesize, $save) = @_;
 125
 126     my $curres = $term->resource($type);
 127     if (!$curres) {
 128         return;
 129     }
 130     my @curfonts = split(/,/, $curres);
 131     my @newfonts = ();
 132
 133     foreach my $font (@curfonts) {
 134         my ($newfont, $newsize) = handle_font($term, $font, $change, $basesize);
 135         push @newfonts, $newfont;
 136     }
 137
 138     my $newres = join(",", @newfonts);
 139     font_apply_new($term, $newres, $type, $save);
 140 }
 141
 142 sub handle_font
 143 {
 144     my ($term, $font, $change, $basesize) = @_;
 145
 146     my $newfont;
 147     my $newsize;
 148     my $prefix = 0;
 149
 150     if ($font =~ /^\s*x:/) {
 151         $font =~ s/^\s*x://;
 152         $prefix = 1;
 153     }
 154     if ($font =~ /^\s*(\[.*\])?xft:/) {
 155         ($newfont, $newsize) = font_change_size_xft($term, $font, $change, $basesize);
 156     } elsif ($font =~ /^\s*-/) {
 157         ($newfont, $newsize) = font_change_size_x11($term, $font, $change, $basesize);
 158     } else {
 159         # check whether the font is a valid alias and if yes resolve it to the
 160         # actual font
 161         my $lsfinfo = `xlsfonts -l $font 2>/dev/null`;
 162
 163         if ($lsfinfo eq "") {
 164             # not a valid alias, ring the bell if it is the base font and just
 165             # return the current font
 166             if ($basesize == 0) {
 167                 $term->scr_bell;
 168             }
 169             return ($font, $basesize);
 170         }
 171
 172         my $fontinfo = (split(/\n/, $lsfinfo))[-1];
 173         my ($fontfull) = ($fontinfo =~ /\s+([-a-z0-9]+$)/);
 174         ($newfont, $newsize) = font_change_size_x11($term, $fontfull, $change, $basesize);
 175     }
 176
 177     # $term->scr_add_lines("\r\nNew font is $newfont\n");
 178     if ($prefix) {
 179         $newfont = "x:$newfont";
 180     }
 181     return ($newfont, $newsize);
 182 }
 183
 184 sub font_change_size_xft
 185 {
 186     my ($term, $fontstring, $change, $basesize) = @_;
 187
 188     my @pieces   = split(/:/, $fontstring);
 189     my @resized  = ();
 190     my $size     = 0;
 191     my $new_size = 0;
 192
 193     foreach my $piece (@pieces) {
 194         if ($piece =~ /pixelsize=(\d+)/) {
 195             $size = $1;
 196
 197             if ($basesize != 0) {
 198                 $new_size = $basesize;
 199             } else {
 200                 $new_size = ($change > 0 ? ($size + 1) : ($size - 1));
 201             }
 202
 203             $piece =~ s/pixelsize=$size/pixelsize=$new_size/;
 204         }
 205         push @resized, $piece;
 206     }
 207
 208     my $resized_str = join(":", @resized);
 209
 210     # don't make fonts too small
 211     if ($new_size >= 10) {
 212         return ($resized_str, $new_size);
 213     } else {
 214         if ($basesize == 0) {
 215             $term->scr_bell;
 216         }
 217         return ($fontstring, $size);
 218     }
 219 }
 220
 221 sub font_change_size_x11
 222 {
 223     my ($term, $fontstring, $change, $basesize) = @_;
 224
 225     #-xos4-terminus-medium-r-normal-*-12-*-*-*-*-*-*-1
 226
 227     my @fields = qw(foundry family weight slant setwidth style pixelSize pointSize Xresolution Yresolution spacing averageWidth registry encoding);
 228
 229     my %font;
 230     $fontstring =~ s/^-//;  # Strip leading - before split
 231     @font{@fields} = split(/-/, $fontstring);
 232
 233     if ($font{registry} eq '*') {
 234         $font{registry} ='iso8859';
 235     }
 236
 237     # Blank out the size for the pattern
 238     my %pattern = %font;
 239     $pattern{foundry} = '*';
 240     $pattern{setwidth} = '*';
 241     $pattern{pixelSize} = '*';
 242     $pattern{pointSize} = '*';
 243     # if ($basesize != 0) {
 244     #     $pattern{Xresolution} = '*';
 245     #     $pattern{Yresolution} = '*';
 246     # }
 247     $pattern{averageWidth} = '*';
 248     # make sure there are no empty fields
 249     foreach my $field (@fields) {
 250         $pattern{$field} = '*' unless defined($pattern{$field});
 251     }
 252     my $new_fontstring = '-' . join('-', @pattern{@fields});
 253
 254     my @possible;
 255     # $term->scr_add_lines("\r\nPattern is $new_fontstring\n");
 256     open(FOO, "xlsfonts -fn '$new_fontstring' | sort -u |") or die $!;
 257     while (<FOO>) {
 258         chomp;
 259         s/^-//;  # Strip leading '-' before split
 260         my @fontdata = split(/-/, $_);
 261
 262         push @possible, [$fontdata[6], "-$_"];
 263         # $term->scr_add_lines("\r\npossibly $fontdata[6] $_\n");
 264     }
 265     close(FOO);
 266
 267     if (!@possible) {
 268         die "No possible fonts!";
 269     }
 270
 271     if ($basesize != 0) {
 272         # sort by font size, descending
 273         @possible = sort {$b->[0] <=> $a->[0]} @possible;
 274
 275         # font is not the base font, so find the largest font that is at most
 276         # as large as the base font. If the largest possible font is smaller
 277         # than the base font bail and hope that a 0-size font can be found at
 278         # the end of the function
 279         if ($possible[0]->[0] > $basesize) {
 280             foreach my $candidate (@possible) {
 281                 if ($candidate->[0] <= $basesize) {
 282                     return ($candidate->[1], $candidate->[0]);
 283                 }
 284             }
 285         }
 286     } elsif ($change > 0) {
 287         # sort by font size, ascending
 288         @possible = sort {$a->[0] <=> $b->[0]} @possible;
 289
 290         foreach my $candidate (@possible) {
 291             if ($candidate->[0] > $font{pixelSize}) {
 292                 return ($candidate->[1], $candidate->[0]);
 293             }
 294         }
 295     } elsif ($change < 0) {
 296         # sort by font size, descending
 297         @possible = sort {$b->[0] <=> $a->[0]} @possible;
 298
 299         foreach my $candidate (@possible) {
 300             if ($candidate->[0] < $font{pixelSize} && $candidate->[0] != 0) {
 301                 return ($candidate->[1], $candidate->[0]);
 302             }
 303         }
 304     }
 305
 306     # no fitting font available, check whether a 0-size font can be used to
 307     # fit the size of the base font
 308     @possible = sort {$a->[0] <=> $b->[0]} @possible;
 309     if ($basesize != 0 && $possible[0]->[0] == 0) {
 310         return ($possible[0]->[1], $basesize);
 311     } else {
 312         # if there is absolutely no smaller/larger font that can be used
 313         # return the current one, and beep if this is the base font
 314         if ($basesize == 0) {
 315             $term->scr_bell;
 316         }
 317         return ("-$fontstring", $font{pixelSize});
 318     }
 319 }
 320
 321 sub font_apply_new
 322 {
 323     my ($term, $newfont, $type, $save) = @_;
 324
 325     # $term->scr_add_lines("\r\nnew font is $newfont\n");
 326
 327     $term->cmd_parse("\033]" . $escapecodes{$type} . ";" . $newfont . "\033\\");
 328
 329     # load the xrdb db
 330     # system("xrdb -load " . X_RESOURCES);
 331
 332     if ($save > 0) {
 333         # merge the new values
 334         open(XRDB_MERGE, "| xrdb -merge") || die "can't fork: $!";
 335         local $SIG{PIPE} = sub { die "xrdb pipe broken" };
 336         print XRDB_MERGE "URxvt." . $type . ": " . $newfont;
 337         close(XRDB_MERGE) || die "bad xrdb: $! $?";
 338     }
 339 }