Geometry-Primitive-0.22/000755 000765 000024 00000000000 11322222254 015437 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/Changes000644 000765 000024 00000004267 11322221517 016744 0ustar00gphatstaff000000 000000 Revision history for Geometry-Primitive 0.22 January 9th, 2009 - Default Dimension width and height to 0 0.21 January 9th, 2009 - Add Dimension - De-moosify Graphics::Primitive and stop extending it everywhere, since it's useless. 0.20 December 27th, 2009 - Use MooseX::Storage::Deferred 0.19 November 12th, 2009 - Add JSON::Any dep 0.18 October 3rd, 2009 - POD overhaul - Removal of MooseX::AttributeHelpers, using native Moose feature now - Bump Moose dependency 0.17 - Fix bug in POD - Fix Geometry::Primitive not being immutable 0.16 - Dep bumps 0.15 - Updated readme 0.14 - POD updates 0.13 - Move pod tests to t/author 0.12 - Add Ellipse - Circle is no longer a child of Arc - Fix some POD - Remove .DS_Store from MANIFEST 0.11 - Stop depending on Moose coverage 0.10 - POD updates (thanks CPAN testers!) - Circle: set defaults in radians, not degrees - Add MooseX::Storage for serialization 0.09 - Convenience coercions for Point from ArrayRef 0.08 - Add Bézier curve - POD fix (thanks Brian Cassidy) 0.07 - Add scale method to Shape role and implementations - Fix line slope calculation - Line: add is_perpendicular and is_parallel - Arc: don't check angles in get_point_at_angle, allow for negative arcs - Util: Remove in favor of Math::Trig - Polygon: Implement area 0.06 - Shape: removed get_points in favor of point_start/point_end - Arc: Add length and get_point_at_angle - Line: rename point_start/point_end to start/end - Line: added contains_point, length and y_intercept - Polygon: rename get_point_at to get_point - Point: add string overload - Circle: Add area and circumference - Make some attributes required - More MX::Clone lovin' - Add to_string and "" overload to Line 0.05 - Add MooseX::Clone for Point (for now) - Add make_immutable to er'thang 0.04 - Add Circle - Move 'origin' attribute from Rectangle to Shape and make it !required 0.03 - Add MI version because Yuval yelled at me - Add degrees_to_radians and radians_to_degrees to Util 0.02 2008-07-09 - Package fixes, no changes 0.01 Date/time First version, released on an unsuspecting world. Geometry-Primitive-0.22/inc/000755 000765 000024 00000000000 11322222254 016210 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/lib/000755 000765 000024 00000000000 11322222254 016205 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/Makefile.PL000644 000765 000024 00000000612 11315732237 017421 0ustar00gphatstaff000000 000000 use inc::Module::Install 0.75; name 'Geometry-Primitive'; all_from 'lib/Geometry/Primitive.pm'; author 'Cory Watson '; build_requires 'Test::More'; test_requires 'JSON::Any' => '1.22'; requires 'Check::ISA' => '0.04'; requires 'Math::Complex' => '1.56'; requires 'Moose' => '0.92'; requires 'MooseX::Clone' => '0.04'; requires 'MooseX::Storage' => '0.23'; WriteAll; Geometry-Primitive-0.22/MANIFEST000644 000765 000024 00000001562 11322220011 016561 0ustar00gphatstaff000000 000000 Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Geometry/Primitive.pm lib/Geometry/Primitive/Arc.pm lib/Geometry/Primitive/Bezier.pm lib/Geometry/Primitive/Circle.pm lib/Geometry/Primitive/Dimension.pm lib/Geometry/Primitive/Ellipse.pm lib/Geometry/Primitive/Equal.pm lib/Geometry/Primitive/Line.pm lib/Geometry/Primitive/Point.pm lib/Geometry/Primitive/Polygon.pm lib/Geometry/Primitive/Rectangle.pm lib/Geometry/Primitive/Shape.pm Makefile.PL MANIFEST This list of files META.yml README t/00-load.t t/000-point.t t/001-arc.t t/001-ellipse.t t/001-line.t t/001-polygon.t t/002-bezier.t t/002-circle.t t/002-rectangle.pm t/010-serialize.t t/author/pod-coverage.t t/author/pod.t t/dimension.t Geometry-Primitive-0.22/META.yml000644 000765 000024 00000001166 11322222251 016711 0ustar00gphatstaff000000 000000 --- abstract: 'Primitive Geometry Entities' author: - 'Cory Watson ' build_requires: ExtUtils::MakeMaker: 6.42 JSON::Any: 1.22 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Geometry-Primitive no_index: directory: - inc - t requires: Check::ISA: 0.04 Math::Complex: 1.56 Moose: 0.92 MooseX::Clone: 0.04 MooseX::Storage: 0.23 resources: license: http://dev.perl.org/licenses/ version: 0.22 Geometry-Primitive-0.22/README000644 000765 000024 00000002272 11203601331 016315 0ustar00gphatstaff000000 000000 Geometry::Primitive - Primitive Geometry Entities Geometry::Primitive is a device and library agnostic system for representing geometric entities such as points, lines and shapes. It provides simple objects and many convenience methods you would expect from a simple geometry library. use Geometry::Primitive::Point; my $foo = Geometry::Primitive::Point->new(x => 1, y => 3); ... INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Geometry::Primitive You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Geometry-Primitive AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Geometry-Primitive CPAN Ratings http://cpanratings.perl.org/d/Geometry-Primitive Search CPAN http://search.cpan.org/dist/Geometry-Primitive COPYRIGHT AND LICENCE Copyright (C) 2008 Cory Watson This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Geometry-Primitive-0.22/t/000755 000765 000024 00000000000 11322222254 015702 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/t/00-load.t000644 000765 000024 00000000247 11203601060 017220 0ustar00gphatstaff000000 000000 #!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Geometry::Primitive' ); } diag( "Testing Geometry::Primitive $Geometry::Primitive::VERSION, Perl $], $^X" ); Geometry-Primitive-0.22/t/000-point.t000644 000765 000024 00000000635 11203601060 017513 0ustar00gphatstaff000000 000000 use Test::More tests => 5; BEGIN { use_ok('Geometry::Primitive::Point'); }; my $point = Geometry::Primitive::Point->new(); $point->x(1); $point->y(2); cmp_ok($point->x, '==', 1, 'x value'); cmp_ok($point->y, '==', 2, 'y value'); my $point2 = Geometry::Primitive::Point->new(x => 1, y => 2); ok($point->equal_to($point2), 'point equality'); $point2->x(0); ok(!$point->equal_to($point2), 'point inequality');Geometry-Primitive-0.22/t/001-arc.t000644 000765 000024 00000001172 11203601060 017125 0ustar00gphatstaff000000 000000 use Test::More tests => 8; use Geometry::Primitive::Point; BEGIN { use_ok('Geometry::Primitive::Arc'); }; my $arc = Geometry::Primitive::Arc->new( origin => Geometry::Primitive::Point->new(x => 0, y => 0), angle_start => 0, angle_end => 1.57079633, radius => 5 ); cmp_ok($arc->angle_start, '==', 0, 'angle start'); cmp_ok($arc->angle_end, '==', 1.57079633, 'angle end'); cmp_ok($arc->radius, '==', 5, 'radius'); ok($arc->length =~ /^7.8/, 'length'); ok(defined($arc->get_point_at_angle(1.5)), 'get_point_at_angle bounds check'); ok(defined($arc->point_start), 'point_start'); ok(defined($arc->point_end), 'point_end');Geometry-Primitive-0.22/t/001-ellipse.t000644 000765 000024 00000000360 11203601060 020013 0ustar00gphatstaff000000 000000 use Test::More tests => 3; BEGIN { use_ok('Geometry::Primitive::Ellipse'); }; my $circ = Geometry::Primitive::Ellipse->new(width => 4 , height => 2); isa_ok($circ, 'Geometry::Primitive::Ellipse'); ok($circ->area =~ /^6.28/, 'area'); Geometry-Primitive-0.22/t/001-line.t000644 000765 000024 00000003477 11203601060 017321 0ustar00gphatstaff000000 000000 use Test::More tests => 16; BEGIN { use_ok('Geometry::Primitive::Point'); use_ok('Geometry::Primitive::Line'); }; my $point1 = Geometry::Primitive::Point->new(x => 1, y => 2); my $point2 = Geometry::Primitive::Point->new(x => 3, y => 4); my $line = Geometry::Primitive::Line->new(start => $point1, end => $point2); ok($line->point_start->equal_to($point1), 'point_start'); ok($line->point_end->equal_to($point2), 'point_end'); cmp_ok($line->slope, '==', 1, 'slope'); cmp_ok($line->length, '==', sqrt(8), 'length'); cmp_ok($line->y_intercept, '==', 1, 'y_intercept'); ok($line->contains_point(-2, -1), 'contains_point'); ok(!$line->contains_point(-1, -1), 'contains_point (wrong)'); my $vert = Geometry::Primitive::Line->new( start => Geometry::Primitive::Point->new( x => 0, y => 0 ), end => Geometry::Primitive::Point->new( x => 0, y => 5 ), ); ok(!defined($vert->slope), 'slope of vertical line'); my $horiz = Geometry::Primitive::Line->new( start => Geometry::Primitive::Point->new( x => 0, y => 0 ), end => Geometry::Primitive::Point->new( x => 5, y => 0 ), ); cmp_ok($horiz->slope, '==', 0, 'slope of horizontal line'); ok($horiz->is_perpendicular($vert), 'vert/horiz perpendicular'); ok($vert->is_perpendicular($horiz), 'horiz/vert perpendicular'); my $line1 = Geometry::Primitive::Line->new( start => Geometry::Primitive::Point->new( x => 0, y => 1 ), end => Geometry::Primitive::Point->new( x => 1, y => 0 ), ); my $line2 = Geometry::Primitive::Line->new( start => Geometry::Primitive::Point->new( x => 0, y => 0 ), end => Geometry::Primitive::Point->new( x => 1, y => 1 ), ); ok($line1->is_perpendicular($line2), 'perpendicular'); my $cline = Geometry::Primitive::Line->new(start => [0, 0], end => [5, 5]); cmp_ok($cline->start->x, '==', 0, 'point coercion'); ok($cline->slope, 'coerced line'); Geometry-Primitive-0.22/t/001-polygon.t000644 000765 000024 00000001775 11203601060 020060 0ustar00gphatstaff000000 000000 use Test::More tests => 9; BEGIN { use_ok('Geometry::Primitive::Point'); use_ok('Geometry::Primitive::Polygon'); }; my $poly = Geometry::Primitive::Polygon->new; my $point1 = Geometry::Primitive::Point->new(x => 0, y => 0); $poly->add_point($point1); my $point2 = Geometry::Primitive::Point->new(x => 0, y => 1); $poly->add_point($point2); my $point3 = Geometry::Primitive::Point->new(x => 1, y => 1); $poly->add_point($point3); my $point4 = Geometry::Primitive::Point->new(x => 1, y => 0); $poly->add_point($point4); my $point5 = Geometry::Primitive::Point->new(x => 0, y => 0); $poly->add_point($point5); cmp_ok($poly->point_count, '==', 5, 'point count'); ok($poly->get_point(0)->equal_to($point1), 'get point 1'); ok($poly->point_start->equal_to($point1), 'start point'); ok($poly->point_end->equal_to($point1), 'end point'); cmp_ok($poly->area, '==', 1, 'area'); $poly->scale(2); cmp_ok($poly->area, '==', 4, 'scaled area'); $poly->clear_points; cmp_ok($poly->point_count, '==', 0, 'cleared points'); Geometry-Primitive-0.22/t/002-bezier.t000644 000765 000024 00000001333 11203601060 017640 0ustar00gphatstaff000000 000000 use Test::More tests => 6; BEGIN { use_ok('Geometry::Primitive::Point'); use_ok('Geometry::Primitive::Bezier'); }; my $point1 = Geometry::Primitive::Point->new(x => 0, y => 0); my $point2 = Geometry::Primitive::Point->new(x => 0, y => 10); my $c1 = Geometry::Primitive::Point->new(x => 5, y => 5); my $c2 = Geometry::Primitive::Point->new(x => 7, y => 6); my $bezier = Geometry::Primitive::Bezier->new( start => $point1, end => $point2, control1 => [5, 5], control2 => $c2 ); isa_ok($bezier, 'Geometry::Primitive::Bezier'); ok($bezier->point_start->equal_to($point1), 'point_start'); ok($bezier->point_end->equal_to($point2), 'point_end'); ok($bezier->control1->equal_to($c1), 'coerced control point');Geometry-Primitive-0.22/t/002-circle.t000644 000765 000024 00000000427 11203601060 017624 0ustar00gphatstaff000000 000000 use Test::More tests => 4; BEGIN { use_ok('Geometry::Primitive::Circle'); }; my $circ = Geometry::Primitive::Circle->new( radius => 5 ); isa_ok($circ, 'Geometry::Primitive::Circle'); cmp_ok($circ->radius, '==', 5, 'radius'); cmp_ok($circ->diameter, '==', 10, 'diameter'); Geometry-Primitive-0.22/t/002-rectangle.pm000644 000765 000024 00000001436 11203601060 020501 0ustar00gphatstaff000000 000000 use Test::More tests => 11; BEGIN { use_ok('Geometry::Primitive::Point'); use_ok('Geometry::Primitive::Rectangle'); }; my $orig = Geometry::Primitive::Point->new(x => 0, y => 0); my $rect = Geometry::Primitive::Rectangle->new( origin => $orig, width => 5, height => 10 ); cmp_ok($rect->area(), '==', 50, 'area'); my $points = $rect->get_points(); cmp_ok(scalar(@{ $points }), '==', 4, 'correct number of points'); ok($points->[0]->equal_to($orig), 'first point'); cmp_ok($points->[1]->x, '==', 5, 'second point x'); cmp_ok($points->[1]->y, '==', 0, 'second point y'); cmp_ok($points->[2]->x, '==', 0, 'third point x'); cmp_ok($points->[2]->y, '==', 10, 'third point y'); cmp_ok($points->[3]->x, '==', 5, 'third point x'); cmp_ok($points->[3]->y, '==', 10, 'third point y');Geometry-Primitive-0.22/t/010-serialize.t000644 000765 000024 00000004161 11315732445 020370 0ustar00gphatstaff000000 000000 use Test::More tests => 7; use Geometry::Primitive::Arc; use Geometry::Primitive::Bezier; use Geometry::Primitive::Circle; use Geometry::Primitive::Line; use Geometry::Primitive::Point; use Geometry::Primitive::Polygon; use Geometry::Primitive::Rectangle; my $arc = Geometry::Primitive::Arc->new(radius => 5, angle_start => 15, angle_end => 45); my $arc2 = Geometry::Primitive::Arc->thaw($arc->freeze({ format => 'JSON' }), { format => 'JSON' }); is_deeply($arc, $arc2, 'arc deserialized'); my $bezier = Geometry::Primitive::Bezier->new( control1 => [ 0, 0 ], control2 => [ 10, 10 ], start => [0, 0 ], end => [ 5, 5 ] ); my $bezier2 = Geometry::Primitive::Bezier->thaw($bezier->freeze({ format => 'JSON' }), { format => 'JSON' }); is_deeply($bezier, $bezier2, 'bezier deserialized'); my $circle = Geometry::Primitive::Circle->new( radius => 5, origin => [ 10, 10 ] ); my $circle2 = Geometry::Primitive::Circle->thaw($circle->freeze({ format => 'JSON' }), { format => 'JSON' }); is_deeply($circle, $circle2, 'circle deserialized'); my $line = Geometry::Primitive::Line->new( start => [ 0, 0 ], end => [ 10, 10 ] ); my $line2 = Geometry::Primitive::Line->thaw($line->freeze({ format => 'JSON' }), { format => 'JSON' }); is_deeply($line, $line2, 'line deserialized'); my $point = Geometry::Primitive::Point->new(x => 1, y => 5); my $point2 = Geometry::Primitive::Point->unpack($point->pack); ok($point->equal_to($point2), 'point equal_to'); my $polygon = Geometry::Primitive::Polygon->new; $polygon->add_point(Geometry::Primitive::Point->new(x => 0, y => 10)); $polygon->add_point(Geometry::Primitive::Point->new(x => 5, y => 10)); $polygon->add_point(Geometry::Primitive::Point->new(x => 10, y => 10)); my $polygon2 = Geometry::Primitive::Polygon->thaw($polygon->freeze({ format => 'JSON'}), { format => 'JSON' }); is_deeply($polygon, $polygon2, 'polygon deserialized'); my $rect = Geometry::Primitive::Rectangle->new( origin => [0, 0], width => 100, height => 25 ); my $rect2 = Geometry::Primitive::Rectangle->thaw($rect->freeze({ format => 'JSON' }), { format => 'JSON' }); is_deeply($rect, $rect2, 'rectangle deserialized');Geometry-Primitive-0.22/t/author/000755 000765 000024 00000000000 11322222254 017204 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/t/dimension.t000644 000765 000024 00000000711 11322217750 020060 0ustar00gphatstaff000000 000000 use Test::More; use strict; BEGIN { use_ok('Geometry::Primitive::Dimension'); }; my $dim = Geometry::Primitive::Dimension->new(width => 1, height => 2); cmp_ok($dim->width, '==', 1, 'width value'); cmp_ok($dim->height, '==', 2, 'height value'); my $dim2 = Geometry::Primitive::Dimension->new(width => 1, height => 2); ok($dim->equal_to($dim2), 'dimension equality'); $dim2->width(0); ok(!$dim->equal_to($dim2), 'dimension inequality'); done_testing;Geometry-Primitive-0.22/t/author/pod-coverage.t000644 000765 000024 00000001313 11203601060 021734 0ustar00gphatstaff000000 000000 use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; eval "use Pod::Coverage::Moose"; plan skip_all => "Pod::Coverage::Moose required for testing POD coverage" if $@; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::Moose' }); Geometry-Primitive-0.22/t/author/pod.t000644 000765 000024 00000000350 11203601060 020143 0ustar00gphatstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); Geometry-Primitive-0.22/lib/Geometry/000755 000765 000024 00000000000 11322222254 020000 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/lib/Geometry/Primitive/000755 000765 000024 00000000000 11322222254 021750 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/lib/Geometry/Primitive.pm000644 000765 000024 00000004160 11322221522 022304 0ustar00gphatstaff000000 000000 package Geometry::Primitive; use strict; use warnings; our $VERSION = '0.22'; our $AUTHORITY = 'cpan:GPHAT'; 1; __END__ =head1 NAME Geometry::Primitive - Primitive Geometry Entities =head1 SYNOPSIS Geometry::Primitive is a device and library agnostic system for representing geometric entities such as points, lines and shapes. It provides simple objects and many convenience methods you would expect from a simple geometry library. use Geometry::Primitive::Point; my $foo = Geometry::Primitive::Point->new(x => 1, y => 3); ... =head1 DISCLAIMER I'm not a math guy. I hate math. I will likely learn a lot in the process of making this library. If you are a math person you will probably look at this and find many things missing or wrong. Patches are B. I will likely find that I've done something completely wrong having taken geometry over 10 years ago. C'est la vie. =head1 ENTITIES =over 4 =item L =item L =item L =item L =item L =item L =item L =item L =back =head1 SERIALIZATON All of the entities in this library support serialization via L. This is primarily to support serialization in consumers of this library, but may be useful for other purposes. All classes are set to JSON format and File IO. =head1 AUTHOR Cory Watson, C<< >> =head1 ACKNOWLEDGEMENTS Many of the ideas here come from my experience using the Cairo library. =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 COPYRIGHT & LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Geometry-Primitive-0.22/lib/Geometry/Primitive/Arc.pm000644 000765 000024 00000005035 11322220174 023015 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Arc; use Moose; use MooseX::Storage; with qw(Geometry::Primitive::Shape MooseX::Clone MooseX::Storage::Deferred); use Geometry::Primitive::Point; has 'angle_start' => ( is => 'rw', isa => 'Num', required => 1 ); has 'angle_end' => ( is => 'rw', isa => 'Num', required => 1 ); has 'origin' => ( is => 'rw', isa => 'Geometry::Primitive::Point', coerce => 1 ); has 'radius' => ( is => 'rw', isa => 'Num', required => 1 ); # Area of a sector, if it's ever needed... # sub area { # my ($self) = @_; # # return (($self->radius**2 * ($self->angle_end - $self->angle_start)) / 2 # ); # } sub get_point_at_angle { my ($self, $angle) = @_; return Geometry::Primitive::Point->new( x => $self->origin->x + ($self->radius * cos($angle)), y => $self->origin->y + ($self->radius * sin($angle)) ); } sub length { my ($self) = @_; return $self->radius * ($self->angle_end - $self->angle_start); } sub point_end { my ($self) = @_; return $self->get_point_at_angle($self->angle_end); } sub point_start { my ($self) = @_; return $self->get_point_at_angle($self->angle_start); } sub scale { my ($self, $amount) = @_; $self->radius($self->radius * $amount); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Arc - Portion of the circumference of a Circle =head1 DESCRIPTION Geometry::Primitive::Arc represents a closed segment of a curve. =head1 SYNOPSIS use Geometry::Primitive::Arc; my $arc = Geometry::Primitive::Arc->new( angle_start => 0, angle_end => 1.57079633, radius => 15 ); =head1 ATTRIBUTES =head2 angle_start The starting angle for this arc in radians. =head2 angle_end The ending angle for this arc in radians. =head2 radius Returns the radius of the arc. =head2 origin Set/Get the origin of this arc. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Arc =head2 get_point_at_angle Given angle in radians returns the point at that angle on this arc. Returns undef if the angle falls outside this arc's range. =head2 length Returns the length of this arc. =head2 point_end Get the end point. Provided for Shape role. =head2 point_start Get the start point. Provided for Shape role. =head2 scale ($amount) Increases the radius by multiplying it by the supplied amount. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Bezier.pm000644 000765 000024 00000005122 11322220160 023520 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Bezier; use Moose; use MooseX::Storage; with qw(Geometry::Primitive::Shape MooseX::Clone MooseX::Storage::Deferred); use overload ('""' => 'to_string'); use Geometry::Primitive::Point; has 'control1' => ( is => 'rw', isa => 'Geometry::Primitive::Point', required => 1, coerce => 1 ); has 'control2' => ( is => 'rw', isa => 'Geometry::Primitive::Point', required => 1, coerce => 1 ); has 'end' => ( is => 'rw', isa => 'Geometry::Primitive::Point', required => 1, coerce => 1 ); has 'start' => ( is => 'rw', isa => 'Geometry::Primitive::Point', required => 1, coerce => 1 ); sub scale { my ($self, $amount) = @_; $self->start->x($self->start->x * $amount); $self->start->y($self->start->y * $amount); $self->end->x($self->end->x * $amount); $self->end->y($self->end->y * $amount); $self->control1->x($self->control1->x * $amount); $self->control1->y($self->control1->y * $amount); $self->control2->x($self->control2->x * $amount); $self->control2->y($self->control2->y * $amount); } sub point_end { my ($self) = @_; return $self->end; } sub point_start { my ($self) = @_; return $self->start; } sub to_string { my ($self) = @_; return $self->start->to_string.' - '.$self->control1->to_string .' = '.$self->control2->to_string.' = '.$self->end->to_string; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Bezier - Cubic Bézier Curve =head1 DESCRIPTION Geometry::Primitive::Bezier represents a cubic Bézier curve. =head1 SYNOPSIS use Geometry::Primitive::Bezier; my $line = Geometry::Primitive::Bezier->new( start => $point1, control1 => $point2, control2 => $point3, end => $point4 ); =head1 ATTRIBUTES =head2 control1 Set/Get the first control point of the curve. =head2 control2 Set/Get the second control point of the curve. =head2 end Set/Get the end point of the curve. =head2 start Set/Get the start point of the line. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Bezier =head2 grow Does nothing, as I'm not sure how. Patches or hints welcome. =head2 point_end Get the end point. Provided for Shape role. =head2 point_start Get the start point. Provided for Shape role. =head2 scale Scales this curve by the amount provided. Multiplies each coordinate by the amount. =head2 to_string Guess! =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Circle.pm000644 000765 000024 00000004221 11322220200 023473 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Circle; use Moose; use MooseX::Storage; with qw(Geometry::Primitive::Shape MooseX::Clone MooseX::Storage::Deferred); use Geometry::Primitive::Point; use Math::Trig ':pi'; has 'origin' => ( is => 'rw', isa => 'Geometry::Primitive::Point', coerce => 1 ); has 'radius' => ( is => 'rw', isa => 'Num', default => 0 ); sub area { my ($self) = @_; return $self->radius**2 * pi; }; sub circumference { my ($self) = @_; return $self->diameter * pi; } sub diameter { my ($self) = @_; return $self->radius * 2; } sub point_end { my ($self) = @_; return $self->point_start; } sub point_start { my ($self) = @_; return Geometry::Primitive::Point->new( x => $self->origin->x, y => $self->origin->y - ($self->radius / 2) ); } sub scale { my ($self, $amount) = @_; return Geometry::Primitive::Circle->new( radius => $self->radius * $amount ); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Circle - A Circle =head1 DESCRIPTION Geometry::Primitive::Circle represents an ellipse with equal width and height. =head1 SYNOPSIS use Geometry::Primitive::Circle; my $circle = Geometry::Primitive::Circle->new( radius => 15 ); print $circle->diameter; =head1 ATTRIBUTES =head2 origin Set/Get the origin of this circle. =head2 radius Set/Get the radius of this circle. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Circle =head2 area Returns the area of this circle. =head2 circumference Returns the circumference of this circle. =head2 diameter Returns the diameter of this circle =head2 scale ($amount) Returns a new circle whose radius is $amount times bigger than this one. =head2 point_end Set/Get the "end" point of this cicle. Calls C. =head2 point_start Set/Get the "start" point of this cicle. Returns the point at the circle's origin X coordinate and the origin Y coordinate + radius / 2. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Dimension.pm000644 000765 000024 00000002761 11322221475 024245 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Dimension; use Moose; use Moose::Util::TypeConstraints; use MooseX::Storage; with qw(Geometry::Primitive::Equal MooseX::Clone MooseX::Storage::Deferred); use overload ('""' => 'to_string'); has 'height' => ( is => 'rw', isa => 'Num', default => 0, ); has 'width' => ( is => 'rw', isa => 'Num', default => 0 ); coerce 'Geometry::Primitive::Dimension' => from 'ArrayRef' => via { Geometry::Primitive::Dimension->new(width => $_->[0], height => $_->[1]) }; sub equal_to { my ($self, $other) = @_; return (($self->width == $other->width) && $self->height == $other->height); } sub to_string { my ($self) = @_; return $self->width.'x'.$self->height; } __PACKAGE__->meta->make_immutable; no Moose; 1; =head1 NAME Geometry::Primitive::Dimension - A width and height =head1 DESCRIPTION Geometry::Primitive::Dimension encapsulates a height and width. =head1 SYNOPSIS use Geometry::Primitive::Dimension; my $point = Geometry::Primitive::Dimeions->new(width => 100, height => 100); =head1 ATTRIBUTES =head2 height Set/Get the height value. =head2 width Set/Get the width value. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Point. =head2 equal_to Compares this dimesion to another. =head2 to_string Return this dimesion as a string $widthx$height =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself. Geometry-Primitive-0.22/lib/Geometry/Primitive/Ellipse.pm000644 000765 000024 00000004062 11322220207 023701 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Ellipse; use Moose; use MooseX::Storage; use Math::Trig ':pi'; with qw(Geometry::Primitive::Shape MooseX::Clone MooseX::Storage::Deferred); has 'height' => ( is => 'rw', isa => 'Num', default => 0 ); has 'origin' => ( is => 'rw', isa => 'Geometry::Primitive::Point', coerce => 1 ); has 'width' => ( is => 'rw', isa => 'Num', default => 0 ); sub area { my ($self) = @_; return (pi * $self->width * $self->height) / 4; }; sub point_end { my ($self) = @_; return $self->point_start; } sub point_start { my ($self) = @_; return Geometry::Primitive::Point->new( x => $self->origin->x, y => $self->origin->y - ($self->height / 2) ); } sub scale { my ($self, $amount) = @_; return Geometry::Primitive::Ellipse->new( height => $self->height * $amount, width => $self->width * $amount ); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Ellipse - An Ellipse =head1 DESCRIPTION Geometry::Primitive::Ellipse represents an elliptical conic section. =head1 SYNOPSIS use Geometry::Primitive::Ellipse; my $ellipse = Geometry::Primitive::Ellipse->new( width => 15, height => 10 ); print $ellipse->area; =head1 ATTRIBUTES =head2 height Set/Get the height of this ellipse. =head2 origin Set/Get the origin of this ellipse. =head2 width Set/Get the width of this ellipse. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Ellipse =head2 area Returns the area of this ellipse. =head2 point_end Gets the "end" point for this Ellipse. Same as C. =head2 point_start Get the point that "starts" this Ellipse. Returns the a point where the X coordinate is the Ellipse origin X and the origin Y + height / 2. =head2 scale ($amount) Returns a new ellipse whose radius is $amount times bigger than this one. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Equal.pm000644 000765 000024 00000001363 11315731753 023373 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Equal; use Moose::Role; requires 'equal_to'; sub not_equal_to { my ($self, $other) = @_; not $self->equal_to($other); } no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Equal - Equality Role =head1 DESCRIPTION Geometry::Primitive::Equal is a Moose role for equality. =head1 SYNOPSIS with 'Geometry::Primitive::Equal'; sub equal_to { my ($self, $other) = @_; # compare and return! } =head1 METHODS =head2 equal_to Implement this. =head2 not_equal_to Provided you implement C, this will be implemented for you! =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Line.pm000644 000765 000024 00000006562 11322220214 023200 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Line; use Moose; use MooseX::Storage; with qw(Geometry::Primitive::Shape MooseX::Clone MooseX::Storage::Deferred); use overload ('""' => 'to_string'); use Geometry::Primitive::Point; has 'start' => ( is => 'rw', isa => 'Geometry::Primitive::Point', required => 1, coerce => 1 ); has 'end' => ( is => 'rw', isa => 'Geometry::Primitive::Point', required => 1, coerce => 1 ); sub contains_point { my ($self, $x, $y) = @_; my $point; if(!ref($x) && defined($y)) { # This allows the user to pass in $x and $y as scalars, which # easier sometimes. $point = Geometry::Primitive::Point->new(x => $x, y => $y); } else { $point = $x; } my $expy = ($self->slope * $point->x) + $self->y_intercept; return $expy == $point->y; } # Don't know how to do this atm. sub scale { } sub is_parallel { my ($self, $line) = @_; return $line->slope == $self->slope; } sub is_perpendicular { my ($self, $line) = @_; my $slope = $self->slope; # Deal with horizontal and vertical lines if(!defined($slope)) { return $line->slope == 0; } if($slope == 0) { return !defined($line->slope); } return $line->slope == (-1 / $self->slope); } sub length { my ($self) = @_; return sqrt(($self->end->x - $self->start->x) ** 2 + ($self->end->y - $self->start->y) ** 2); } sub point_end { my ($self) = @_; return $self->end; } sub point_start { my ($self) = @_; return $self->start; } sub slope { my ($self) = @_; my $end = $self->end; my $start = $self->start; my $x = $end->x - $start->x; my $y = $end->y - $start->y; if($x == 0) { return undef; } return $y / $x; } sub to_string { my ($self) = @_; return $self->start->to_string." - ".$self->end->to_string; } sub y_intercept { my ($self) = @_; return $self->start->y - ($self->slope * $self->start->x); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Line - A Line =head1 DESCRIPTION Geometry::Primitive::Line represents a straight curve defined by two points. =head1 SYNOPSIS use Geometry::Primitive::Line; my $line = Geometry::Primitive::Line->new(); $line->start($point1); $line->end($point2); =head1 ATTRIBUTES =head2 end Set/Get the end point of the line. =head2 start Set/Get the start point of the line. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Line =head2 contains_point Returns true if the supplied point is 'on' the line. Accepts either a point object or an x y pair. =head2 grow Does nothing, as I'm not sure how. Patches or hints welcome. =head2 is_parallel ($other_line) Returns true if the supplied line is parallel to this one. =head2 is_perpendicular ($other_line) Returns true if the supplied line is perpendicular to this one. =head2 length Get the length of the line. =head2 point_end Get the end point. Provided for Shape role. =head2 point_start Get the start point. Provided for Shape role. =head2 scale Does nothing at the moment. =head2 slope Get the slope of the line. =head2 to_string Guess! =head2 y_intercept Returns the Y intercept of this line. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Point.pm000644 000765 000024 00000002547 11322220217 023404 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Point; use Moose; use Moose::Util::TypeConstraints; use MooseX::Storage; with qw(Geometry::Primitive::Equal MooseX::Clone MooseX::Storage::Deferred); use overload ('""' => 'to_string'); has 'x' => ( is => 'rw', isa => 'Num' ); has 'y' => ( is => 'rw', isa => 'Num' ); coerce 'Geometry::Primitive::Point' => from 'ArrayRef' => via { Geometry::Primitive::Point->new(x => $_->[0], y => $_->[1]) }; sub equal_to { my ($self, $other) = @_; return (($self->x == $other->x) && $self->y == $other->y); } sub to_string { my ($self) = @_; return $self->x.','.$self->y; } __PACKAGE__->meta->make_immutable; no Moose; 1; =head1 NAME Geometry::Primitive::Point - An XY coordinate =head1 DESCRIPTION Geometry::Primitive::Point represents a location in two dimensional space. =head1 SYNOPSIS use Geometry::Primitive::Point; my $point = Geometry::Primitive::Point->new({ x => 2, y => 0 }); =head1 ATTRIBUTES =head2 x Set/Get the X value. =head2 y Set/Get the Y value. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Point. =head2 equal_to Compares this point to another. =head2 to_string Return this point as a string $x,$y =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself. Geometry-Primitive-0.22/lib/Geometry/Primitive/Polygon.pm000644 000765 000024 00000004731 11322220226 023737 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Polygon; use Moose; use MooseX::Storage; with qw(Geometry::Primitive::Shape MooseX::Clone MooseX::Storage::Deferred); has 'points' => ( traits => [ qw(Array Clone) ], is => 'rw', isa => 'ArrayRef[Geometry::Primitive::Point]', default => sub { [] }, handles => { add_point => 'push', clear_points=> 'clear', get_point => 'get', point_count => 'count' } ); sub area { my ($self) = @_; # http://mathworld.wolfram.com/PolygonArea.html my $area = 0; my $last = $self->get_point(0); for (my $i = 1; $i < $self->point_count; $i++) { my $curr = $self->get_point($i); $area += ($last->x * $curr->y) - ($curr->x * $last->y); $last = $curr; } return abs($area / 2); } sub point_end { my ($self) = @_; return $self->get_point($self->point_count - 1); } sub point_start { my ($self) = @_; return $self->get_point(0); } sub scale { my ($self, $amount) = @_; foreach my $p (@{ $self->points }) { $p->x($p->x * $amount); $p->y($p->y * $amount); } } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Polygon - Closed shape with an arbitrary number of points. =head1 DESCRIPTION Geometry::Primitive::Polygon represents a two dimensional figure bounded by a series of points that represent a closed path. =head1 SYNOPSIS use Geometry::Primitive::Polygon; my $poly = Geometry::Primitive::Polygon->new; $poly->add_point($point1); $poly->add_point($point2); $poly->add_point($point3); # No need to close the path, it's handled automatically =head1 ATTRIBUTES =head2 points Set/Get the arrayref of points that make up this Polygon. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Polygon =head2 area Area of this polygon. Assumes it is non-self-intersecting. =head2 add_point Add a point to this polygon. =head2 clear_points Clears all points from this polygon. =head2 point_count Returns the number of points that bound this polygon. =head2 get_point Returns the point at the specified offset. =head2 point_end Get the end point. Provided for Shape role. =head2 point_start Get the start point. Provided for Shape role. =head2 scale ($amount) Scale this this polygon by the supplied amount. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Rectangle.pm000644 000765 000024 00000004640 11322220223 024210 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Rectangle; use Moose; use MooseX::Storage; use Geometry::Primitive::Point; with qw(Geometry::Primitive::Shape MooseX::Clone MooseX::Storage::Deferred); has 'height' => ( is => 'rw', isa => 'Num', required => 1 ); has 'origin' => ( is => 'rw', isa => 'Geometry::Primitive::Point', coerce => 1 ); has 'width' => ( is => 'rw', isa => 'Num', required => 1 ); sub area { my ($self) = @_; return $self->height * $self->width; } sub get_points { my ($self) = @_; my @points; push(@points, $self->origin); push(@points, Geometry::Primitive::Point->new( x => $self->origin->x + $self->width, y => $self->origin->y )); push(@points, Geometry::Primitive::Point->new( x => $self->origin->x, y => $self->origin->y + $self->height )); push(@points, Geometry::Primitive::Point->new( x => $self->origin->x + $self->width, y => $self->origin->y + $self->height )); return \@points } sub scale { my ($self, $amount) = @_; $self->width($self->width * $amount); $self->height($self->height * $amount); } sub point_end { my ($self) = @_; return $self->origin; } sub point_start { my ($self) = @_; return $self->origin; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Rectangle - 4 sided polygon =head1 DESCRIPTION Geometry::Primitive::Rectangle a space defined by a point, a width and a height. =head1 SYNOPSIS use Geometry::Primitive::Rectangle; my $poly = Geometry::Primitive::Rectangle->new(); $poly->add_point($point1); $poly->height(100); $poly->width(100); =head1 ATTRIBUTES =head2 height Set/Get the height of this Rectangle. =head2 origin Set/Get the origin of this rectangle. =head2 width Set/Get the width of this Rectangle. =head1 METHODS =head2 new Creates a new Geometry::Primitive::Rectangle =head2 area Returns the area of this rectangle. =head2 get_points Get the points that make up this Rectangle. =head2 point_end Get the end point. Returns the origin. Provided for Shape role. =head2 point_start Get the start point. Returns the origin. Provided for Shape role. =head2 scale ($amount) Scales the hieght and width of this rectangle by the amount specified. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/lib/Geometry/Primitive/Shape.pm000644 000765 000024 00000001361 11322220230 023337 0ustar00gphatstaff000000 000000 package Geometry::Primitive::Shape; use Moose::Role; requires 'point_end'; requires 'point_start'; requires 'scale'; no Moose; 1; __END__ =head1 NAME Geometry::Primitive::Shape - Shape Role =head1 DESCRIPTION Geometry::Primitive::Shape is a geometric shape. =head1 SYNOPSIS with 'Geometry::Primitive::Shape'; has 'point_end' => ' =head1 METHODS =head2 grow Increase the size of this shape by the amount specified. Consult the shape implementation's documentation for this works. =head2 point_end The end point of this shape. =head2 point_start The starting point of this shape. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE You can redistribute and/or modify this code under the same terms as Perl itself.Geometry-Primitive-0.22/inc/Module/000755 000765 000024 00000000000 11322222254 017435 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/inc/Module/Install/000755 000765 000024 00000000000 11322222254 021043 5ustar00gphatstaff000000 000000 Geometry-Primitive-0.22/inc/Module/Install.pm000644 000765 000024 00000024114 11322222251 021400 0ustar00gphatstaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2009 Adam Kennedy. Geometry-Primitive-0.22/inc/Module/Install/Base.pm000644 000765 000024 00000001766 11322222251 022262 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 Geometry-Primitive-0.22/inc/Module/Install/Can.pm000644 000765 000024 00000003333 11322222251 022101 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Geometry-Primitive-0.22/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 11322222251 022440 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Geometry-Primitive-0.22/inc/Module/Install/Makefile.pm000644 000765 000024 00000016003 11322222251 023113 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 394 Geometry-Primitive-0.22/inc/Module/Install/Metadata.pm000644 000765 000024 00000035304 11322222251 023123 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords }; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless $self->author; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than on rt.cpan.org link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Geometry-Primitive-0.22/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 11322222251 022300 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Geometry-Primitive-0.22/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002222 11322222251 023117 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;