New testing framework

MANIFEST

@@ -45,6 +45,7 @@ lib/Slic3r/Print/Region.pm
 lib/Slic3r/Print/Object.pm
 lib/Slic3r/Surface.pm
 lib/Slic3r/SVG.pm
+lib/Slic3r/Test.pm
 lib/Slic3r/TriangleMesh.pm
 MANIFEST			This list of files
 README.markdown
@@ -58,6 +59,7 @@ t/dynamic.t
 t/fill.t
 t/geometry.t
 t/polyclip.t
+t/retract.t
 t/serialize.t
 t/stl.t
 utils/amf-to-stl.pl

lib/Slic3r/Print.pm

@@ -434,9 +434,9 @@ sub export_gcode {
     $self->make_brim;  # must come after make_skirt
     
     # output everything to a G-code file
-    my $output_file = $self->expanded_output_filepath($params{output_file});
+    my $output_file = $params{output_file} ? $self->expanded_output_filepath($params{output_file}) : '';
     $status_cb->(90, "Exporting G-code to $output_file");
-    $self->write_gcode($output_file);
+    $self->write_gcode($params{output_fh} || $output_file);
     
     # run post-processing scripts
     if (@{$Slic3r::Config->post_process}) {
@@ -449,6 +449,7 @@ sub export_gcode {
     }
     
     # output some statistics
+    unless ($params{quiet}) {
         $self->processing_time(tv_interval($t0));
         printf "Done. Process took %d minutes and %.3f seconds\n", 
             int($self->processing_time/60),
@@ -458,6 +459,7 @@ sub export_gcode {
         printf "Filament required: %.1fmm (%.1fcm3)\n",
             $self->total_extrusion_length, $self->total_extrusion_volume;
     }
+}
 
 sub export_svg {
     my $self = shift;
@@ -643,9 +645,14 @@ sub write_gcode {
     my $self = shift;
     my ($file) = @_;
     
-    # open output gcode file
-    open my $fh, ">", $file
+    # open output gcode file if we weren't supplied a file-handle
+    my $fh;
+    if (ref $file eq 'IO::Scalar') {
+        $fh = $file;
+    } else {
+        open $fh, ">", $file
             or die "Failed to open $file for writing\n";
+    }
     
     # write some information
     my @lt = localtime;

lib/Slic3r/Test.pm

@@ -0,0 +1,112 @@
+package Slic3r::Test;
+use strict;
+use warnings;
+
+use IO::Scalar;
+use Slic3r::Geometry qw(epsilon);
+
+sub init_print {
+    my ($model_name, %params) = @_;
+    
+    my $model = Slic3r::Model->new;
+    {
+        my ($vertices, $facets);
+        if ($model_name eq '20mm_cube') {
+            $vertices = [
+                [10,10,-10], [10,-10,-10], [-10,-10,-10], [-10,10,-10], [10,10,10], [-10,10,10], [-10,-10,10], [10,-10,10],
+            ];
+            $facets = [
+                [0,1,2], [0,2,3], [4,5,6], [4,6,7], [0,4,7], [0,7,1], [1,7,6], [1,6,2], [2,6,5], [2,5,3], [4,0,3], [4,3,5],
+            ],
+        }
+        $model->add_object(vertices => $vertices)->add_volume(facets => $facets);
+    }
+    
+    my $config = Slic3r::Config->new_from_defaults;
+    $config->apply($params{config}) if $params{config};
+    
+    my $print = Slic3r::Print->new(config => $config);
+    $print->add_model($model);
+    $print->validate;
+    
+    return $print;
+}
+
+sub gcode {
+    my ($print) = @_;
+    
+    my $fh = IO::Scalar->new(\my $gcode);
+    $print->export_gcode(output_fh => $fh, quiet => 1);
+    $fh->close;
+    
+    return $gcode;
+}
+
+sub compare {
+    my ($a, $b) = @_;
+    return abs($a - $b) < epsilon;
+}
+
+package Slic3r::Test::GCodeReader;
+use Moo;
+
+has 'gcode' => (is => 'ro', required => 1);
+has 'X' => (is => 'rw', default => sub {0});
+has 'Y' => (is => 'rw', default => sub {0});
+has 'Z' => (is => 'rw', default => sub {0});
+has 'E' => (is => 'rw', default => sub {0});
+has 'F' => (is => 'rw', default => sub {0});
+
+our $Verbose = 0;
+my @AXES = qw(X Y Z E F);
+
+sub parse {
+    my $self = shift;
+    my ($cb) = @_;
+    
+    foreach my $line (split /\n/, $self->gcode) {
+        $line =~ s/\s*;(.*)//; # strip comment
+        next if $line eq '';
+        my $comment = $1;
+        
+        # parse command
+        my ($command, @args) = split /\s+/, $line;
+        my %args = map { /([A-Z])(.*)/; ($1 => $2) } @args;
+        my %info = ();
+        
+        # check retraction
+        if ($command =~ /^G[01]$/) {
+            if (!exists $args{E}) {
+                $info{travel} = 1;
+            }
+            foreach my $axis (@AXES) {
+                if (!exists $args{$axis}) {
+                    $info{"dist_$axis"} = 0;
+                    next;
+                }
+                $info{"dist_$axis"} = $args{$axis} - $self->$axis;
+            }
+            $info{dist_XY} = Slic3r::Line->new([0,0], [@info{qw(dist_X dist_Y)}])->length;
+            if (exists $args{E}) {
+                ($info{dist_E} > 0)
+                    ? ($info{extruding} = 1)
+                    : ($info{retracting} = 1);
+            }
+        }
+        
+        # run callback
+        printf "$line\n" if $Verbose;
+        $cb->($self, $command, \%args, \%info);
+        
+        # update coordinates
+        if ($command =~ /^(?:G[01]|G92)$/) {
+            for (@AXES) {
+                $self->$_($args{$_}) if exists $args{$_};
+            }
+        }
+        
+        # TODO: update temperatures
+    }
+}
+
+1;

t/retraction.t

@@ -0,0 +1,42 @@
+use Test::More;
+use strict;
+use warnings;
+
+BEGIN {
+    use FindBin;
+    use lib "$FindBin::Bin/../lib";
+}
+
+use Slic3r;
+use Slic3r::Geometry qw(epsilon);
+use Slic3r::Test;
+
+{
+    my $config = Slic3r::Config->new(
+        retract_length          => [1.5],
+        retract_before_travel   => [3],
+    );
+    my $print = Slic3r::Test::init_print('20mm_cube', config => $config);
+    
+    my $retracted = 1;  # ignore the first travel move from home to first point
+    Slic3r::Test::GCodeReader->new(gcode => Slic3r::Test::gcode($print))->parse(sub {
+        my ($self, $cmd, $args, $info) = @_;
+        
+        if ($info->{retracting}) {
+            ok Slic3r::Test::compare(-$info->{dist_E}, $config->retract_length->[0]),
+                'retracted by the right amount';
+            $retracted = 1;
+        }
+        if ($info->{extruding}) {
+            $retracted = 0;
+        }
+        if ($info->{travel} && $info->{dist_XY} >= $config->retract_before_travel->[0]) {
+            ok $retracted,
+                'retracted before long travel move';
+        }
+    });
+}
+
+done_testing;
+
+__END__