File Coverage

blib/lib/CAD/Format/STL.pm

Criterion	Covered	Total	%
statement	131	189	69.3
branch	36	84	42.8
condition	7	15	46.6
subroutine	17	23	73.9
pod	9	9	100.0
total	200	320	62.5

package CAD::Format::STL;
$VERSION = v0.2.1;

use warnings;
use strict;
use Carp;

use CAD::Format::STL::part;

=head1 NAME

CAD::Format::STL - read/write 3D stereolithography files

=head1 SYNOPSIS

Reading:

  my $stl = CAD::Format::STL->new->load("foo.stl");
  # what about the part/multipart?
  my @facets = $stl->part->facets;

Writing:

  my $stl = CAD::Format::STL->new;
  my $part = $stl->add_part("my part");
  $part->add_facets(@faces);
  $stl->save("foo.stl");
  # or $stl->save(binary => "foo.stl");

Streaming read/write:

  my $reader = CAD::Format::STL->reader("foo.stl");
  my $writer = CAD::Format::STL->writer(binary => "bar.stl");
  while(my $part = $reader->next_part) {
    my $part_name = $part->name;
    $writer->start_solid($part_name);
    while(my @data = $part->facet) {
      my ($normal, @vertices) = @data;
      my @v1 = @{$vertices[0]};
      my @v2 = @{$vertices[0]};
      my @v3 = @{$vertices[0]};
      # that's just for illustration
      $writer->facet(\@v1, \@v2, \@v3);
      # note the omitted normal
    }
    $writer->end_solid;
  }

=begin design

The reader auto-detects whether it is binary (but assumes ascii when
seek can't go backwards.)

The reader and writer both take 1, 2, or {1,2}+2n arguments.

This package and/or the reader/writer are subclassable (though getting
$self->reader to instantiate a subclass implies that you have subclassed
$self.)

A cached_facet (or raw_facet) method is necessary to ensure uniform
tranformation of shared points (and optimize the computation.)  This
would return the normal and points as a list of scalars rather than
arrays, with a later call to unpack_point() or something.  The caller
needs to be able to handle the caching (or else there is a callback for
non-cached (or an override for unpack_point().)

Maybe $self->set_writer() and set_reader() immutable object methods?

=end design

=head1 ABOUT

This module provides object-oriented methods to read and write the STL
(Stereo Lithography) file format in both binary and ASCII forms.  The
STL format is a simple set of 3D triangles.

=cut

use Class::Accessor::Classy;
lo 'parts';
no  Class::Accessor::Classy;

=head1 Constructor

=head2 new

  my $stl = CAD::Format::STL->new;

=cut

sub new {
  my $package = shift;
  my $class = ref($package) || $package;
  my $self = {parts => []};
  bless($self, $class);
  return($self);
} # end subroutine new definition
########################################################################

=head2 add_part

Create a new part in the stl.

  my $part = $stl->add_part("name");

Optionally, add the faces directly:

  my $part = $stl->add_part("name", @faces);

=cut

sub add_part {
  my $self = shift;
  my ($name, @faces) = @_;

  my $part = CAD::Format::STL::part->new($name, @faces);
  push(@{$self->{parts}}, $part);
  return($part);
} # end subroutine add_part definition
########################################################################

=head2 part

Get the part at $index.  Negative indices are valid.

  my $part = $stl->part($index);

Throws an error if there is no such part.

=cut

sub part {
  my $self = shift;
  my ($index) = @_;

  @{$self->{parts}} or croak("file has no parts");

  $index ||= 0;
  exists($self->{parts}[$index]) or croak("no part $index");
  return($self->{parts}[$index]);
} # end subroutine part definition
########################################################################

=head1 I/O Methods

=head2 load

Load an STL file (auto-detects binary/ascii)

  $stl = $stl->load("filename.stl");

Optionally, explicitly declare binary mode:

  $stl = $stl->load(binary => "filename.stl");

The $self object is returned to allow e.g. chaining to C.

The filename may also be a filehandle.

=cut

sub load {
  my $self = shift;
  my ($file, @and) = @_;

  my $mode;
  if(@and) {
    (@and > 1) and croak('too many arguments to load()');
    $mode = $file;
    ($file) = @and;
  }

  # allow filehandle
  unless((ref($file) || '') eq 'GLOB') {
    open(my $fh, '<', $file) or
      die "cannot open '$file' for reading $!";
    $file = $fh;
  }

  # detection
  unless($mode) {
    unless(seek($file, 0,0)) {
      croak('must have explicit mode for non-seekable filehandle');
    }
    # now, detection...
    $mode = sub {
      my $fh = shift;
      seek($fh, 80, 0);
      my $count = eval {
        my $buf; read($fh, $buf, 4) or die;
        unpack('L', $buf);
      };
      $@ and return 'ascii'; # if we hit eof, it can't be binary
      $count or die "detection failed - no facets?";
      my $size = (stat($fh))[7];
      # calculate the expected file size
      my $expect =
        + 80 # header
        +  4 # count
        + $count * (
          + 4 # normal, pt,pt,pt (vectors)
          * 4 # bytes per value
          * 3 # values per vector
          + 2 # the trailing 'short'
        );
      return ($size == $expect) ? 'binary' : 'ascii';
    }->($file);
    seek($file, 0, 0) or die "cannot reset filehandle";
  }

  my $method = '_read_' . lc($mode);
  $self->can($method) or croak("invalid read mode '$mode'");

  $self->$method($file);
  return($self);
} # end subroutine load definition
########################################################################

=head2 _read_ascii

  $self->_read_ascii($filehandle);

=cut

sub _read_ascii {
  my $self = shift;
  my ($fh) = @_;

  my $getline = sub {
    while(my $line = <$fh>) {
      $line =~ s/\s*$//; # allow any eol
      length($line) or next;
      return($line);
    }
    return;
  };
  my $p_re = qr/([^ ]+)\s+([^ ]+)\s+([^ ]+)$/;

  my $part;
  while(my $line = $getline->()) {

    if($line =~ m/^\s*solid (.*)/) {
      $part = $self->add_part($1);
    }
    elsif($line =~ m/^\s*endsolid (.*)/) {
      my $name = $1;
      $part or die "invalid 'endsolid' entry with no current part";
      ($name eq $part->name) or
        die "end of part '$name' should have been '",
          $part->name, "'";
      $part = undef;
    }
    elsif($part) {
      my @n = ($line =~ m/^\s*facet\s+normal\s+$p_re/) or
        die "how did that happen? ($line)";
      #warn "got ", join('|', @n);
      my @facet = (\@n);

      my $next = $getline->();
      unless($next and ($next =~ m/^\s*outer\s+loop$/)) {
        die "facet doesn't start with 'outer loop' ($next)";
      }
      push(@facet, do {
        my @got;
        while(my $line = $getline->()) {
          ($line =~ m/^\s*endloop$/) and last;
          if($line =~ m/^\s*vertex\s+$p_re/) {
            push(@got, [$1, $2, $3]);
          }
        }
        @got;
      });
      (scalar(@facet) == 4) or
        die "need three vertices per facet (not $#facet)";
      my $end = $getline->();
      ($end and ($end =~ m/^\s*endfacet/)) or
        die "bad endfacet $line";
      $part->add_facets([@facet]);
    }
    else {
      die "what? ($line)";
    }
  }
  $part and die "part '", $part->name, "' was left open";
} # end subroutine _read_ascii definition
########################################################################

=head2 get_

These functions are currently only used internally.

=over

=item get_triangle

=item get_ulong

=item get_float32

=item get_short

=back

=cut

sub get_triangle {
  my ($fh) = @_;

  my ($n, $x, $y, $z) = map({[map({get_float32($fh)} 1..3)]} 1..4);
  my $scrap = get_short($fh);
  return($n, $x, $y, $z);
}

sub get_ulong {
  my ($fh) = @_;

  my $buf;
  read($fh, $buf, 4) or warn "EOF?";
  return(unpack('L', $buf));
}

sub get_float32 {
  my ($fh) = @_;

  my $buf;
  read($fh, $buf, 4) or warn "EOF?";
  return(unpack('f', $buf));
}

sub get_short {
  my ($fh) = @_;

  my $buf;
  read($fh, $buf, 2) or warn "EOF?";
  return(unpack('S', $buf));
}

=head2 _read_binary

  $self->_read_binary($filehandle);

=cut

sub _read_binary {
  my $self = shift;
  my ($fh) = @_;

  $self->parts and die "binary STL files must have only one part";

  die "bigfloat" unless(length(pack("f", 1)) == 4);
  # TODO try to read part name from header (up to \0)
  my $name = 'a part';
  seek($fh, 80, 0);

  my $triangles = get_ulong($fh);
  my $part = $self->add_part($name);

  my $count = 0;
  while(1) {
    my @tr = get_triangle($fh);
    # TODO check that the unit normal is within a thousandth of a radian
    # (0.001 rad is ~0.06deg)
    $part->add_facets([@tr]);
    $count++;
    eof($fh) and last;
  }
  ($count == $triangles) or
    die "ERROR: got $count facets (expected $triangles)";
} # end subroutine _read_binary definition
########################################################################

=head2 save

  $stl->save("filename.stl");

  $stl->save(binary => "filename.stl");

=cut

sub save {
  my $self = shift;
  my ($file, @and) = @_;

  my $mode;
  if(@and) {
    (@and > 1) and croak('too many arguments to save()');
    $mode = $file;
    ($file) = @and;
  }

  # allow filehandle
  unless((ref($file) || '') eq 'GLOB') {
    open(my $fh, '>', $file) or
      die "cannot open '$file' for writing $!";
    $file = $fh;
  }

  $mode = 'ascii' unless($mode);

  my $method = '_write_' . lc($mode);
  $self->can($method) or croak("invalid write mode '$mode'");

  $self->$method($file);
} # end subroutine save definition
########################################################################

=head2 _write_binary

  $self->_write_binary($filehandle);

=cut

sub _write_binary {
  my $self = shift;
  my ($fh) = @_;

  my ($part, @and) = $self->parts;
  @and and die 'cannot write binary files with multiple parts';

  my $name = $part->name; # utf8 is ok
  print $fh $name, "\0" x (80 - do {use bytes; length($name)});
  my @facets = $part->facets;
  print $fh pack('L', scalar(@facets));
  foreach my $facet (@facets) {
    print $fh map({map({pack('f', $_)} @$_)} @$facet);
    print $fh "\0" x 2;
  }

} # end subroutine _write_binary definition
########################################################################

=head2 _write_ascii

  $self->_write_ascii($filehandle);

=cut

sub _write_ascii {
  my $self = shift;
  my ($fh) = @_;

  my $spaces = '';
  my $print = sub {print $fh $spaces, @_, "\n"};
  my @parts = $self->parts or croak("no parts to write");
  foreach my $part (@parts) {
    $print->('solid ', $part->name);
    $spaces = ' 'x2;
    foreach my $facet ($part->facets) {
      my ($n, @pts) = @$facet;
      $print->(join(' ', 'facet normal', @$n));
      $spaces = ' 'x4;
      $print->('outer loop');
      $spaces = ' 'x6;
      (@pts == 3) or die "invalid facet";
      foreach my $pt (@pts) {
        $print->(join(' ', 'vertex', @$pt));
      }
      $spaces = ' 'x4;
      $print->('endloop');
      $spaces = ' 'x2;
      $print->('endfacet');
    }
    $spaces = '';
    print $fh 'endsolid ', $part->name, "\n";
  }
} # end subroutine _write_ascii definition
########################################################################

=head1 AUTHOR

Eric Wilhelm @

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2007 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatsoever.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# vi:ts=2:sw=2:et:sta
1;