File Coverage

blib/lib/Acme/Steganography/Image/Png.pm

Criterion	Covered	Total	%
statement	116	199	58.2
branch	15	30	50.0
condition	5	9	55.5
subroutine	21	28	75.0
pod	1	7	14.2
total	158	273	57.8

package Acme::Steganography::Image::Png;

use strict;
use vars qw($VERSION @ISA);

use Imager;
require Class::Accessor;
use Carp;

@ISA = qw(Class::Accessor);

$VERSION = '0.06';

my @keys = qw(offset data section x y datum_length done filename_generator
	      suffix);

# What arguments can we accept to the constructor.
# Am I reinventing the wheel here?
my %keys;
@keys{@keys} = ();

sub _keys {
  return \%keys;
}

Acme::Steganography::Image::Png->mk_accessors(@keys);

# This will get refactored out at some point to support other formats.
sub generate_header {
    my ($self) = shift;
    my $section = $self->section;

    my $header = pack 'w', $section;
    if (!$section) {
	$header .= pack 'w', length ${$self->data};
    }
    $header;
}

sub default_filename_generator {
  my $state = shift;
  $state ||= 0;
  my $new_state = $state+1;
  # really unimaginative filenames by default
  ($state, $new_state);
}

package Acme::Steganography::Image::Png::FlashingNeonSignGrey;

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

# Raw data as a greyscale PNG

sub make_image {
  my $self = shift;
  my $img = new Imager;
  $img->read(data=>$_[0], type => 'raw', xsize => $self->x,
	     ysize => $self->y, datachannels=>1, storechannels=>1, bits=>8);
  $img;
}

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

sub extract_payload {
  my ($class, $img) = @_;
  my $datum;
  $img->write(data=> \$datum, type => 'raw');
  $datum;
}

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

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;

  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;

  for (my $offset = 0; $offset < $end; ++$offset) {
    my ($red, $green, $blue) = unpack 'x' . ($offset * 3) . 'C3', $raw;
    my $datum = (($red & 0x7) << 5) | (($green & 0x3) << 3) | ($blue & 0x7);
    $data .= chr $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 C", $_[0];
    my $rgb = substr ($raw, $offset * 3, 3);
    # Pack 8 bits into the low bits of R G and B
    $rgb &= "\xF8\xFC\xF8";
    $rgb |= ("\x07\x03\x07" & pack 'C3', $datum >> 5, $datum >> 3, $datum);
    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;
}

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

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

# Raw data in the low bits of a colour image

sub write_images {
  my $self = shift;
  my $victim = shift;

  my $img;
  if (ref($victim) && $victim->isa('Imager')) {
    $img = $victim;
  } else {
    $img = new Imager;
    $img->open(file=>$victim, type=>'jpeg') or croak($img->errstr);
  }


  $self->x($img->getwidth());
  $self->y($img->getheight());

  my $raw;
  $img->write(data=> \$raw, type => 'raw')
    or croak($img->errstr);

  $self->raw($raw);

  $self->SUPER::write_images;
}
package Acme::Steganography::Image::Png;

sub generate_next_image {
    my ($self) = shift;
    my $datum = $self->generate_header;
    my $offset = $self->offset;
    my $datum_length = $self->datum_length;
    # Fill our blob of data to the correct length
    my $grab = $datum_length - length $datum;
    $datum .= substr ${$self->data()}, $offset, $grab;
    $self->offset($offset + $grab);

    if (length $datum < $datum_length) {
      # Need to pad it. NUL is so uninspiring.
      $datum .= "N" x ($datum_length - length $datum);
      $self->done(1);
    } elsif (length ${$self->data()} == $self->offset) {
      warn length $datum;
    }
    $self->section($self->section + 1);

    $self->make_image($datum);
}

sub new {
  my $class = shift;
  croak "Use a classname, not a reference for " . __PACKAGE__ . "::new"
    if ref $class;
  my $self = bless {}, $class;
  my %args = @_;
  my $acceptable = $self->_keys();
  foreach (keys %args) {
    croak "Unknown parameter $_" unless exists $acceptable->{$_};
    $self->set($_, $args{$_});
  }
  $self->x(352) unless $args{x};
  $self->y(288) unless $args{y};

  # Kowtow to the metadata bodging into filenames world
  $self->suffix('.png');

  $self;
}

sub type {
  'png';
}

sub write_images {
  my $self = shift;
  $self->section(0);
  $self->offset(0);
  $self->datum_length($self->calculate_datum_length());
  my $type = $self->type;
  my $filename_generator
    = $self->filename_generator || \&default_filename_generator;

  my @filenames;

  my ($filename, $state);
  while (!$self->done()) {
    my $image = $self->generate_next_image;
    ($filename, $state) = &$filename_generator($state);
    $filename .= $self->suffix;
    $image->write(file => $filename, type=> $type);
    push @filenames, $filename;
  }
  @filenames;
}

# package method
sub read_files {
  my $class = shift;
  # This is intentionally a "sparse" array to avoid some "interesting" DOS
  # possibilities.
  my $length;
  my %got;
  foreach my $file (@_) {
    my $img = new Imager;
    $img->open(file => $file) or carp "Can't read '$file': " . $img->errstr;
    my $payload = $class->extract_payload($img);
    my $datum;
    my $section;
    ($section, $datum) = unpack "wa*", $payload;
    if ($section == 0) {
      # Oops. Strip off the length.
      ($length, $datum) = unpack "wa*", $datum;
    }
    $got{$section} = $datum;
  }
  carp "Did not find first section in files @_" unless defined $length;

  my $data = join '', map {$got{$_}} sort {$a <=> $b} keys %got;
  substr ($data, $length) = '';

  $data;
}

1;
__END__