2026 11 12 TDF Send for Irssi

use strict;
use warnings;
use utf8;
use Irssi;
use Encode qw(decode encode);
use File::Spec;
use Cwd qw(abs_path);

our $VERSION = '1.12';
our %IRSSI = (
    authors     => 'Converted from tdf_send.py',
    name        => 'tdf_send',
    description => 'Render and send wrapped TheDraw .TDF fonts',
    license     => 'Public Domain',
);

my $TDF_MARKER        = "\x55\xaa\x00\xff";
my $FIRST_FONT_OFFSET = 20;
my $FONT_HEADER_SIZE  = 213;
my $UNDEFINED_OFFSET  = 0xFFFF;
my $MAX_IRC_BYTES     = 350;

my @DOS_TO_IRC = (1, 2, 3, 10, 4, 6, 7, 15, 14, 12, 9, 11, 4, 13, 8, 0);

my %OUTLINE_MAP = (
    A => 0xCD, B => 0xC4, C => 0xB3, D => 0xBA,
    E => 0xD5, F => 0xBB, G => 0xD6, H => 0xBF,
    I => 0xC8, J => 0xBE, K => 0xC0, L => 0xBD,
    M => 0xB5, N => 0xC7,
);

my %PC_DISPLAY_GLYPHS = (
    1=>'☺', 2=>'☻', 3=>'♥', 4=>'♦', 5=>'♣', 6=>'♠', 7=>'•', 8=>'◘',
    9=>'○', 10=>'◙', 11=>'♂', 12=>'♀', 14=>'♫', 15=>'☼', 16=>'►',
    17=>'◄', 18=>'↕', 19=>'‼', 20=>'¶', 21=>'§', 22=>'▬', 23=>'↨',
    24=>'↑', 25=>'↓', 26=>'→', 27=>'←', 28=>'∟', 29=>'↔', 30=>'▲',
    31=>'▼', 127=>'⌂',
);

my %TDF_BLOCK_GLYPHS = (
    0xB0=>'░', 0xB1=>'▒', 0xB2=>'▓', 0xDB=>'█',
    0xDC=>'▄', 0xDD=>'▌', 0xDE=>'▐', 0xDF=>'▀', 0xFE=>'█',
);

my %loaded_fonts;
my $loaded_file;

Irssi::settings_add_str('tdf', 'tdf_font_directory', "$ENV{HOME}/fonts");
Irssi::settings_add_str('tdf', 'tdf_last_font_file', '');

sub cp437_to_utf8 {
    my ($value) = @_;
    return $TDF_BLOCK_GLYPHS{$value} if exists $TDF_BLOCK_GLYPHS{$value};
    return $PC_DISPLAY_GLYPHS{$value} if exists $PC_DISPLAY_GLYPHS{$value};
    return decode('cp437', chr($value), Encode::FB_DEFAULT);
}

sub font_key {
    my ($name) = @_;
    $name =~ s/\x00//g;
    $name =~ s/\x{A0}/ /g;
    $name =~ s/^\s+|\s+$//g;
    return lc $name;
}

sub display_width {
    my ($text) = @_;
    $text =~ s/\x03\d{2},\d{2}//g;
    $text =~ s/\x0f//g;
    return length($text);
}

sub compact_irc_colors {
    my ($line) = @_;
    my ($result, $last_color) = ('', undef);

    while (length $line) {
        if ($line =~ s/^(\x03\d{2},\d{2})//) {
            my $color = $1;
            if (!defined $last_color || $color ne $last_color) {
                $result .= $color;
                $last_color = $color;
            }
            next;
        }

        my $char = substr($line, 0, 1, '');
        $last_color = undef if $char eq "\x0f";
        $result .= $char;
    }

    return $result;
}

sub get_font_directory {
    my $dir = Irssi::settings_get_str('tdf_font_directory');
    $dir =~ s/^~/$ENV{HOME}/;
    return $dir;
}

sub resolve_tdf_path {
    my ($value) = @_;
    $value =~ s/^~/$ENV{HOME}/;

    my @candidates = (
        File::Spec->file_name_is_absolute($value) || $value =~ m!/!
            ? $value
            : File::Spec->catfile(get_font_directory(), $value)
    );

    for my $candidate (@candidates) {
        return abs_path($candidate) if -f $candidate;

        if ($candidate !~ /\.tdf$/i) {
            my $with_extension = "$candidate.tdf";
            return abs_path($with_extension) if -f $with_extension;
        }
    }

    die qq{Could not find "$value" in } . get_font_directory();
}

sub character {
    my ($font, $char) = @_;

    return ['    '] if $char eq ' ';

    my $code = ord($char);
    return [$char] if $code < 33 || $code > 126;

    my $offset = $font->{offsets}->[$code - 33];
    return [$char] if !defined($offset)
        || $offset == $UNDEFINED_OFFSET
        || $offset + 2 > length($font->{data});

    my $width  = ord(substr($font->{data}, $offset, 1));
    my $height = ord(substr($font->{data}, $offset + 1, 1));
    my $pos    = $offset + 2;

    return [' '] if $width == 0;

    my @rows;
    my $row = '';
    my $columns = 0;

    while ($pos < length($font->{data})) {
        my $value = ord(substr($font->{data}, $pos++, 1));

        if ($value == 0) {
            if (length($row) || !@rows) {
                my $padding = $width - $columns;
                $padding = 0 if $padding < 0;
                push @rows, $row . (' ' x $padding);
            }
            last;
        }

        if ($value == 13) {
            my $padding = $width - $columns;
            $padding = 0 if $padding < 0;
            push @rows, $row . (' ' x $padding);

            $row = '';
            $columns = 0;
            next;
        }

        my $color_value;
        if ($font->{font_type} == 2) {
            last if $pos >= length($font->{data});
            $color_value = ord(substr($font->{data}, $pos++, 1));
        }

        my $glyph;
        if ($font->{font_type} == 0) {
            my $reference = chr($value);

            if ($reference eq '@') {
                $glyph = ' ';
            } elsif ($reference eq 'O') {
                $glyph = "\x{A0}";
            } elsif ($reference eq '&') {
                next;
            } elsif (exists $OUTLINE_MAP{$reference}) {
                $glyph = cp437_to_utf8($OUTLINE_MAP{$reference});
            } else {
                $glyph = cp437_to_utf8($value);
            }
        } else {
            $glyph = cp437_to_utf8($value);
        }

        if (defined $color_value) {
            my $fg = $DOS_TO_IRC[$color_value & 0x0F];
            my $bg = $DOS_TO_IRC[($color_value >> 4) & 0x07];
            $row .= sprintf("\x03%02d,%02d%s", $fg, $bg, $glyph);
        } else {
            $row .= $glyph;
        }

        $columns++;
    }

    push @rows, (' ' x $width) while @rows < $height;
    return @rows ? \@rows : [(' ' x $width)];
}

sub render {
    my ($font, $text) = @_;
    my @rendered;

    my @source_lines = split(/\n/, $text, -1);
    @source_lines = ('') unless @source_lines;

    for my $source_line (@source_lines) {
        # Explicit blank paragraphs render as one blank IRC line.
        if ($source_line eq '') {
            push @rendered, "\x0f";
            next;
        }

        my @glyphs = map { character($font, $_) } split(//, $source_line);
        next unless @glyphs;

        my @widths;
        for my $glyph (@glyphs) {
            my $max_width = 1;

            for my $glyph_row (@$glyph) {
                my $width = display_width($glyph_row);
                $max_width = $width if $width > $max_width;
            }

            push @widths, $max_width;
        }

        my $height = 1;
        for my $glyph (@glyphs) {
            $height = scalar(@$glyph) if scalar(@$glyph) > $height;
        }

        my @output = ('') x $height;

        for my $i (0 .. scalar(@glyphs) - 1) {
            for my $row_index (0 .. $height - 1) {
                if ($row_index < scalar(@{$glyphs[$i]})) {
                    $output[$row_index] .= $glyphs[$i]->[$row_index];
                } else {
                    $output[$row_index] .= ' ' x $widths[$i];
                }
            }

            if ($i < scalar(@glyphs) - 1) {
                $_ .= ' ' x $font->{spacing} for @output;
            }
        }

        push @rendered, map { $_ . "\x0f" } @output;
    }

    return @rendered;
}

sub rendered_lines_fit {
    my ($font, $text, $limit) = @_;

    for my $line (render($font, $text)) {
        return 0 if length(encode('UTF-8', compact_irc_colors($line))) > $limit;
    }

    return 1;
}

sub render_wrapped {
    my ($font, $text, $limit) = @_;
    $limit //= $MAX_IRC_BYTES;

    my @all_lines;

    for my $paragraph (split(/\n/, $text, -1)) {
        if ($paragraph eq '') {
            push @all_lines, render($font, '');
            next;
        }

        my @words = split(/\s+/, $paragraph);
        my $current = '';

        for my $word (@words) {
            my $candidate = $current eq '' ? $word : "$current $word";

            if (rendered_lines_fit($font, $candidate, $limit)) {
                $current = $candidate;
                next;
            }

            if ($current ne '') {
                push @all_lines, render($font, $current);
                $current = '';
            }

            if (rendered_lines_fit($font, $word, $limit)) {
                $current = $word;
                next;
            }

            my $partial = '';

            for my $char (split(//, $word)) {
                my $part_candidate = $partial . $char;

                if (rendered_lines_fit($font, $part_candidate, $limit)) {
                    $partial = $part_candidate;
                } else {
                    die 'One rendered character is wider than IRC allows.'
                        if $partial eq '';

                    push @all_lines, render($font, $partial);
                    $partial = $char;
                }
            }

            $current = $partial;
        }

        push @all_lines, render($font, $current) if $current ne '';
    }

    return @all_lines;
}

sub load_tdf {
    my ($path) = @_;

    open my $fh, '<:raw', $path or die "Cannot open $path: $!";
    local $/;
    my $blob = <$fh>;
    close $fh;

    die 'Not a valid TheDraw .TDF file.'
        unless substr($blob, 0, 20) eq "\x13TheDraw FONTS file\x1a";

    my %fonts;
    my $pos = $FIRST_FONT_OFFSET;

    while ($pos + $FONT_HEADER_SIZE <= length($blob)) {
        last unless substr($blob, $pos, 4) eq $TDF_MARKER;

        my $name_length = ord(substr($blob, $pos + 4, 1));
        $name_length = 12 if $name_length > 12;

        my $name = decode('cp437', substr($blob, $pos + 5, $name_length));
        $name =~ s/\x00.*$//s;
        $name =~ s/^\s+|\s+$//g;

        my $font_type  = ord(substr($blob, $pos + 21, 1));
        my $spacing    = ord(substr($blob, $pos + 22, 1));
        my $block_size = unpack('v', substr($blob, $pos + 23, 2));
        my @offsets    = unpack('v94', substr($blob, $pos + 25, 188));

        my $data_start = $pos + $FONT_HEADER_SIZE;
        my $data_end   = $data_start + $block_size;
        $data_end = length($blob) if $data_end > length($blob);

        if ($name ne '') {
            $fonts{font_key($name)} = {
                name      => $name,
                font_type => $font_type,
                spacing   => $spacing > 0 ? $spacing - 1 : 0,
                data      => substr($blob, $data_start, $data_end - $data_start),
                offsets   => \@offsets,
            };
        }

        $pos = $data_start + $block_size;
    }

    die 'No readable fonts were found in this file.' unless %fonts;

    %loaded_fonts = %fonts;
    $loaded_file = abs_path($path);
}

sub get_font {
    my ($name) = @_;
    my $font = $loaded_fonts{font_key($name)};

    die qq{Font "$name" was not found. Use /TDFFONTS to list fonts.}
        unless $font;

    return $font;
}

sub send_lines {
    my ($server, $target, @lines) = @_;

    for my $line (@lines) {
        $line =~ s/[\r\n]//g;
        $line = compact_irc_colors($line);

        die 'A rendered line is too wide for IRC.'
            if length(encode('UTF-8', $line)) > $MAX_IRC_BYTES;

        # Do not pre-encode: Irssi performs outgoing encoding itself.
        $server->command("MSG $target $line");
    }
}

sub active_target {
    my $window = Irssi::active_win();
    my $item = $window->{active};

    die 'No active channel or query.'
        unless $item && $item->{server};

    return ($item->{server}, $item->{name});
}

sub parse_quoted {
    my ($text) = @_;
    my @args;

    while ($text =~ /\G\s*(?:"([^"]*)"|'([^']*)'|(\S+))/gc) {
        push @args, defined($1) ? $1 : defined($2) ? $2 : $3;
    }

    return @args;
}

sub cmd_tdfload {
    my ($data) = @_;

    eval {
        die 'Usage: /TDFLOAD <filename-or-path>' unless $data =~ /\S/;

        my $path = resolve_tdf_path($data);
        load_tdf($path);

        Irssi::settings_set_str('tdf_last_font_file', $loaded_file);
        Irssi::print(
            'Loaded ' . scalar(keys %loaded_fonts) . " font(s) from $loaded_file"
        );
    };

    Irssi::print("TDF error: $@") if $@;
}

sub cmd_tdfdir {
    my ($data) = @_;

    eval {
        if ($data !~ /\S/) {
            Irssi::print('TDF directory: ' . get_font_directory());
            return;
        }

        $data =~ s/^~/$ENV{HOME}/;
        die "Directory does not exist: $data" unless -d $data;

        my $path = abs_path($data);
        Irssi::settings_set_str('tdf_font_directory', $path);
        Irssi::print("TDF directory set to: $path");
    };

    Irssi::print("TDF error: $@") if $@;
}

sub cmd_tdffonts {
    if (!%loaded_fonts) {
        Irssi::print('No TDF file loaded. Use /TDFLOAD <file>.');
        return;
    }

    Irssi::print(
        'Loaded fonts: ' .
        join(', ', sort map { $_->{name} } values %loaded_fonts)
    );
}

sub cmd_tdf {
    my ($data) = @_;

    eval {
        my @args = parse_quoted($data);
        die 'Usage: /TDF "Font Name" text' unless @args >= 2;

        my $font = get_font(shift @args);
        my ($server, $target) = active_target();

        send_lines($server, $target, render_wrapped($font, join(' ', @args)));
    };

    Irssi::print("TDF error: $@") if $@;
}

sub cmd_tdfto {
    my ($data) = @_;

    eval {
        my @args = parse_quoted($data);
        die 'Usage: /TDFTO <#channel-or-nick> "Font Name" text'
            unless @args >= 3;

        my $target = shift @args;
        my $font = get_font(shift @args);
        my ($server) = active_target();

        send_lines($server, $target, render_wrapped($font, join(' ', @args)));
    };

    Irssi::print("TDF error: $@") if $@;
}

Irssi::command_bind('tdfload',  \&cmd_tdfload);
Irssi::command_bind('tdfdir',   \&cmd_tdfdir);
Irssi::command_bind('tdffonts', \&cmd_tdffonts);
Irssi::command_bind('tdf',      \&cmd_tdf);
Irssi::command_bind('tdfto',    \&cmd_tdfto);

Irssi::print("TDF Send $VERSION loaded");

my $saved_font = Irssi::settings_get_str('tdf_last_font_file');

if ($saved_font && -f $saved_font) {
    eval {
        load_tdf($saved_font);
        Irssi::print("TDF Send restored $saved_font");
    };

    Irssi::print("TDF auto-load error: $@") if $@;
} else {
    Irssi::print('TDF Send font directory: ' . get_font_directory());
}