SIRTX-Font
view release on metacpan or search on metacpan
lib/SIRTX/Font.pm view on Meta::CPAN
sub write {
my ($self, $out) = @_;
my $chars = $self->{chars};
my $glyphs = $self->{glyphs};
my %index;
my @list = sort {$a <=> $b} keys %{$chars};
my %index_update;
my @runs;
my @extra_headers;
{
my $next_index = 0;
my $run;
foreach my $idx (@list) {
my $glyph = $index_update{$chars->{$idx}} //= $next_index++;
if (defined $run) {
my $next = $run->[1] + 1;
if ($idx == ($run->[0] + $next) && $glyph == ($run->[2] + $next)) {
$run->[1]++;
} else {
$run = undef;
redo;
}
} else {
push(@runs, $run = [$idx, 0, $glyph]);
}
}
}
$self->set_attribute(last_modification => SIRTX::Datecode->now);
push(@extra_headers, eval { $self->_render_geometry_hints });
push(@extra_headers, eval { $self->_render_identity });
push(@extra_headers, eval { $self->_render_displayinfo });
@extra_headers = grep {defined} @extra_headers;
$out->binmode;
# Write magic:
print $out MAGIC;
eval { print $out $self->_render_early_hints(scalar(@extra_headers)) } if scalar(@extra_headers);
print $out $_ foreach @extra_headers;
# Write master header:
print $out pack('nCCCxn', DATA_START_MARKER, $self->width, $self->height, $self->bits, scalar(keys %index_update));
# Write codepoint -> glyph map:
print $out pack('Nnn', @{$_}) foreach @runs;
print $out pack('Nnn', 0xFFFFFFFF, 0, 0);
foreach my $glyph (sort {$index_update{$a} <=> $index_update{$b}} keys %index_update) {
print $out $glyphs->[$glyph];
}
}
sub import_glyph {
my ($self, $in) = @_;
if (!eval {$in->isa('Image::Magick')}) {
require Image::Magick;
my $p = Image::Magick->new;
$p->Read($in);
$in = $p;
}
return $self->_import_glyph_wbmp($in->ImageToBlob(magick => 'wbmp'));
}
sub _import_glyph_wbmp {
my ($self, $data) = @_;
my ($w, $h);
croak 'Bad wbmp magic' unless substr($data, 0, 2) eq "\0\0";
($w, $h) = unpack('CC', substr($data, 2, 2));
croak 'Bad geometry' if ($w & 0x80) || ($h & 0x80);
$self->width($w);
$self->height($h);
$self->bits(1);
push(@{$self->{glyphs}}, substr($data, 4));
return scalar(@{$self->{glyphs}}) - 1;
}
sub _read_kv_file {
my ($self, $filename, $cb) = @_;
open(my $in, '<:utf8', $filename) or croak 'Cannot open: '.$filename.': '.$!;
while (defined(my $line = <$in>)) {
my ($pg, $sg);
$line =~ s/\r?\n$//;
$line =~ s/^\s+//;
$line =~ s/\s+$//;
$line =~ s/^(?:;|\/\/|#).*$//;
$line =~ s/\s+/ /g;
($pg, $sg) = $line =~ /^(.+?\S)(?:\s+(?:--|<-|->|=>|<=|=)\s+(\S.*))?$/;
croak 'Invalid format' unless defined $pg;
$cb->($pg, $sg);
}
return $self;
}
sub import_alias_map {
my ($self, $filename, %opts) = @_;
my $chars = $self->{chars};
croak 'Stray options passed' if scalar keys %opts;
$self->_read_kv_file($filename => sub {
my ($pg, $sg) = @_;
my $primary;
lib/SIRTX/Font.pm view on Meta::CPAN
push(@{$self->{glyphs}}, ~. $pixel);
$chars->{$cp} = $cur++;
}
}
sub import_directory {
my ($self, $directory, %opts) = @_;
my $chars = $self->{chars};
my $incremental = delete $opts{incremental};
require File::Spec;
croak 'Stray options passed' if scalar keys %opts;
opendir(my $dir, $directory) or croak 'Cannot open directory: '.$directory;
while (defined(my $ent = readdir($dir))) {
if ($ent =~ /^U\+([0-9A-F]{4,})\.(?:png|wbmp)$/) {
my $codepoint = hex $1;
my $fullname;
my $glyph;
next if $incremental && defined $chars->{$codepoint};
$fullname = File::Spec->catfile($directory, $ent);
# TODO: Handle symlinks here.
$glyph = $self->import_glyph($fullname);
$self->glyph_for($codepoint => $glyph);
}
}
closedir($dir);
{
my $fullname = File::Spec->catfile($directory, 'font-attributes.txt');
$self->import_attributes($fullname) if -f $fullname;
}
{
my $fullname = File::Spec->catfile($directory, 'alias-map.txt');
$self->import_alias_map($fullname) if -f $fullname;
}
return $self;
}
sub export_glyph_as_image_magick {
my ($self, $glyph) = @_;
my $p;
$glyph = int($glyph) if defined $glyph;
croak 'No valid glyph given' unless defined($glyph) && $glyph >= 0;
$glyph = $self->{glyphs}[$glyph];
croak 'No valid glyph given' unless defined($glyph);
if ($self->width >= 128 || $self->height >= 128 || $self->bits != 1) {
croak 'Unsupported glyph size';
}
require Image::Magick;
$p = Image::Magick->new(magick => 'wbmp');
$p->BlobToImage(pack('CCCC', 0, 0, $self->width, $self->height).$glyph);
return $p;
}
sub export_alias_map {
my ($self, $filename, %opts) = @_;
my $chars = $self->{chars};
my %glyph_map;
local $, = ' ';
croak 'Stray options passed' if scalar keys %opts;
foreach my $char (keys %{$chars}) {
push(@{$glyph_map{$chars->{$char}} //= []}, $char);
}
open(my $out, '>:utf8', $filename) or croak 'Cannot open file: '.$filename.': '.$!;
foreach my $chars (grep {scalar(@{$_}) > 1} values %glyph_map) {
$out->say(map {sprintf('U+%04X', $_)} sort {$a <=> $b} @{$chars});
}
}
sub make_up_glyphs {
my ($self) = @_;
my $w = $self->width;
my $h = $self->height;
my $vmiddleline = eval {$self->get_attribute('vmiddleline')};
my $hmiddleline = eval {$self->get_attribute('hmiddleline')};
my $h8 = $h/8;
my $w8 = $w/8;
my $wb = int($w8) + (($w % 8) ? 1 : 0);
$self->bits(1);
# U+0020 SPACE
$self->_make_up_glyphs_add_one(0x0020 => [map {chr(0xFF) x $wb} 1..$h]);
# U+2588 FULL BLOCK
$self->_make_up_glyphs_add_one(0x2588 => [map {chr(0x00) x $wb} 1..$h]);
# U+2581 LOWER ONE EIGHTH BLOCK .. U+2587 LOWER SEVEN EIGHTHS BLOCK
for (my $i = 1; $i < 8; $i++) {
$self->_make_up_glyphs_add_one((0x2580 + $i) => [map {chr(($h - $_) < ($i*$h8) ? 0x00 : 0xFF) x $wb} 1..$h]);
}
# U+2594 UPPER ONE EIGHTH BLOCK
$self->_make_up_glyphs_add_one(0x2594 => [map {chr(($h - $_) > (7*$h8) || $_ == 1 ? 0x00 : 0xFF) x $wb} 1..$h]);
# U+2580 UPPER HALF BLOCK
$self->_make_up_glyphs_add_one(0x2580 => [map {chr($_ > (4*$h8) ? 0xFF : 0x00) x $wb} 1..$h]);
# Dear reader, have fun figuring out this!
# The basic idea is that we generate a pattern that is 8 or 16 bit wide and use that for the blocks.
# The pattern is created using bit shifts in units of 1/8ths.
# We also ensure that at least a one pixel bar is present, even if we would shift it all out (e.g. 1/8ths of 4 pixels is still one pixel).
if ($wb == 1) {
my $pattern;
lib/SIRTX/Font.pm view on Meta::CPAN
} else {
$vmiddleline = $vpixel;
$vmatches++;
}
}
if (defined $hpixel) {
if (defined $hmiddleline) {
$hmatches++ if $hmiddleline == $hpixel;
} else {
$hmiddleline = $hpixel;
$hmatches++;
}
}
#printf("U+%04X %2u 0x%04X empty: 0x%04X, vpixel: %s\n", $cp, 0, $lines[0], $empty, $vpixel // '<undef>');
}
}
# We require at least 4 matches.
if ($vmatches >= 4) {
eval { $self->_set_value(vmiddleline => $vmiddleline); }
}
if ($hmatches >= 4) {
eval { $self->_set_value(hmiddleline => $hmiddleline); }
}
#warn sprintf('vmiddleline: %u, matches: %u', $vmiddleline, $vmatches);
#warn sprintf('hmiddleline: %u, matches: %u', $hmiddleline, $hmatches);
}
#use Data::Dumper;
#warn Dumper([map {sprintf('0x%02x', $_)} $self->_analyse_read_char(ord('A'))]);
}
sub _analyse_read_char {
my ($self, $cp) = @_;
my $glyph = $self->glyph_for($cp);
my $w = $self->width;
my $p;
$glyph = int($glyph) if defined $glyph;
croak 'No valid glyph given' unless defined($glyph) && $glyph >= 0;
$glyph = $self->{glyphs}[$glyph];
croak 'No valid glyph given' unless defined($glyph);
if ($self->bits != 1) {
croak 'Unsupported glyph size';
}
if ($w <= 8) {
return unpack('C*', $glyph);
} elsif ($w <= 16) {
return unpack('n*', $glyph);
} else {
croak 'Unsupported glyph width';
}
}
sub render {
require List::Util;
require Image::Magick;
my ($self, $string) = @_;
my @lines = split(/\r?\n/, $string);
my $max_line = List::Util::max(map {length} @lines);
my $width = $self->width;
my $height = $self->height;
my $p = Image::Magick->new;
my %handle_cache;
$p->Set(size => sprintf('%ux%u', $max_line * $width, scalar(@lines) * $height));
$p->Read('canvas:white');
for (my $row = 0; $row < scalar(@lines); $row++) {
my $line = $lines[$row];
my $len = length($line);
for (my $column = 0; $column < $len; $column++) {
my $c = substr($line, $column, 1);
my $handle = $handle_cache{ord $c} //= $self->export_glyph_as_image_magick($self->glyph_for(ord $c));
$p->CopyPixels(image => $handle, width => $width, height => $height, x => 0, y => 0, dx => $column * $width, dy => $row * $height);
}
}
return $p;
}
# TODO: This is not yet part of public API. make it public. reconsider how it should work before doing so.
sub list_info {
my ($self, $list) = @_;
my $chars = $_char_lists{$list};
return undef unless defined $chars;
return {
name => $list,
characters => scalar(@{$chars}),
};
}
# ---- Private helpers ----
sub _render_font_flags {
my ($self) = @_;
my $slant = $self->get_attribute('slant');
my $weight = $self->get_attribute('weight');
my $res = 0;
$res |= $self->has_all_codepoints_from('important') ? 1 << 5 : 0;
$res |= $self->get_attribute('reverse_slant') ? 0 : 1 << 4;
if ($slant eq 'roman') {
$res |= 3 << 2;
} elsif ($slant eq 'italic') {
$res |= 1 << 2;
} elsif ($slant eq 'oblique') {
$res |= 2 << 2;
} else {
$res |= 0;
}
if ($weight eq 'normal') {
$res |= 3;
} elsif ($slant eq 'bold') {
$res |= 1;
} elsif ($slant eq 'thin') {
$res |= 2;
} else {
$res |= 0;
}
lib/SIRTX/Font.pm view on Meta::CPAN
Aliases the glyph for code point C<$from> to the same as code point C<$to> if C<$from> has no glyph set.
=head2 add_default_aliases
$font->add_default_aliases;
# or:
$font->add_default_aliases($level);
(experimental, since v0.02)
Adds aliases as per L</default_alias_glyph> for known homoglyphs.
The following levels are supported:
=over
=item C<common-small>
A set if code point aliases that are both likely homoglyphs as well as hard to pick up by rendering engines.
=item C<common-large>
A set of code point aliases that are likely homoglyphs, some might be picked up by rendering engines.
This includes the aliases from C<common-small>.
=item C<common-all>
A set of code point aliases that are likely homoglyphs, including those that should be picked up by rendering engines.
This includes the aliases from C<common-small>, and C<common-large>.
=back
B<Note:>
This operation cannot easly be undone.
B<Note:>
The levels are not yet stable in this version. Future versions might use different sets of code points aliases.
=head2 read
$font->read($handle);
Reads a font file into memory.
If any data is already loaded the data is merged.
=head2 write
$font->write($handle);
Writes the current font in the SIRTX format to the given handle.
=head2 import_glyph
my $glyph = $font->import_glyph($filename);
Imports a glyph from a file.
The glyph index is returned.
The supported formats depend on the installed modules.
See also L<Image::Magick>.
=head2 import_alias_map
$font->import_alias_map($filename);
(experimental, since v0.04)
Imports an alias map from the given file.
The format is one alias group per line.
Each line is formatted into two sections.
The first section lists all the code points that are aliased to each other.
The second part (seperated by a C<-->) lists all the code points that
are only aliased to (that is they will share the glyph from the first part,
but the code points from the first part will not share glyph with the second part).
Each part is a list of codepoints in C<U+NNNN> format, seperated by space, comma or both.
This method will ignore if a mapped glyph does not exists alike L</default_glyph_for>.
=head2 import_attributes
$font->import_attributes($filename);
(experimental, since v0.07)
Imports an font attributes from the given file.
The format consist of simple key-value-pairs separated by a single C<=>, optionally with spaces.
Possible keys and values are the same as for L</set_attribute>.
=head2 import_psf
$font->import_psf($filename);
(experimental since v0.06)
Imports a PC Screen Font (PSF) file into the font.
Supports PSF1, and PSF2 files at this point.
Note that files without a Unicode table might import incorrectly.
=head2 import_hex
$font->import_hex($filename);
(since v0.07)
Imports Roman's .hex format. This supports both 8 and 16 pixel width glyphs.
If the font is set to pixel width 8 pixel glyphs are extended with space to match 16 pixel.
B<Note:>
The font must be set to 8 or 16 pixel width before this function is called.
See L</width> for details.
=head2 import_directory
$font->import_directory($filename [, %opts ]);
(experimental, since v0.02)
Imports a directory into the font.
The directory contains of files with a name of the code point plus the extention png or wbmp (e.g. C<U+1F981.png>).
There is one option supported: C<incremental>.
If set to a true value it will cause mappings for already known code points to be skipped.
This can result in a massive speedup.
Only use if you are sure no entries have been altered.
B<Note:>
All rules of L</import_glyph> apply.
Entries are merged, data already present in the font is not cleared.
B<Note:>
In order to deduplicate entries a call to L</gc> might be considered.
=head2 export_glyph_as_image_magick
my Image::Magick $image = $font->export_glyph_as_image_magick($glyph);
(experimental, since v0.01)
Exports a single glyph as a image object.
=head2 export_alias_map
$font->export_alias_map($filename);
(experimental, since v0.04)
Exports the map of all aliases found in the font.
This is the inverse of L</import_alias_map>.
B<Note:>
This method cannot know which code points are aliases one way and which are aliased both ways.
This information is not included in the binary format.
Therefore this method exports all aliases as both way aliases.
This is the same behaviour as known from hardlinks.
=head2 make_up_glyphs
$font->make_up_glyphs;
(experimental since v0.06)
Makes up glyphs for the font.
This will create glyphs that can be easily calculated, such as the space character (all blank).
The exact list of characters that can be made up depend on the version of this module and the available font data.
Therefore this should be called late in processing a font, so that as much data is available to the algorithm as possible.
L</add_default_aliases> should be called after this step if called at all.
L</gc> should be called after this step, as this step might generate glyphs that are in fact unused.
B<Note:>
This step can not easily be undone. It should be used with care on font files that a meant to be edited.
B<Note:>
Code points are added as per L</default_glyph_for>.
=head2 analyse
$font->analyse;
(experimental, since v0.06)
Analyses the font to find additional attributes automatically.
This can be useful specifically when importing pre-existing fonts.
However the result should be manually checked as the values might not reflect reality.
=head2 render
my Image::Magick $image = $font->render($string);
# e.g.:
my Image::Magick $image = $font->render("Hello World!");
$image->Transparent(color => 'white'); # transparent background
$image->Write('hello.png');
(experimental, since v0.03)
Renders a text using the loaded font.
=head1 AUTHOR
Philipp Schafft <lion@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2025-2026 by Philipp Schafft <lion@cpan.org>.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut
( run in 1.606 second using v1.01-cache-2.11-cpan-99c4e6809bf )