view release on metacpan or  search on metacpan

t/STL-outputStl.t  view on Meta::CPAN

my $mesh = createMesh();
my $tri = createFacet($lft, $mid, $rgt);
# note sprintf '%-8.8s = <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e>', floor => map { @$_ } @$tri;
push @$mesh, $tri;

$tri = createFacet($lft, $rgt, $top);
# note sprintf '%-8.8s = <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e>', front => map { @$_ } @$tri;
push @$mesh, $tri;

$tri = createFacet($rgt, $mid, $top);
# note sprintf '%-8.8s = <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e>', right => map { @$_ } @$tri;
push @$mesh, $tri;

$tri = createFacet($mid, $lft, $top);
# note sprintf '%-8.8s = <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e>', left  => map { @$_ } @$tri;
push @$mesh, $tri;

# note '';
# note 'MESH:';
# note sprintf '%-8.8s   <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e> <%.9e,%.9e,%.9e>', '', map { @$_ } @$_ for @$mesh;

# define the expected values for the binary tests
my $expected_ubin = qr"................................................................................................................................................................04000000........................0000000000000000000000000000003fd7b...
    # expected unpacked bin.  comments that follow help describe what's going on...
    #                 "null header....................................................................................................................................................'########n1-----'n2-----'n3-----'a1-----'a2-----'a3-----'b1-----'b2-...
    # if the bigendian pack fails, it will be
    #                 "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000040000000000000000000000bf8000000000000000000000000000003f0000003f5...
    # 2018-Sep-18: converted to regular expression, where the header and normal vectors can be anything (required, since I've lost control over those when I switched to using CAD::Format::STL)

# define the expected values for the ascii tests
my $exp_ascii_aref = do {
    # automatically generate it: need to enforce roundoff, so match will be correct
    # 2018-Sep-19: no longer need normals, since those aren't compared (cannot control whether underlying library will include normals in saves or not)
    my @v = (
        [0,0,0], [5.0e-1, 8.6602540e-1, 0], [1,0,0],
        [0,0,0], [1,0,0], [5.0000000e-001,2.8867513e-001,8.1649658e-001],
        [1.0000000e+000, 0.0000000e+000, 0.0000000e+000], [5.0000000e-001, 8.6602540e-001, 0.0000000e+000], [5.0000000e-001, 2.8867513e-001, 8.1649658e-001],
        [5.0000000e-001, 8.6602540e-001, 0.0000000e+000], [0.0000000e+000, 0.0000000e+000, 0.0000000e+000], [5.0000000e-001, 2.8867513e-001, 8.1649658e-001],
    );

    # round the array coordinates
    foreach my $i ( 0 .. $#v ) {
        foreach my $j ( 0 .. 2 ) {
            $v[$i][$j] = 0 + sprintf '%.8f', $v[$i][$j];
        }
    }

    [@v];
};

# compare the expected values for the ascii tests
sub test_ascii {
    my($ascii_string, $expect_aref, $test_name) = @_;
    $test_name = "test_ascii::${test_name}";
    note "\n", $test_name;
    $ascii_string =~ s/\h+/ /gm;  # normalize horizontal whitespace
    $ascii_string =~ s/^\s+//gm;  # trim leading whitespace on any line
    $ascii_string =~ s/\s+$//gm;  # trim trailing whitespace on any line
    #note "-----\n", $ascii_string, "\n=====\n";
    $ascii_string =~ m/^solid *(?<name>\V*?)$(?<content>.*)^endsolid *\g{name}*$/ms;
    my $name = $+{name};
    #note "\t", name => "\t", $name;
    my $content = $+{content};
    #note "\t", content => "\t", $content;
    ok $content, "${test_name}: solid/endsolid has content";
    my @facets = $content =~ m/^facet *(.*?)\R+^endfacet$/gms;
    my $n = scalar @facets;
    is $n, 4, "${test_name}: has 4 facets";
    my @vectors;
    foreach my $facet ( @facets ) {
        #note "facet {\n", $facet, "\n}\n";
        my @nv = $facet =~ m/normal (\S+) (\S+) (\S+)/gms;
        #note "normal: [@nv]";
        is scalar(@nv), 3, "${test_name}: facet normal has three coordinates";
        $facet =~ m/^outer loop$(?<content>.*)^endloop$/ms;
        $content = $+{content};
        ok $content, "${test_name}: facet has loop content";
        #note "\t", loop_content => "\t", $content;
        my @verts = $facet =~ /^vertex \S+ \S+ \S+$/gms;
        is scalar(@verts), 3, "${test_name}: facet has three vertexes";
        foreach my $vstr ( @verts ) {
            $vstr =~ m/\Avertex (?<x>\S+) (?<y>\S+) (?<z>\S+)\Z/ms;
            my $pt = [map {0 + sprintf '%.8f', $_} @+{qw/x y z/}];
            #note pt => "\t[@$pt] = $pt";
            is scalar(@$pt), 3, "${test_name}: vertex has three coordinates";
            push @vectors, $pt;
        }
    }
    is scalar(@vectors), 12, "${test_name}: found a total of 12 vertices in all the facets";
    is_deeply \@vectors, $expect_aref, "${test_name}: vertices ok" or diag explain \@vectors;

    note "\n";
}

# loop through the mainline tests using in-memory file
foreach my $asc (undef, 0, qw(false binary bin true ascii asc), 1) {
    my $memory = '';
    open my $fh, '>', \$memory or die "in-memory handle failed: $!";
    $mesh->output(STL => $fh, $asc);
    close($fh);
    my $expected;
    my $is_ascii = 0;
    while(1) {
        my $nmesh = @$mesh;
        my $count = unpack 'L<', substr($memory, 80, 4);
        $is_ascii++, last   unless $nmesh == $count;
        my $exp_size =
            + 80 # eighty header bytes
            +  4 # four bytes for the length
            + $count * (
                + 4 # normal and three point vectors
                * 3 # three values per vector
                * 4 # four bytes per value
                + 2 # the trailing short (aka 'attribute byte count')
            );
        my $got_size = length($memory);
        $is_ascii++, last   unless $exp_size == $got_size;
        last;
    }
    if($is_ascii) {       # ascii