view release on metacpan or  search on metacpan

Png.pm  view on Meta::CPAN

sub extract_payload {
  my ($class, $img) = @_;
  my ($raw, $data);
  $img->write(data=> \$raw, type => 'raw');
  my $end = length ($raw)/3;

  for (my $offset = 0; $offset < $end; ++$offset) {
    my ($red, $green, $blue) = unpack 'x' . ($offset * 3) . 'C3', $raw;
    my $datum = (($red & 0x1F) << 11) | (($green & 0x1F) << 6) | ($blue & 0x3F);
    $data .= pack 'n', $datum;
  }
  $data;
}

sub make_image {
  my $self = shift;
  # We get a copy to play with
  my $raw = $self->raw;
  my $offset = length ($raw)/3;
  my $img = new Imager;

  while ($offset--) {
    my $datum = unpack 'x' . ($offset * 2) . 'n', $_[0];
    my $rgb = substr ($raw, $offset * 3, 3);
    # Pack 16 bits into the low bits of R G and B
    $rgb &= "\xE0\xE0\xC0";
    $rgb |= pack 'C3', $datum >> 11, ($datum >> 6) & 0x1F, $datum & 0x3F;
    substr($raw, $offset * 3, 3, $rgb);
  }
  $img->read(data=>$raw, type => 'raw', xsize => $self->x,
	     ysize => $self->y, datachannels => 3,interleave => 0);
  $img;
}

sub calculate_datum_length {
  my $self = shift;
  $self->x * $self->y * 2;
}

package Acme::Steganography::Image::Png::RGB::556FS;

use vars '@ISA';
@ISA = 'Acme::Steganography::Image::Png::RGB::556';

# Raw data in the low bits of a colour image, with Floyd-Steinberg dithering
# to spread the errors around. Share and enjoy, share and enjoy.

sub make_image {
  my $self = shift;
  # We get a copy to play with
  my $raw = $self->raw;
  my $img = new Imager;
  my $next_row;

  my $xsize = $self->x;
  my $ysize = $self->y;

  for (my $y = $ysize; $y-- > 0; ) {
    # New row
    my $this_row = $next_row;
    undef $next_row;

    for (my $x = $xsize; $x-- > 0; ) {
      my $offset = $y * $xsize + $x;

      # I'm not sure if I've got the algorithm correct.
      my $datum = unpack 'x' . ($offset * 2) . 'n', $_[0];

      my @rgb = unpack 'x' . ($offset * 3) . 'C3', $raw;
      foreach (0..2) {
	$rgb[$_] += $this_row->[$x + 1][$_] || 0;
	# And this is most definitely an empirical hack, as there seem to be
	# big systematic problems if the errors drive things outside the range
	# 0-255
	if ($rgb[$_] > 255) {
	  $rgb[$_] = 255;
	} elsif ($rgb[$_] < 0) {
	  $rgb[$_] = 0;
	}
      }
      # What we'd ideally have liked to output
      my @rgb_ideal = @rgb;
      # Pack 16 bits into the low bits of R G and B
      $rgb[0] = ($rgb[0] & 0xE0) | $datum >> 11;
      $rgb[1] = ($rgb[1] & 0xE0) | (($datum >> 6) & 0x1F);
      $rgb[2] = ($rgb[2] & 0xC0) | ($datum & 0x3F);
      substr($raw, $offset * 3, 3, pack 'C3', @rgb);

      # Calculate the error and dither it
      # 7 x
      # 1 5 3
      # Note that the backwards dithering is why we need the +1 on the co-ords.
      foreach (0..2) {
	my $error = ($rgb_ideal[$_] - $rgb[$_]) / 16;
	$this_row->[$x][$_] += $error * 7;
	$next_row->[$x + 2][$_] += $error * 3;
	$next_row->[$x + 1][$_] += $error * 5;
	$next_row->[$x][$_] += $error;
      }
    }
  }

  $img->read(data=>$raw, type => 'raw', xsize => $xsize,
	     ysize => $ysize, datachannels => 3,interleave => 0);
  $img;
}

package Acme::Steganography::Image::Png::RGB::323;

use vars '@ISA';
@ISA = 'Acme::Steganography::Image::Png::RGB';

# Raw data in the low bits of a colour image

Acme::Steganography::Image::Png->mk_accessors('raw');

sub extract_payload {
  my ($class, $img) = @_;
  my ($raw, $data);
  $img->write(data=> \$raw, type => 'raw');
  my $end = length ($raw)/3;