+sub preload {
+ # this serves two purposes:
+ # - a class method to load the file support modules included with Imager
+ # (or were included, once the library dependent modules are split out)
+ # - something for Module::ScanDeps to analyze
+ # https://rt.cpan.org/Ticket/Display.html?id=6566
+ local $@;
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ eval { require Imager::File::GIF };
+ eval { require Imager::File::JPEG };
+ eval { require Imager::File::PNG };
+ eval { require Imager::File::SGI };
+ eval { require Imager::File::TIFF };
+ eval { require Imager::File::ICO };
+ eval { require Imager::Font::W32 };
+ eval { require Imager::Font::FT2 };
+ eval { require Imager::Font::T1 };
+ eval { require Imager::Color::Table };
+
+ 1;
+}
+
+package Imager::IO;
+use IO::Seekable;
+
+sub new_fh {
+ my ($class, $fh) = @_;
+
+ if (tied(*$fh)) {
+ return $class->new_cb
+ (
+ sub {
+ local $\;
+
+ return print $fh $_[0];
+ },
+ sub {
+ my $tmp;
+ my $count = CORE::read $fh, $tmp, $_[1];
+ defined $count
+ or return undef;
+ $count
+ or return "";
+ return $tmp;
+ },
+ sub {
+ if ($_[1] != SEEK_CUR || $_[0] != 0) {
+ unless (CORE::seek $fh, $_[0], $_[1]) {
+ return -1;
+ }
+ }
+
+ return tell $fh;
+ },
+ undef,
+ );
+ }
+ else {
+ return $class->_new_perlio($fh);
+ }
+}
+
+# backward compatibility for %formats
+package Imager::FORMATS;
+use strict;
+use constant IX_FORMATS => 0;
+use constant IX_LIST => 1;
+use constant IX_INDEX => 2;
+use constant IX_CLASSES => 3;
+
+sub TIEHASH {
+ my ($class, $formats, $classes) = @_;
+
+ return bless [ $formats, [ ], 0, $classes ], $class;
+}
+
+sub _check {
+ my ($self, $key) = @_;
+
+ (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
+ my $value;
+ my $error;
+ my $loaded = Imager::_load_file($file, \$error);
+ if ($loaded) {
+ $value = 1;
+ }
+ else {
+ if ($error =~ /^Can't locate /) {
+ $error = "Can't locate $file";
+ }
+ $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
+ $value = undef;
+ }
+ $self->[IX_FORMATS]{$key} = $value;
+
+ return $value;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+
+ exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
+
+ $self->[IX_CLASSES]{$key} or return undef;
+
+ return $self->_check($key);
+}
+
+sub STORE {
+ die "%Imager::formats is not user monifiable";
+}
+
+sub DELETE {
+ die "%Imager::formats is not user monifiable";
+}
+
+sub CLEAR {
+ die "%Imager::formats is not user monifiable";
+}
+
+sub EXISTS {
+ my ($self, $key) = @_;
+
+ if (exists $self->[IX_FORMATS]{$key}) {
+ my $value = $self->[IX_FORMATS]{$key}
+ or return;
+ return 1;
+ }
+
+ $self->_check($key) or return 1==0;
+
+ return 1==1;
+}
+
+sub FIRSTKEY {
+ my ($self) = @_;
+
+ unless (@{$self->[IX_LIST]}) {
+ # full populate it
+ @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
+ keys %{$self->[IX_FORMATS]};
+
+ for my $key (keys %{$self->[IX_CLASSES]}) {
+ $self->[IX_FORMATS]{$key} and next;
+ $self->_check($key)
+ and push @{$self->[IX_LIST]}, $key;
+ }
+ }
+
+ @{$self->[IX_LIST]} or return;
+ $self->[IX_INDEX] = 1;
+ return $self->[IX_LIST][0];
+}
+
+sub NEXTKEY {
+ my ($self) = @_;
+
+ $self->[IX_INDEX] < @{$self->[IX_LIST]}
+ or return;
+
+ return $self->[IX_LIST][$self->[IX_INDEX]++];
+}
+
+sub SCALAR {
+ my ($self) = @_;
+
+ return scalar @{$self->[IX_LIST]};
+}
+
projects / imager.git / blobdiff