#!/usr/bin/perl
package gcode;
$VERSION=0.01; 
@ISA=qw(Exporter); 
@EXPORT=qw( x y z d f r ); 
my $f="%9f "; 
my $ff="%2.1f";
# convience functions to help with calling these functions. 
# basically so you can write x instead of 'x' 
# they don work, dont know why. 
sub x {'x'}
sub y {'y'} 
sub z {'z'} 
sub f {'f'} 
sub r {'r'} 
sub d {'d'}
# effectively providesone level of buffereing for commands. Needed to make sure recursive calls do what you think they should. 
sub proc
{
	my ($g,$c)=@_; # params are gcode object, code

	my ($file)=$g->{file}; 
    
	print $file $g->{pending}."\n" if ($g->{pending});
	$g->{pending}=$c; 
	return $c; 
}
# object creator
sub new
{
	my ($x,$file,$feed)=@_; 
    $x={};
	$x->{file}=$file; 
	open($file,">".$file) or die;
	$x->{pending}="%\nG40 G17";
    $x->{feed}=$feed;  
	return bless $x; 
}
# initialisation code at the start of gcode
sub ginit
{

}
# produces a comment protected by gcodes comment convention
sub gcomment
{
   my $gc=shift;
   my ($c)=@_; 

   return proc($gc,"( $c )"); 
}
# move command. perhaps this would be a good point to explain the calling convention here. 
# its a bit odd. In order to preserve the useful feature of gcode that you can provide what
# ever parameters you want to provide (and in whatever order) the convention is that 
# that you pass an x followed by the x value and so on. 
# can be intollerent of faulty calls
sub gmove
{
	my $g="G1 "; 
	my $c; 
	my $gc=shift;
	while (@_)
	{
 	   $c.=sprintf("%s $f",uc($_[0]),$_[1]) if ($_[0] =~/^[xyz]$/i);
 	   $c.=sprintf("F $ff",$_[1]) if ($_[0] =~/^f$/i);
	   shift; shift; 
	}
	return proc($gc, "$g $c") if ($c); 
	return ""; 
}
# arc clockwise, x,y and r radius only implemented. 
sub garccw
{
	# clockwise arc
	my $g="G2 "; 
	my $c; 
    my $gc=shift;
	while (@_) 
	{
 	   $c.=sprintf("%s $f",uc($_[0]),$_[1]) if ($_[0] =~/^[xyzrij]$/i);
 	   $c.=sprintf("F $ff",$_[1]) if ($_[0] =~/f/i);
	   shift; shift; 
	}
	return proc($gc,"$g $c\n") if ($c); 
	return ""; 
}
# arc clockwise
sub garcccw
{
	# counter clockwise arc
	my $g="G3 "; 
	my $c; 

    my $gc=shift; 
	while (@_) 
	{
 	   $c.=sprintf("%s $f",uc($_[0]),$_[1]) if ($_[0] =~/^[xyzrij]$/i);
 	   $c.=sprintf("F $ff",$_[1]) if ($_[0] =~/f/i);
	   shift; shift; 
	}
	return proc($gc,"$g $c\n") if ($c); 
	return ""; 
}
# cutter compensation on driving on the righ 
# you can supply an additional function if you want the compensation to linearly 
# come into effect as a move is performed. 
sub gcompr
{
	# cutter compensation on, cutting to the right 


	$c="G42 "; 
    $gc=shift;
	
	while ($_[0] =~/^[d]$/i)
	{
 	   $c.=sprintf("%s %d",uc($_[0]),$_[1]) ;
	   shift; shift; 
	}
	
	while ($_[0]=~/^G/i)
	{
	
		$c.=" ".$_[0]; 
		shift; 
		$gc->{pending}=''; # we clear this if additional values are passed 
	}
   return proc($gc,$c); 
}
# cutter (radius) compensation, drive on the left. 
sub gcompl
{
	# cutter compensation on, cutting to the left

	$c="G41 "; 
    $gc=shift;
	while ($_[0] =~/^[d]$/i)
	{
 	   $c.=sprintf("%s %d",uc($_[0]),$_[1]) ;
	   shift; shift; 
	}
	while ($_[0]=~/G/i)
	{
		$c.=" ".$_[0]; 
		shift; 
		$gc->{pending}=''; # we clear this if additional values are passed 
	}
   return proc($gc,$c); 
}
# switch off compensation. 
sub gcomp0
{
	# cutter compensation off

	$c="G40 "; 
    $gc=shift; 
	while ($_[0]=~/G/i)
	{
		$c.=" ".$_[0]; 
		shift; 
		$gc->{pending}=''; # we clear this if additional values are passed 
	}
   return proc($gc,$c); 
}
# end of program. 
sub gend
{
	my ($gc)=@_; 
	$gc->proc('');
	my $file= $gc->{file};
	print $file  "%\n"; 
	close $file; 
}
1;