Here is a package written by eserte, who is the current Tk maintainer and guru.
If you can figure it out, ;-) Otherwise, without Tk::Zinc you are stuck using Cairo , look at the text-rotate.pl example in the Cairo module source.
#!/usr/bin/perl -w
# -*- *perl* -*-
package main;
use vars qw($x11);
package Tk::RotX11Font;
# $Id: RotX11Font.pm,v 1.13 1999/01/22 00:38:27 eserte Exp eserte $
# Author: Slaven Rezic
#
# Copyright (C) 1998, 1999 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as *Perl* itself.
#
# Mail: ese...
#</groups/unlock?msg=a8e2ebe3c5c85dc4&_done=/group/comp.lang.perl.tk/b
+rowse_thread/thread/a128e86f32629886/a8e2ebe3c5c85dc4%3Flnk%3Dst%26q%
+3DX11%253A%253AProtocol%2BPerl%26rnum%3D2>@cs.tu-berlin.de
# WWW: http://user.cs.tu-berlin.de/~eserte/
use Tk;
use Tk::Font;
use strict;
use vars qw(%font_cache);
sub new {
my($pkg, $text, $f_sub, $size, $rad) = @_;
my $self = {};
($self->{Font}, $self->{'Xadd'}, $self->{'Yadd'})
= get_font_attrib($text, $f_sub, $size, $rad);
$self->{Text} = $text;
bless $self, $pkg;
}
sub writeCanvas {
my($rotfont, $c, $x, $y, $tags, $text) = @_;
my $xadd_ref = $rotfont->{Xadd};
my $yadd_ref = $rotfont->{Yadd};
$text = $rotfont->{Text} if !defined $text;
for(split(//, $text)) {
my $item = $c->createText
($x, $y, -text => $_, -font => $rotfont->{Font},
-anchor => 'w',
(defined $tags ? (-tags => $tags) : ()));
$x+=$xadd_ref->[ord($_)];
$y+=$yadd_ref->[ord($_)];
}
($x, $y);
}
# Arguments:
# $c - canvas
# $x, $y - start coordinates
# $f_sub - template for font as a sub reference, something like:
# sub { "-adobe-helvetica-medium-r-normal--0-" . $_[0] ."-0-0
+-p-0-iso8859-1" }
# $size - point- (or pixel?)size
# $rad - angle in radians
# $text - text for output
# $tags - (optional) tags
#
# Returns coordinate ($x, $y) of the position of textcursor after draw
+ing.
sub writeRot {
my($c, $x, $y, $f_sub, $size, $rad, $text, $tags) = @_;
my($f, $xadd_ref, $yadd_ref) = get_font_attrib($text, $f_sub, $siz
+e,
$rad);
for(split(//, $text)) {
my $item = $c->createText($x, $y, -text => $_, -font => $f,
-anchor => 'w',
(defined $tags ? (-tags => $tags) :
+()));
$x+=$xadd_ref->[ord($_)];
$y+=$yadd_ref->[ord($_)];
}
($x, $y);
}
# Returns an array with the generated X11 font name, and references
# to the per-character X-Add- and Y-Add-arrays
sub get_font_attrib {
my($text, $f_sub, $size, $rad) = @_;
my($mat) = get_matrix($size, $rad);
my %chars_used = map { (ord($_), 1) } split(//, $text);
my $chars_used = join(" ", sort {$a <=> $b } keys %chars_used);
# X11R6- oder *X11::Protocol*-Bug? Font-Struktur muĂŸ mehr al
+s ein
# Zeichen enthalten!
if (scalar keys %chars_used == 1) {
$chars_used .= " " . ((keys(%chars_used))[0] == 32 ? 33 : 32);
}
my $f = $f_sub->($mat);
$f .= "[$chars_used]";
my($xadd_ref, $yadd_ref) = get_x11font_resources($f, \%chars_used)
+;
($f, $xadd_ref, $yadd_ref);
}
sub get_matrix {
my($size, $r) = @_;
my($mat);
foreach ($size*cos($r), $size*sin($r), $size*-sin($r), $size*cos($
+r)) {
s/-/~/g;
if ($mat) { $mat .= " " }
$mat .= $_;
}
"[" . $mat . "]";
}
sub x_y_extent {
my($rotfont, $text) = @_;
my $x = 0;
my $y = 0;
my $xadd_ref = $rotfont->{Xadd};
my $yadd_ref = $rotfont->{Yadd};
$text = $rotfont->{Text} if !defined $text;
foreach (split(//, $text)) {
$x += $xadd_ref->[ord($_)];
$y += $yadd_ref->[ord($_)];
}
($x, $y);
}
sub get_x_y_extent {
my($text, $f_sub, $size, $rad) = @_;
my($f, $xadd_ref, $yadd_ref) = get_font_attrib($text, $f_sub, $siz
+e,
$rad);
my $x = 0;
my $y = 0;
foreach (split(//, $text)) {
$x += $xadd_ref->[ord($_)];
$y += $yadd_ref->[ord($_)];
}
($x, $y);
}
sub get_x11font_resources {
my $font = shift;
my $chars_used_ref = shift;
my $fid = $main::x11->new_rsrc;
$main::x11->OpenFont($fid, $font);
my(%res) = $main::x11->QueryFont($fid);
my @x;
foreach (keys %{$res{'properties'}}) {
if ($main::x11->atom_name($_) eq 'FONT') {
my $realfont;
$realfont = $main::x11->atom_name($res{'properties'}->{$_}
+);
my(@f) = split(/-/, $realfont);
@x = split(/\s/, substr($f[7], 1, length($f[7])-2));
foreach (@x) { s/~/-/g }
last;
}
}
my(@font_xadd);
my(@font_yadd);
$#font_xadd = 255;
$#font_yadd = 255;
foreach (keys %$chars_used_ref) {
my $attr = $res{'char_infos'}->[$_-$res{'min_char_or_byte2'}]-
+>[5];
my($x, $y) = ($attr/1000*$x[0], -$attr/1000*$x[1]);
$font_xadd[$_] = $x;
$font_yadd[$_] = $y;
}
$main::x11->CloseFont($fid);
$font_cache{$font} = [\@font_xadd, \@font_yadd]; # XXX create dup?
(\@font_xadd, \@font_yadd);
}
return 1 if caller();
package main;
use Tk;
use X11::Protocol;
MAIN: {
my $top = new MainWindow;
$x11 = X11::Protocol->new();
my $font = shift || "adobe-helvetica";
# $font = "arial";
my $size = shift || 24;
my $f_sub = sub { "-$font-medium-r-normal--0-" . $_[0] . "-0-0-p-0
+-iso8859-1" };
my $c = $top->Canvas(-width => 500,
-height => 500,
-bg => 'white',
)->pack;
my $start = time;
for(my $deg = -180; $deg <= 180; $deg+=15) {
my $d = $deg;
my $r = _deg2rad($d);
my $text = " Some Rotated Text";
# my $rotfont = new Tk::RotX11Font $text, $f_sub, $size, $r;
# $rotfont->writeCanvas($c, 250, 250);
Tk::RotX11Font::writeRot($c, 250, 250, $f_sub, $size, $r, $tex
+t);
printf STDERR "(x/y) at %4d° = (" .
join("/", Tk::RotX11Font::get_x_y_extent($text, $f_sub, $siz
+e,$r)) .
")\n", $d;
}
warn "Time: " . (time-$start) . " seconds\n";
MainLoop;
}
sub _deg2rad {
$_[0]/180*3.141592653;
}
__END__
| 