view release on metacpan or  search on metacpan

lib/CAD/Drawing/IO/Image.pm  view on Meta::CPAN

		return();
	}
	elsif($filename =~ m/.*\.(\w+)$/) {
		my $ext = $1;
		($ext =~ m/tif|gif|jpg|png|bmp|fax|fig|pict|psd|xcf/) &&
			return("img");
	}
	return();
} # end subroutine check_type definition
########################################################################

=head1 Methods

=cut
########################################################################

=head2 load

Requires vectorization...

  load();

=cut
sub load {
	croak("load image not written");
} # end subroutine load definition
########################################################################

=head2 save

  save();

=cut
sub save {
	my $self = shift;
	my ($filename, $opt) = @_;
	our %img_out_functions;
	my %opts;
	my $accuracy = 1; # digits of accuracy with which to bother
	if(isa($opt, 'HASH')) {
		%opts = %$opt;
	}
	else {
		$opt and croak("not a hash");
	}
	my $imwidth = $opts{width};
	my $imheight = $opts{height};
	(defined($imwidth) and defined($imheight)) or
		carp("can't save image without width and height\n");
	my $outobj = Image::Magick->new(size=>"${imwidth}x${imheight}");
	my $bgcolor = "white";
	my $defaultcolor = "black";
	if($opts{defaultcolor}) {
		$defaultcolor = $opts{defaultcolor};
	}
	# $CAD::Drawing::default_color{$self} = $defaultcolor; # XXX ?
	if($opts{bgcolor}) {
		$bgcolor = $opts{bgcolor};
	}
	$outobj->ReadImage("xc:$bgcolor");
	if($opts{transparent}) {
		$outobj->Transparent(color=>"$bgcolor");
	}
	unless($opts{prescaled}) {
		carp("must prescale drawing object for now\n");
		# FIXME:  this should now go into the fit-to-bound deal
	}
# 	$outobj->Set(antialias=>"False");
	my $matte = "white";
	$outobj->Set(mattecolor=>$matte);
	$opts{imtype} and $outobj->Set(type => $opts{imtype});
	$opts{imcomp} and $outobj->Set(compression => $opts{imcomp});
	my %img_data = (
		imobj => $outobj,
		height => $imheight,
		width => $imwidth,
		accuracy => $accuracy,
		bgcolor => $bgcolor,
		defcolor => $defaultcolor,
		# FIXME:  need some way to make this selective?
		filled => $opts{'filled'} || 'none',
		lw     => defined($opts{'linewidth'}) ? $opts{'linewidth'} : 3.0,
		font => $opts{font} ? $opts{font} : 'arial',
		);
	my $count = $self->outloop(\%img_out_functions, \%img_data);
	my $err = $outobj->Write($filename);
	$err and die;
	return($count);
} # end subroutine save definition
########################################################################

our %img_out_functions = (
lines => sub {
	my ($obj, $data) = @_;
	my $img = $data->{imobj};
	my $acc = $data->{accuracy};
	my @pts = map({
		[map({sprintf("%0.${acc}f", $_)} (@$_)[0,1])]
		} @{$obj->{pts}});
	## warn "points: @{$pts[0]}  and @{$pts[1]}\n";
	# XXX is this needed?
	if(($pts[0][0] == $pts[1][0]) and ($pts[0][1] == $pts[1][1])) {
		## warn "bad line\n";
		return();
	}
	$pts[$_][1] = $data->{height} - $pts[$_][1] for 0..1;
	my $pt_string = join(" ", map({join(",", @$_)} @pts));
	my $color = image_color($obj->{color}, $data);
	$img->Draw(
		primitive => 'line',
		strokewidth => $obj->{lw} || $data->{lw},
		stroke => $color,
		fill => $data->{filled},
		points => $pt_string,
		);
},
plines => sub {
	my ($obj, $data) = @_;
	my $img = $data->{imobj};
	my $acc = $data->{accuracy};
	my @pts = map({