Screenshot.pm

   1 package Imager::Screenshot;
   2 use strict;
   3 use vars qw(@ISA $VERSION @EXPORT_OK);
   4 use Imager;
   5 require Exporter;
   6
   7 push @ISA, 'Exporter';
   8 @EXPORT_OK = 'screenshot';
   9
  10 BEGIN {
  11   require Exporter;
  12   @ISA = qw(Exporter);
  13   $VERSION = '0.002';
  14   eval {
  15     # try XSLoader first, DynaLoader has annoying baggage
  16     require XSLoader;
  17     XSLoader::load('Imager::Screenshot' => $VERSION);
  18     1;
  19   } or do {
  20     require DynaLoader;
  21     push @ISA, 'DynaLoader';
  22     bootstrap Imager::Screenshot $VERSION;
  23   }
  24 }
  25
  26 sub screenshot {
  27   # lose the class if called as a method
  28   @_ % 2 == 1 and shift;
  29
  30   my %opts = (decor => 0, display => 0, @_);
  31
  32   my $result;
  33   if (!@_) {
  34     my $result =
  35       defined &_win32 ? _win32(0) :
  36         defined &_x11 ? _x11($opts{display}, 0) :
  37            die "No drivers enabled\n";
  38   }
  39   if (defined $opts{hwnd}) {
  40     defined &_win32
  41       or die "Win32 driver not enabled\n";
  42     $result = _win32($opts{hwnd}, $opts{decor});
  43   }
  44   elsif (defined $opts{id}) { # X11 window id
  45     defined &_x11
  46       or die "X11 driver not enabled\n";
  47     $result = _x11($opts{display}, $opts{id});
  48   }
  49   elsif ($opts{widget}) {
  50     # Perl/Tk widget
  51     my $top = $opts{widget}->toplevel;
  52     my $sys = $top->windowingsystem;
  53     if ($sys eq 'win32') {
  54       unless (defined &_win32) {
  55         Imager->_set_error("Win32 Tk and Win32 support not built");
  56         return;
  57       }
  58       $result = _win32(hex($opts{widget}->id));
  59     }
  60     elsif ($sys eq 'x11') {
  61       unless (defined &_x11) {
  62         Imager->_set_error("X11 Tk and X11 support not built");
  63         return;
  64       }
  65
  66       my $id_hex = $opts{widget}->id;
  67       $opts{widget}->can('frame')
  68         and $id_hex = $opts{widget}->frame;
  69
  70       # is there a way to get the display pointer from Tk?
  71       $result = _x11(0, hex($id_hex));
  72     }
  73     else {
  74       Imager->_set_error("Unsupported windowing system '$sys'");
  75       return;
  76     }
  77   }
  78
  79   unless ($result) {
  80     Imager->_set_error(Imager->_error_as_msg());
  81     return;
  82   }
  83
  84   return $result;
  85 }
  86
  87 sub have_win32 {
  88   defined &_win32;
  89 }
  90
  91 sub have_x11 {
  92   defined &_x11;
  93 }
  94
  95 sub x11_open {
  96   my $display = _x11_open(@_);
  97   unless ($display) {
  98     Imager->_set_error(Imager->_error_as_msg);
  99     return;
 100   }
 101
 102   return $display;
 103 }
 104
 105 sub x11_close {
 106   _x11_close(shift);
 107 }
 108
 109 1;
 110
 111 __END__
 112
 113 =head1 NAME
 114
 115 Imager::Screenshot - screenshot to an Imager image
 116
 117 =head1 SYNOPSIS
 118
 119   use Imager::Screenshot 'screenshot';
 120
 121   # whole screen
 122   my $img = screenshot();
 123
 124   # Win32 window
 125   my $img2 = screenshot(hwnd => $hwnd);
 126
 127   # X11 window
 128   my $img3 = screenshot(display => $display, id => $window_id);
 129
 130   # X11 tools
 131   my $display = Imager::Screenshot::x11_open();
 132   Imager::Screenshot::x11_close($display);
 133
 134   # test for win32 support
 135   if (Imager::Screenshot->have_win32) { ... }
 136
 137   # test for x11 support
 138   if (Imager::Screenshot->have_x11) { ... }
 139
 140
 141 =head1 DESCRIPTION
 142
 143 Imager::Screenshot captures either a desktop or a specified window and
 144 returns the result as an Imager image.
 145
 146 Currently the image is always returned as a 24-bit image.
 147
 148 =over
 149
 150 =item screenshot hwnd => I<window handle>
 151
 152 =item screenshot hwnd => I<window handle>, decor => <capture decorations>
 153
 154 Retrieve a screenshot under Win32, if I<window handle> is zero,
 155 capture the desktop.
 156
 157 By default, window decorations are not captured, if the C<decor>
 158 parameter is set to true then window decorations are included.
 159
 160 =item screenshot id => I<window id>
 161
 162 =item screenshot id => I<window id>, display => I<display object>
 163
 164 Retrieve a screenshot under X11, if I<id> is zero, capture the root
 165 window.  I<display object> is a integer version of an X11 C< Display *
 166 >, if this isn't supplied C<screenshot()> will attempt connect to the
 167 the display specified by $ENV{DISPLAY}.
 168
 169 Note: taking a screenshot of a remote display is slow.
 170
 171 =item screenshot
 172
 173 If no parameters are supplied:
 174
 175 =over
 176
 177 =item *
 178
 179 if Win32 support is compiled, return screenshot(hwnd => 0).
 180
 181 =item *
 182
 183 if X11 support is compiled, return screenshot(id => 0).
 184
 185 =item *
 186
 187 otherwise, die.
 188
 189 =back
 190
 191 =item have_win32
 192
 193 Returns true if Win32 support is available.
 194
 195 =item have_x11
 196
 197 Returns true if X11 support is available.
 198
 199 =item Imager::Screenshot::x11_open
 200
 201 =item Imager::Screenshot::x11_open I<display name>
 202
 203 Attempts to open a connection to either the display name in
 204 $ENV{DISPLAY} or the supplied display name.  Returns a value suitable
 205 for the I<display> parameter of screenshot, or undef.
 206
 207 =item Imager::Screenshot::x11_close I<display>
 208
 209 Closes a display returned by Imager::Screenshot::x11_open().
 210
 211 =back
 212
 213 =head1 LICENSE
 214
 215 Imager::Screenshot is licensed under the same terms as Perl itself.
 216
 217 =head1 AUTHOR
 218
 219 Tony Cook <tonyc@cpan.org>
 220
 221 =cut
 222
 223