view release on metacpan or  search on metacpan

lib/CAD/Format/STL.pm  view on Meta::CPAN

  @{$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<new()>.

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)";