| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package Selenium::Screenshot; | 
| 2 |  |  |  |  |  |  | $Selenium::Screenshot::VERSION = '0.06'; | 
| 3 |  |  |  |  |  |  | # ABSTRACT: Compare and contrast Webdriver screenshots in PNG format | 
| 4 | 1 |  |  | 1 |  | 1311 | use Moo; | 
|  | 1 |  |  |  |  | 11445 |  | 
|  | 1 |  |  |  |  | 6 |  | 
| 5 | 1 |  |  | 1 |  | 1782 | use Image::Compare; | 
|  | 1 |  |  |  |  | 51775 |  | 
|  | 1 |  |  |  |  | 64 |  | 
| 6 | 1 |  |  | 1 |  | 11 | use Imager qw/:handy/; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 12 |  | 
| 7 | 1 |  |  | 1 |  | 176 | use Imager::Color; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 21 |  | 
| 8 | 1 |  |  | 1 |  | 4 | use Imager::Fountain; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 21 |  | 
| 9 | 1 |  |  | 1 |  | 4 | use Carp qw/croak carp confess/; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 55 |  | 
| 10 | 1 |  |  | 1 |  | 3 | use Cwd qw/abs_path/; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 44 |  | 
| 11 | 1 |  |  | 1 |  | 4 | use MIME::Base64; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 45 |  | 
| 12 | 1 |  |  | 1 |  | 5 | use Scalar::Util qw/blessed/; | 
|  | 1 |  |  |  |  | 0 |  | 
|  | 1 |  |  |  |  | 1575 |  | 
| 13 |  |  |  |  |  |  |  | 
| 14 |  |  |  |  |  |  |  | 
| 15 |  |  |  |  |  |  | has png => ( | 
| 16 |  |  |  |  |  |  | is => 'rwp', | 
| 17 |  |  |  |  |  |  | lazy => 1, | 
| 18 |  |  |  |  |  |  | coerce => sub { | 
| 19 |  |  |  |  |  |  | my ($png_or_image) = @_; | 
| 20 |  |  |  |  |  |  |  | 
| 21 |  |  |  |  |  |  | # We are prepared to handle an Imager object, or a base64 | 
| 22 |  |  |  |  |  |  | # encoded png. | 
| 23 |  |  |  |  |  |  | if ( blessed( $png_or_image ) && $png_or_image->isa('Imager')) { | 
| 24 |  |  |  |  |  |  | return $png_or_image; | 
| 25 |  |  |  |  |  |  | } | 
| 26 |  |  |  |  |  |  | else { | 
| 27 |  |  |  |  |  |  | my $data = decode_base64($png_or_image); | 
| 28 |  |  |  |  |  |  | my $image = Imager->new(data => $data); | 
| 29 |  |  |  |  |  |  |  | 
| 30 |  |  |  |  |  |  | if (! $image && Imager->errstr) { | 
| 31 |  |  |  |  |  |  | confess "you must provide a base64 encoded png. We were not able to create an Imager object after base64 decoding your input; Imager's error message was:\n\n" . Imager->errstr; | 
| 32 |  |  |  |  |  |  | } | 
| 33 |  |  |  |  |  |  | else { | 
| 34 |  |  |  |  |  |  | return $image; | 
| 35 |  |  |  |  |  |  | } | 
| 36 |  |  |  |  |  |  | } | 
| 37 |  |  |  |  |  |  | }, | 
| 38 |  |  |  |  |  |  | required => 1 | 
| 39 |  |  |  |  |  |  | ); | 
| 40 |  |  |  |  |  |  |  | 
| 41 |  |  |  |  |  |  |  | 
| 42 |  |  |  |  |  |  | has exclude => ( | 
| 43 |  |  |  |  |  |  | is => 'ro', | 
| 44 |  |  |  |  |  |  | lazy => 1, | 
| 45 |  |  |  |  |  |  | default => sub { [ ] }, | 
| 46 |  |  |  |  |  |  | coerce => sub { | 
| 47 |  |  |  |  |  |  | my ($exclude) = @_; | 
| 48 |  |  |  |  |  |  |  | 
| 49 |  |  |  |  |  |  | foreach my $rect (@{ $exclude }) { | 
| 50 |  |  |  |  |  |  | croak 'Each exclude region must have size and location keys.' | 
| 51 |  |  |  |  |  |  | unless exists $rect->{size} && exists $rect->{location}; | 
| 52 |  |  |  |  |  |  | } | 
| 53 |  |  |  |  |  |  |  | 
| 54 |  |  |  |  |  |  | return $exclude; | 
| 55 |  |  |  |  |  |  | }, | 
| 56 |  |  |  |  |  |  | predicate => 1 | 
| 57 |  |  |  |  |  |  | ); | 
| 58 |  |  |  |  |  |  |  | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | has target => ( | 
| 61 |  |  |  |  |  |  | is => 'ro', | 
| 62 |  |  |  |  |  |  | lazy => 1, | 
| 63 |  |  |  |  |  |  | default => sub { {} }, | 
| 64 |  |  |  |  |  |  | coerce => sub { | 
| 65 |  |  |  |  |  |  | my ($rect) = @_; | 
| 66 |  |  |  |  |  |  |  | 
| 67 |  |  |  |  |  |  | croak 'Each exclude region must have size and location keys.' | 
| 68 |  |  |  |  |  |  | unless exists $rect->{size} && exists $rect->{location}; | 
| 69 |  |  |  |  |  |  |  | 
| 70 |  |  |  |  |  |  | return $rect; | 
| 71 |  |  |  |  |  |  | }, | 
| 72 |  |  |  |  |  |  | predicate => 1 | 
| 73 |  |  |  |  |  |  | ); | 
| 74 |  |  |  |  |  |  |  | 
| 75 |  |  |  |  |  |  |  | 
| 76 |  |  |  |  |  |  | # TODO: add threshold tests | 
| 77 |  |  |  |  |  |  | # TODO: provide reference images | 
| 78 |  |  |  |  |  |  |  | 
| 79 |  |  |  |  |  |  | has threshold => ( | 
| 80 |  |  |  |  |  |  | is => 'ro', | 
| 81 |  |  |  |  |  |  | lazy => 1, | 
| 82 |  |  |  |  |  |  | coerce => sub { | 
| 83 |  |  |  |  |  |  | my ($threshold) = @_; | 
| 84 |  |  |  |  |  |  |  | 
| 85 |  |  |  |  |  |  | my $scaling = 255 * sqrt(3) / 100; | 
| 86 |  |  |  |  |  |  | return $threshold * $scaling; | 
| 87 |  |  |  |  |  |  | }, | 
| 88 |  |  |  |  |  |  | default => sub { 5 } | 
| 89 |  |  |  |  |  |  | ); | 
| 90 |  |  |  |  |  |  |  | 
| 91 |  |  |  |  |  |  |  | 
| 92 |  |  |  |  |  |  | has folder => ( | 
| 93 |  |  |  |  |  |  | is => 'rw', | 
| 94 |  |  |  |  |  |  | coerce => sub { | 
| 95 |  |  |  |  |  |  | my ($folder) = @_; | 
| 96 |  |  |  |  |  |  | $folder //= 'screenshots/'; | 
| 97 |  |  |  |  |  |  | mkdir $folder unless -d $folder; | 
| 98 |  |  |  |  |  |  |  | 
| 99 |  |  |  |  |  |  | return abs_path($folder) . '/'; | 
| 100 |  |  |  |  |  |  | }, | 
| 101 |  |  |  |  |  |  | default => sub { 'screenshots/' } | 
| 102 |  |  |  |  |  |  | ); | 
| 103 |  |  |  |  |  |  |  | 
| 104 |  |  |  |  |  |  |  | 
| 105 |  |  |  |  |  |  | has metadata => ( | 
| 106 |  |  |  |  |  |  | is => 'ro', | 
| 107 |  |  |  |  |  |  | lazy => 1, | 
| 108 |  |  |  |  |  |  | default => sub { {} }, | 
| 109 |  |  |  |  |  |  | predicate => 'has_metadata' | 
| 110 |  |  |  |  |  |  | ); | 
| 111 |  |  |  |  |  |  |  | 
| 112 |  |  |  |  |  |  | has _cmp => ( | 
| 113 |  |  |  |  |  |  | is => 'ro', | 
| 114 |  |  |  |  |  |  | lazy => 1, | 
| 115 |  |  |  |  |  |  | init_arg => undef, | 
| 116 |  |  |  |  |  |  | builder => sub { | 
| 117 | 0 |  |  | 0 |  | 0 | my ($self) = @_; | 
| 118 | 0 |  |  |  |  | 0 | my $cmp = Image::Compare->new; | 
| 119 |  |  |  |  |  |  |  | 
| 120 | 0 | 0 |  |  |  | 0 | if ($self->has_target) { | 
| 121 | 0 |  |  |  |  | 0 | my $png = $self->_img_target($self->png); | 
| 122 | 0 |  |  |  |  | 0 | $self->_set_png($png); | 
| 123 |  |  |  |  |  |  | } | 
| 124 |  |  |  |  |  |  |  | 
| 125 | 0 | 0 |  |  |  | 0 | if ($self->has_exclude) { | 
| 126 | 0 |  |  |  |  | 0 | my $png = $self->_img_exclude($self->png); | 
| 127 | 0 |  |  |  |  | 0 | $self->_set_png($png); | 
| 128 |  |  |  |  |  |  | } | 
| 129 |  |  |  |  |  |  |  | 
| 130 |  |  |  |  |  |  | $cmp->set_image1( | 
| 131 | 0 |  |  |  |  | 0 | img => $self->png, | 
| 132 |  |  |  |  |  |  | type => 'png' | 
| 133 |  |  |  |  |  |  | ); | 
| 134 |  |  |  |  |  |  |  | 
| 135 | 0 |  |  |  |  | 0 | return $cmp; | 
| 136 |  |  |  |  |  |  | } | 
| 137 |  |  |  |  |  |  | ); | 
| 138 |  |  |  |  |  |  |  | 
| 139 |  |  |  |  |  |  | with 'Selenium::Screenshot::CanPad'; | 
| 140 |  |  |  |  |  |  |  | 
| 141 |  |  |  |  |  |  |  | 
| 142 |  |  |  |  |  |  | sub compare { | 
| 143 | 0 |  |  | 0 | 1 | 0 | my ($self, $opponent) = @_; | 
| 144 | 0 |  |  |  |  | 0 | $opponent = $self->_set_opponent($opponent); | 
| 145 |  |  |  |  |  |  |  | 
| 146 | 0 | 0 |  |  |  | 0 | if (not defined $opponent) { | 
| 147 | 0 |  |  |  |  | 0 | carp 'No reference was provided or found, so no comparison was done. We\'ve saved a reference at ' . $self->reference; | 
| 148 | 0 |  |  |  |  | 0 | return $self->save_reference; | 
| 149 |  |  |  |  |  |  | } | 
| 150 |  |  |  |  |  |  | else { | 
| 151 | 0 |  |  |  |  | 0 | $self->_cmp->set_method( | 
| 152 |  |  |  |  |  |  | method => &Image::Compare::AVG_THRESHOLD, | 
| 153 |  |  |  |  |  |  | args   => { | 
| 154 |  |  |  |  |  |  | type  => &Image::Compare::AVG_THRESHOLD::MEAN, | 
| 155 |  |  |  |  |  |  | value => $self->threshold, | 
| 156 |  |  |  |  |  |  | } | 
| 157 |  |  |  |  |  |  | ); | 
| 158 |  |  |  |  |  |  |  | 
| 159 | 0 |  |  |  |  | 0 | return $self->_cmp->compare; | 
| 160 |  |  |  |  |  |  | } | 
| 161 |  |  |  |  |  |  | } | 
| 162 |  |  |  |  |  |  |  | 
| 163 |  |  |  |  |  |  |  | 
| 164 |  |  |  |  |  |  | sub difference { | 
| 165 | 0 |  |  | 0 | 1 | 0 | my ($self, $opponent) = @_; | 
| 166 | 0 |  |  |  |  | 0 | $opponent = $self->_set_opponent($opponent); | 
| 167 |  |  |  |  |  |  |  | 
| 168 |  |  |  |  |  |  | # We want to range from transparent (no difference) to fuschia at | 
| 169 |  |  |  |  |  |  | # 100% change. | 
| 170 | 0 |  |  |  |  | 0 | my $white = Imager::Color->new(255, 255, 255); | 
| 171 | 0 |  |  |  |  | 0 | my $fuschia = Imager::Color->new(240,  18, 190); | 
| 172 | 0 |  |  |  |  | 0 | my $scale = Imager::Fountain->simple( | 
| 173 |  |  |  |  |  |  | positions => [    0.0,      1.0 ], | 
| 174 |  |  |  |  |  |  | colors    => [ $white, $fuschia ] | 
| 175 |  |  |  |  |  |  | ); | 
| 176 |  |  |  |  |  |  |  | 
| 177 | 0 |  |  |  |  | 0 | $self->_cmp->set_method( | 
| 178 |  |  |  |  |  |  | method => &Image::Compare::IMAGE, | 
| 179 |  |  |  |  |  |  | args => $scale | 
| 180 |  |  |  |  |  |  | ); | 
| 181 |  |  |  |  |  |  |  | 
| 182 |  |  |  |  |  |  | # Do the actual pixel by pixel comparison. This can take a while. | 
| 183 | 0 |  |  |  |  | 0 | my $diff = $self->_cmp->compare; | 
| 184 |  |  |  |  |  |  |  | 
| 185 |  |  |  |  |  |  | # Post processing to overlay the difference onto the | 
| 186 |  |  |  |  |  |  | # opponent. First, subtract a white box from our difference image; | 
| 187 |  |  |  |  |  |  | # to make everything white transparent instead. | 
| 188 | 0 |  |  |  |  | 0 | my $work = Imager->new( | 
| 189 |  |  |  |  |  |  | xsize    => $diff->getwidth, | 
| 190 |  |  |  |  |  |  | ysize    => $diff->getheight, | 
| 191 |  |  |  |  |  |  | channels => $diff->getchannels | 
| 192 |  |  |  |  |  |  | ); | 
| 193 | 0 |  |  |  |  | 0 | $work->box(filled => 1, color => $white ); | 
| 194 | 0 |  |  |  |  | 0 | $diff = $work->difference(other => $diff); | 
| 195 |  |  |  |  |  |  |  | 
| 196 |  |  |  |  |  |  | # Place the transparent diff image on top of our opponent - | 
| 197 |  |  |  |  |  |  | # anything changed will show up on top of the opponent image in | 
| 198 |  |  |  |  |  |  | # varying degrees of pink. | 
| 199 | 0 |  |  |  |  | 0 | $opponent->compose(src => $diff); | 
| 200 |  |  |  |  |  |  |  | 
| 201 | 0 |  |  |  |  | 0 | my $name = $self->_diff_filename; | 
| 202 | 0 |  |  |  |  | 0 | $opponent->write(file => $name); | 
| 203 |  |  |  |  |  |  |  | 
| 204 | 0 |  |  |  |  | 0 | return $name; | 
| 205 |  |  |  |  |  |  | } | 
| 206 |  |  |  |  |  |  |  | 
| 207 |  |  |  |  |  |  |  | 
| 208 |  |  |  |  |  |  | sub find_opponent { | 
| 209 | 0 |  |  | 0 | 1 | 0 | my ($self) = @_; | 
| 210 |  |  |  |  |  |  |  | 
| 211 | 0 |  |  |  |  | 0 | my $default_reference = $self->reference; | 
| 212 | 0 | 0 |  |  |  | 0 | if (-e $default_reference) { | 
| 213 | 0 |  |  |  |  | 0 | return Imager->new(file => $default_reference); | 
| 214 |  |  |  |  |  |  | } | 
| 215 |  |  |  |  |  |  | } | 
| 216 |  |  |  |  |  |  |  | 
| 217 |  |  |  |  |  |  | sub _diff_filename { | 
| 218 | 0 |  |  | 0 |  | 0 | my ($self) = @_; | 
| 219 |  |  |  |  |  |  |  | 
| 220 | 0 |  |  |  |  | 0 | my $diff = $self->filename; | 
| 221 | 0 |  |  |  |  | 0 | $diff =~ s/\.png$/-diff.png/; | 
| 222 |  |  |  |  |  |  |  | 
| 223 | 0 |  |  |  |  | 0 | return $diff; | 
| 224 |  |  |  |  |  |  | } | 
| 225 |  |  |  |  |  |  |  | 
| 226 |  |  |  |  |  |  | sub _set_opponent { | 
| 227 | 0 |  |  | 0 |  | 0 | my ($self, $opponent) = @_; | 
| 228 | 0 |  | 0 |  |  | 0 | $opponent //= $self->find_opponent; | 
| 229 |  |  |  |  |  |  |  | 
| 230 |  |  |  |  |  |  | # No opponent was provided, and we can't find one. | 
| 231 | 0 | 0 |  |  |  | 0 | return unless $opponent; | 
| 232 |  |  |  |  |  |  |  | 
| 233 | 0 |  |  |  |  | 0 | $opponent = $self->_extract_image( $opponent ); | 
| 234 |  |  |  |  |  |  |  | 
| 235 |  |  |  |  |  |  | # Before setting this $opponent as our image2, we must ensure that | 
| 236 |  |  |  |  |  |  | # our $self->png image and this $opponent are the same size. | 
| 237 | 0 | 0 |  |  |  | 0 | if (! $self->cmp_image_dims( $self->png, $opponent )) { | 
| 238 | 0 |  |  |  |  | 0 | my ($new_png, $new_opp) = $self->coerce_image_size( $self->png, $opponent ); | 
| 239 | 0 |  |  |  |  | 0 | $self->_set_png( $new_png ); | 
| 240 | 0 |  |  |  |  | 0 | $opponent = $new_opp; | 
| 241 |  |  |  |  |  |  | } | 
| 242 |  |  |  |  |  |  |  | 
| 243 | 0 | 0 |  |  |  | 0 | $opponent = $self->_img_target( $opponent ) if $self->has_target; | 
| 244 | 0 | 0 |  |  |  | 0 | $opponent = $self->_img_exclude( $opponent ) if $self->has_exclude; | 
| 245 |  |  |  |  |  |  |  | 
| 246 | 0 |  |  |  |  | 0 | $self->_cmp->set_image2( img => $opponent ); | 
| 247 |  |  |  |  |  |  |  | 
| 248 | 0 |  |  |  |  | 0 | return $opponent; | 
| 249 |  |  |  |  |  |  | } | 
| 250 |  |  |  |  |  |  |  | 
| 251 |  |  |  |  |  |  |  | 
| 252 |  |  |  |  |  |  | sub filename { | 
| 253 | 3 |  |  | 3 | 1 | 36 | my ($self, %overrides) = @_; | 
| 254 |  |  |  |  |  |  |  | 
| 255 | 3 |  |  |  |  | 4 | my @filename_parts; | 
| 256 | 3 | 100 | 66 |  |  | 16 | if ($self->has_metadata or %overrides) { | 
| 257 |  |  |  |  |  |  | my $metadata = { | 
| 258 | 2 |  |  |  |  | 3 | %{ $self->metadata}, | 
|  | 2 |  |  |  |  | 21 |  | 
| 259 |  |  |  |  |  |  | %overrides | 
| 260 |  |  |  |  |  |  | }; | 
| 261 |  |  |  |  |  |  |  | 
| 262 | 2 |  |  |  |  | 402 | foreach (sort keys %{ $metadata }) { | 
|  | 2 |  |  |  |  | 7 |  | 
| 263 | 2 |  |  |  |  | 6 | push @filename_parts, $self->_sanitize_string($metadata->{$_}); | 
| 264 |  |  |  |  |  |  | } | 
| 265 |  |  |  |  |  |  | } | 
| 266 |  |  |  |  |  |  | else { | 
| 267 | 1 |  |  |  |  | 21 | push @filename_parts, time | 
| 268 |  |  |  |  |  |  | } | 
| 269 |  |  |  |  |  |  |  | 
| 270 | 3 |  |  |  |  | 38 | my $filename = $self->folder . join('-', @filename_parts) . '.png'; | 
| 271 | 3 |  |  |  |  | 478 | $filename =~ s/\-+/-/g; | 
| 272 | 3 |  |  |  |  | 10 | return $filename; | 
| 273 |  |  |  |  |  |  | } | 
| 274 |  |  |  |  |  |  |  | 
| 275 |  |  |  |  |  |  |  | 
| 276 |  |  |  |  |  |  | sub reference { | 
| 277 | 0 |  |  | 0 | 1 | 0 | my ($self) = @_; | 
| 278 |  |  |  |  |  |  |  | 
| 279 | 0 |  |  |  |  | 0 | my $default_reference = $self->filename; | 
| 280 | 0 |  |  |  |  | 0 | $default_reference =~ s/\.png$/-reference.png/; | 
| 281 |  |  |  |  |  |  |  | 
| 282 | 0 |  |  |  |  | 0 | return $default_reference; | 
| 283 |  |  |  |  |  |  | } | 
| 284 |  |  |  |  |  |  |  | 
| 285 |  |  |  |  |  |  |  | 
| 286 |  |  |  |  |  |  | sub save { | 
| 287 | 0 |  |  | 0 | 1 | 0 | my ($self, %overrides) = @_; | 
| 288 |  |  |  |  |  |  |  | 
| 289 | 0 |  |  |  |  | 0 | my $png = $self->png; | 
| 290 | 0 |  |  |  |  | 0 | my $filename =  $self->filename(%overrides); | 
| 291 | 0 |  |  |  |  | 0 | $png->write(file => $filename); | 
| 292 |  |  |  |  |  |  |  | 
| 293 | 0 |  |  |  |  | 0 | return $filename; | 
| 294 |  |  |  |  |  |  | } | 
| 295 |  |  |  |  |  |  |  | 
| 296 |  |  |  |  |  |  |  | 
| 297 |  |  |  |  |  |  | sub save_reference { | 
| 298 | 0 |  |  | 0 | 1 | 0 | my ($self) = @_; | 
| 299 |  |  |  |  |  |  |  | 
| 300 | 0 |  |  |  |  | 0 | my $png = $self->png; | 
| 301 | 0 |  |  |  |  | 0 | $png->write(file => $self->reference); | 
| 302 |  |  |  |  |  |  |  | 
| 303 | 0 |  |  |  |  | 0 | return $self->reference; | 
| 304 |  |  |  |  |  |  | } | 
| 305 |  |  |  |  |  |  |  | 
| 306 |  |  |  |  |  |  | sub _img_exclude { | 
| 307 | 0 |  |  | 0 |  | 0 | my ($self, $img, $exclude) = @_; | 
| 308 | 0 |  | 0 |  |  | 0 | $exclude //= $self->exclude; | 
| 309 |  |  |  |  |  |  |  | 
| 310 | 0 |  |  |  |  | 0 | my $copy = $img->copy; | 
| 311 |  |  |  |  |  |  |  | 
| 312 | 0 |  |  |  |  | 0 | foreach my $rect (@{ $exclude }) { | 
|  | 0 |  |  |  |  | 0 |  | 
| 313 | 0 |  |  |  |  | 0 | my ($size, $loc) = ($rect->{size}, $rect->{location}); | 
| 314 |  |  |  |  |  |  |  | 
| 315 |  |  |  |  |  |  | # skip items that don't have the valid keys | 
| 316 | 0 | 0 | 0 |  |  | 0 | unless (exists $loc->{x} | 
|  |  |  | 0 |  |  |  |  | 
|  |  |  | 0 |  |  |  |  | 
| 317 |  |  |  |  |  |  | && exists $loc->{y} | 
| 318 |  |  |  |  |  |  | && exists $size->{width} | 
| 319 |  |  |  |  |  |  | && exists $size->{height}) { | 
| 320 | 0 |  |  |  |  | 0 | next; | 
| 321 |  |  |  |  |  |  | } | 
| 322 |  |  |  |  |  |  |  | 
| 323 |  |  |  |  |  |  | my $top_left = { | 
| 324 |  |  |  |  |  |  | x => $loc->{x}, | 
| 325 |  |  |  |  |  |  | y => $loc->{y} | 
| 326 | 0 |  |  |  |  | 0 | }; | 
| 327 |  |  |  |  |  |  |  | 
| 328 |  |  |  |  |  |  | my $bottom_right = { | 
| 329 |  |  |  |  |  |  | x => $loc->{x} + $size->{width}, | 
| 330 |  |  |  |  |  |  | y => $loc->{y} + $size->{height} | 
| 331 | 0 |  |  |  |  | 0 | }; | 
| 332 |  |  |  |  |  |  |  | 
| 333 |  |  |  |  |  |  | $copy->box( | 
| 334 |  |  |  |  |  |  | xmin => $top_left->{x}, | 
| 335 |  |  |  |  |  |  | ymin => $top_left->{y}, | 
| 336 |  |  |  |  |  |  | xmax => $bottom_right->{x}, | 
| 337 |  |  |  |  |  |  | ymax => $bottom_right->{y}, | 
| 338 | 0 |  |  |  |  | 0 | filled => 1, | 
| 339 |  |  |  |  |  |  | color => 'black' | 
| 340 |  |  |  |  |  |  | ); | 
| 341 |  |  |  |  |  |  | } | 
| 342 |  |  |  |  |  |  |  | 
| 343 | 0 |  |  |  |  | 0 | return $copy; | 
| 344 |  |  |  |  |  |  | } | 
| 345 |  |  |  |  |  |  |  | 
| 346 |  |  |  |  |  |  | sub _img_target { | 
| 347 | 0 |  |  | 0 |  | 0 | my ($self, $img, $target) = @_; | 
| 348 | 0 |  | 0 |  |  | 0 | $target //= $self->target; | 
| 349 |  |  |  |  |  |  |  | 
| 350 | 0 |  |  |  |  | 0 | my ($size, $loc) = ($target->{size}, $target->{location}); | 
| 351 |  |  |  |  |  |  |  | 
| 352 | 0 | 0 | 0 |  |  | 0 | unless (exists $loc->{x} | 
|  |  |  | 0 |  |  |  |  | 
|  |  |  | 0 |  |  |  |  | 
| 353 |  |  |  |  |  |  | && exists $loc->{y} | 
| 354 |  |  |  |  |  |  | && exists $size->{width} | 
| 355 |  |  |  |  |  |  | && exists $size->{height}) { | 
| 356 | 0 |  |  |  |  | 0 | next; | 
| 357 |  |  |  |  |  |  | } | 
| 358 |  |  |  |  |  |  |  | 
| 359 | 0 |  |  |  |  | 0 | my $left = $loc->{x}; | 
| 360 | 0 |  |  |  |  | 0 | my $top = $loc->{y}; | 
| 361 | 0 |  |  |  |  | 0 | my $right = $left + $size->{width}; | 
| 362 | 0 |  |  |  |  | 0 | my $bottom = $top + $size->{height}; | 
| 363 |  |  |  |  |  |  |  | 
| 364 |  |  |  |  |  |  | # copy returns the cropped image, unlike box | 
| 365 | 0 |  |  |  |  | 0 | return $img->crop( | 
| 366 |  |  |  |  |  |  | left => $left, | 
| 367 |  |  |  |  |  |  | top => $top, | 
| 368 |  |  |  |  |  |  | right => $right, | 
| 369 |  |  |  |  |  |  | bottom => $bottom | 
| 370 |  |  |  |  |  |  | ); | 
| 371 |  |  |  |  |  |  | } | 
| 372 |  |  |  |  |  |  |  | 
| 373 |  |  |  |  |  |  | sub _sanitize_string { | 
| 374 | 2 |  |  | 2 |  | 3 | my ($self, $dirty_string) = @_; | 
| 375 |  |  |  |  |  |  |  | 
| 376 | 2 |  |  |  |  | 5 | $dirty_string =~ s/[^A-z0-9\.\-]/-/g; | 
| 377 | 2 |  |  |  |  | 5 | return $dirty_string; | 
| 378 |  |  |  |  |  |  | } | 
| 379 |  |  |  |  |  |  |  | 
| 380 |  |  |  |  |  |  | sub _extract_image { | 
| 381 | 0 |  |  | 0 |  |  | my ($self, $file_or_image) = @_; | 
| 382 |  |  |  |  |  |  |  | 
| 383 | 0 |  |  |  |  |  | my $err_msg = 'We were expecting one of: a filename, Imager object, or Selenium::Screenshot object'; | 
| 384 | 0 | 0 |  |  |  |  | croak $err_msg unless defined $file_or_image; | 
| 385 |  |  |  |  |  |  |  | 
| 386 | 0 | 0 |  |  |  |  | if ( blessed( $file_or_image ) ) { | 
| 387 | 0 | 0 |  |  |  |  | if ($file_or_image->isa('Selenium::Screenshot')) { | 
|  |  | 0 |  |  |  |  |  | 
| 388 | 0 |  |  |  |  |  | return $file_or_image->png; | 
| 389 |  |  |  |  |  |  | } | 
| 390 |  |  |  |  |  |  | elsif ($file_or_image->isa('Imager')) { | 
| 391 | 0 |  |  |  |  |  | return $file_or_image; | 
| 392 |  |  |  |  |  |  | } | 
| 393 |  |  |  |  |  |  | else { | 
| 394 | 0 |  |  |  |  |  | croak $err_msg; | 
| 395 |  |  |  |  |  |  | } | 
| 396 |  |  |  |  |  |  | } | 
| 397 |  |  |  |  |  |  | else { | 
| 398 | 0 |  |  |  |  |  | return Imager->new(file => $file_or_image); | 
| 399 |  |  |  |  |  |  | } | 
| 400 |  |  |  |  |  |  | } | 
| 401 |  |  |  |  |  |  |  | 
| 402 |  |  |  |  |  |  |  | 
| 403 |  |  |  |  |  |  | 1; | 
| 404 |  |  |  |  |  |  |  | 
| 405 |  |  |  |  |  |  | __END__ |