File Coverage

blib/lib/PDF/API2/Win32.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package PDF::API2::Win32;
2              
3 1     1   1075 use strict;
  1         4  
  1         35  
4 1     1   6 no warnings qw[ deprecated recursion uninitialized ];
  1         1  
  1         66  
5              
6             our $VERSION = '2.044'; # VERSION
7              
8             package PDF::API2;
9              
10 1     1   266 use Win32::TieRegistry;
  0            
  0            
11              
12             use strict;
13             no warnings qw[ recursion uninitialized ];
14              
15             our $wf = {};
16              
17             $Registry->Delimiter('/');
18              
19             my $fontdir = $Registry->{'HKEY_CURRENT_USER/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders'}->{'Fonts'};
20              
21             my $subKey = $Registry->{'HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Fonts/'};
22              
23             foreach my $k (sort keys %{$subKey}) {
24             next unless $subKey->{$k} =~ /\.[ot]tf$/i;
25             my $kk = lc $k;
26             $kk =~ s|^/||;
27             $kk =~ s|\s+\(truetype\).*$||g;
28             $kk =~ s|\s+\(opentype\).*$||g;
29             $kk =~ s/[^a-z0-9]+//g;
30              
31             $wf->{$kk} = {};
32              
33             $wf->{$kk}->{'display'} = $k;
34             $wf->{$kk}->{'display'} =~ s|^/||;
35              
36             if (-e "$fontdir/$subKey->{$k}") {
37             $wf->{$kk}->{'ttfile'} = "$fontdir/$subKey->{$k}";
38             }
39             else {
40             $wf->{$kk}->{'ttfile'} = $subKey->{$k};
41             }
42             }
43              
44             $subKey = $Registry->{'HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Type 1 Installer/Type 1 Fonts/'};
45              
46             foreach my $k (sort keys %$subKey) {
47             my $kk = lc $k;
48             $kk =~ s|^/||;
49             $kk =~ s/[^a-z0-9]+//g;
50              
51             $wf->{$kk} = {};
52              
53             $wf->{$kk}->{'display'} = $k;
54             $wf->{$kk}->{'display'} =~ s|^/||;
55              
56             my $t;
57             ($t, $wf->{$kk}->{'pfmfile'}, $wf->{$kk}->{'pfbfile'}) = split(/\0/, $subKey->{$k});
58              
59             if (-e "$fontdir/$wf->{$kk}->{pfmfile}") {
60             $wf->{$kk}->{'pfmfile'} = "$fontdir/" . $wf->{$kk}->{'pfmfile'};
61             $wf->{$kk}->{'pfbfile'} = "$fontdir/" . $wf->{$kk}->{'pfbfile'};
62             }
63             }
64              
65             sub enumwinfonts {
66             my $self = shift();
67             return map { $_ => $wf->{$_}->{'display'} } keys %$wf;
68             }
69              
70             sub winfont {
71             my $self = shift();
72             my $key = lc(shift());
73             $key =~ s/[^a-z0-9]+//g;
74              
75             return unless defined $wf and defined $wf->{$key};
76              
77             if (defined $wf->{$key}->{'ttfile'}) {
78             return $self->ttfont($wf->{$key}->{'ttfile'}, @_);
79             }
80             else {
81             return $self->psfont($wf->{$key}->{'pfbfile'}, -pfmfile => $wf->{$key}->{'pfmfile'}, @_);
82             }
83             }
84              
85             1;