Graphics-Primitive-0.61/000755 000765 000024 00000000000 11571676547 015437 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/Changes000644 000765 000024 00000017227 11571676367 016743 0ustar00gphatstaff000000 000000 Revision history for Graphics-Primitive 0.61 Jun 2, 2011 - Fix broken merge (thanks Ansgar Burchardt) 0.60 May 5, 2011 - If minimum_width or minimum_height is set, don't allow height or width to be set to anything smaller! 0.53 Feb 18, 2011 - Add callback to Component 0.52 Aug 21, 2010 - POD updates 0.51 March 22, 2010 - Convert all remaining uses of AttributeHelpers with native traits (Florian Ragwitz). 0.50 March 9, 2010 - Convert Path to use Moose's native traits rather than AttributeHelpers 0.49 January 10th, 2010 - Remove typing for Path's primitives accessor 0.48 December 24th, 2009 - Add _draw_arc to Driver's require 0.47 December 24th, 2009 - Use BUILD and triggers to handle Border's color & width in constructor and via setting width/color. 0.46 November 10th, 2009 - Add JSON::Any dependency (Thanks NPW via RT) 0.45 October 2nd, 2009 - Add antialias_mode, hint_style, hint_metrics and subpixel_order attributes to Font. 0.44 - Fix typo in Canvas' hints attribute 0.43 - README update 0.42 - Reverting 0.41 (ha!) - Add width to insets, sets all insets in one call 0.41 - Don't re-layout already laid out textboxes (might get reverted) 0.40 - Fix some deprecated Moose stuff 0.39 - POD fixes - Don't short-circuit TextBox prepare if there are lines or a layout. - If there's no layout, don't try and create one. This breaks things. 0.38 - Fix error in Component->outside_width 0.37 - More POD fixes 0.36 - POD fixes 0.35 - Gradient: Break out into separate Line and Radial classes 0.34 - Move pod tests to t/author 0.33 - Driver: Don't mark things prepared, that's Layout::Manager's job - TextBox: simplify logic and return from prepare immediately after super if there is no text - TextBox: make some 'enumed' attributes plain Strings, since different drivers will have different values - Remove Text::Flow requirement 0.32 - Fix POD typo (thanks Brian Cassidy) - TextBox: Don't resize during prepare unless it's new minimums are bigger - Fix TextLayout's POD (thanks Brian Cassidy) - Driver: add _draw_bezier to requires (thanks Budrica Petre Cosmin) 0.31 - Fix POD typo (thanks Brian Cassidy) - Driver: Add _draw_circle and _draw_ellipse - Bump Deps - Revamp text handling, see Driver::TextLayout 0.30 - Bump Forest dependency to 0.4 to ease Win32 problems 0.29 - MooseX::Storage support - Rename pack to finalize 0.28 - Require _draw_polygon method for Driver role 0.27 - Fill: Make paint a required attribute - Operations: Make Fill and Stroke clone properly 0.26 - Add Image component (experimental) - POD fixes - Component: make parent a weakref 0.25 - TextBox: Normalize multi-line rendering on line height 0.24 - TextBox: Fix broken multi-line rendering 0.23 - Component: Add parent attribute - Container: Set and unset parent attribute on add/remove/clear - Add Aligned role - Textbox: Use Aligned role - POD updates 0.22 - Properly append component lists in find. 0.21 - Remove duplicate code in Driver's prepare method 0.20 - Fix accidentally marking containers as prepared when they are not 0.19 - Component: Add class attribute - ComponentList: Add each and find 0.18 - Add ComponentList and use it to keep container components. - Container: find_component now returns the component's index, not the component. 0.17 - Useless whitespace changes - POD typos fixed - Border: switch from a single width to per-side Brushes - Brush: add derive, equal_to and not_equal_to - Border: now cloneable - Border: add homogeneous, equal_to and not_equal_to - Insets: ad as_array 0.16 - Opps, I forgot. :( 0.15 - Add prepared flag to components. Attributes that affect rendering have been modified to set prepared to 0 via a trigger. Any new attributes added henceforth should do the same. - Containers (being Components) also have a prepared flag, but it is set to true by the layout manager, not by the container itself. Also, a container is not prepared unless all of it's child components are prepared. See Layout::Manager for more details. - TextBox: Fix bug when prepared & packed with text attribute set - POD 0.14 - TextBox: handle text layout with Text::Flow - Component: coercion of Insets from ArrayRef and Num - Add pop_component to Container for removing the last component. - POD updates - Component: explicitly return from outside_width and outside_height - Component: if minimum width or height are set already, don't change them in prepare - Font: add derive 0.13 - Reorganize prepare/pack/draw API to be handled by the Driver - Add _resize and _finish_page to Driver API - Component: Add page attribute - Driver: Don't check class of incoming component before asking if it has components and treating it like a container. 0.12 - Path: Add curve_to and rel_curve_to 0.11 - Small optimizations - Driver: add reset - Textbox: Add angle - Use Forest rather than Tree::Simple per stevan's request 0.10 - Path: add rectangle - New feature & hint: Add "preserve" to Operation. Setting this causes the canvas to NOT clear the current path on a do(). This operation can then be used as a hint to the driver to not create a new path, but to reuse the old one. 0.09 - Path: add arc, close_path, get_path - Path: rename get_primitive_at to get_primitive - Path: rename count_primitives to primitive_count - Path: clone points rather than using them, they tend to change - Path: don't inherit or implement anything out of Geo::Primitive, it's not necessary - Path: add hints attr with for driver hinting and add contiguous flag for use with same - Gradient: add line attr for guiding Gradient - Canvas: update path proxy methods - Make everything cloneable, adding Clone trait to 'deep' clone attrs 0.08 - Path: default starting point to 0,0 - Rename Graphics::Primitive::Stroke to Graphics::Primitive::Brush - Brush: Add Color - Add Canvas calls to Driver - Add Operation::Fill and Operation::Stroke - Lots of POD - Add Paint and children 0.07 - Remove do_prepare - Add disclaimer - Add lines to Textbox and chop up input, this is likely temporary - Add optional layout manager to container - prepare now expects the driver to be passed in - Component's prepare sets minimum sizes to the outside ones - Return default font size from coderef - Use isa to check component classes and put container at the bottom so that the parent container is drawn before it's children. - Add get_tree method to component for visualizing the entire component - Prepare children before parents - Don't return inside_height or width < 0 - Default Component::prepare to setting a minimum height/width based on outside values - Add Component::to_string - Let Container's layout_manager handle do_layout - Add 'pack' to the plan... - Path: modify line_to and move_to to accept scalars - Stroke: add dash_pattern 0.06 - Add Driver - Set default border width to 0 - Move component management out of LM and into Container - Move stuff from LM::Component role into Component - Remove LM dependency - Add Textbox - Change Component's inside_bounding_box origin to be a relative value 0.05 - Don't prepare or draw invisible components in Containers 0.04 - POD fixes - Add find_component and get_component as proxies in Container 0.03 - Check for definedness of components in a Container before prepare & draw 0.02 - Add visible to component - Fix Description - Add MI version because Yuval yelled at me 0.01 Date/time First version, released on an unsuspecting world. Graphics-Primitive-0.61/inc/000755 000765 000024 00000000000 11571676547 016210 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/lib/000755 000765 000024 00000000000 11571676547 016205 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/Makefile.PL000644 000765 000024 00000000752 11433753343 017400 0ustar00gphatstaff000000 000000 use inc::Module::Install 0.75; name 'Graphics-Primitive'; all_from 'lib/Graphics/Primitive.pm'; author 'Cory G Watson '; build_requires 'Test::More'; requires 'Geometry::Primitive' => '0.16'; requires 'Graphics::Color' => '0.20'; requires 'Moose' => '0.90'; requires 'MooseX::Clone' => '0.04'; requires 'MooseX::Storage' => '0.17'; requires 'Forest' => '0.06'; requires 'JSON::Any' => '1.22'; repository 'git://github.com/gphat/graphics-primitive.git'; WriteAll; Graphics-Primitive-0.61/MANIFEST000644 000765 000024 00000002707 11571676274 016573 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/Graphics/Primitive.pm lib/Graphics/Primitive/Aligned.pm lib/Graphics/Primitive/Border.pm lib/Graphics/Primitive/Brush.pm lib/Graphics/Primitive/Canvas.pm lib/Graphics/Primitive/Component.pm lib/Graphics/Primitive/ComponentList.pm lib/Graphics/Primitive/Container.pm lib/Graphics/Primitive/Driver.pm lib/Graphics/Primitive/Driver/TextLayout.pm lib/Graphics/Primitive/Font.pm lib/Graphics/Primitive/Image.pm lib/Graphics/Primitive/Insets.pm lib/Graphics/Primitive/Operation.pm lib/Graphics/Primitive/Operation/Fill.pm lib/Graphics/Primitive/Operation/Stroke.pm lib/Graphics/Primitive/Oriented.pm lib/Graphics/Primitive/Paint.pm lib/Graphics/Primitive/Paint/Gradient.pm lib/Graphics/Primitive/Paint/Gradient/Linear.pm lib/Graphics/Primitive/Paint/Gradient/Radial.pm lib/Graphics/Primitive/Paint/Solid.pm lib/Graphics/Primitive/Path.pm lib/Graphics/Primitive/TextBox.pm Makefile.PL MANIFEST This list of files META.yml README t/00-load.t t/01-font.t t/01-insets.t t/02-brush.t t/20-border.t t/30-component.t t/35-componentlist.t t/40-container.t t/50-path.t t/55-canvas.t t/60-driver.t t/61-textbox.t t/70-op-fill.t t/70-op-stroke.t t/70-paint-gradient.t t/80-serialize.t t/author/pod-coverage.t t/author/pod.t t/callback.t t/lib/DummyDriver.pm Graphics-Primitive-0.61/META.yml000644 000765 000024 00000001414 11571676546 016707 0ustar00gphatstaff000000 000000 --- abstract: 'Device and library agnostic graphic primitives' author: - 'Cory Watson, C<< >>' - 'Cory G Watson ' build_requires: ExtUtils::MakeMaker: 6.42 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.01' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Graphics-Primitive no_index: directory: - inc - t requires: Forest: 0.06 Geometry::Primitive: 0.16 Graphics::Color: 0.20 JSON::Any: 1.22 Moose: 0.90 MooseX::Clone: 0.04 MooseX::Storage: 0.17 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/gphat/graphics-primitive.git version: 0.61 Graphics-Primitive-0.61/README000644 000765 000024 00000002027 11320171065 016271 0ustar00gphatstaff000000 000000 Graphics::Primitive - Device and library agnostic graphic primitives Graphics::Primitive is a device and library agnostic system for creating and manipulating various graphical elements such as Borders, Fonts, Paths and the like. 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 Graphics::Primitive You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Graphics-Primitive AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Graphics-Primitive CPAN Ratings http://cpanratings.perl.org/d/Graphics-Primitive Search CPAN http://search.cpan.org/dist/Graphics-Primitive COPYRIGHT AND LICENCE Copyright (C) 2008 Cory G Watson This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Graphics-Primitive-0.61/t/000755 000765 000024 00000000000 11571676547 015702 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/t/00-load.t000644 000765 000024 00000000247 11142731754 017210 0ustar00gphatstaff000000 000000 #!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Graphics::Primitive' ); } diag( "Testing Graphics::Primitive $Graphics::Primitive::VERSION, Perl $], $^X" ); Graphics-Primitive-0.61/t/01-font.t000644 000765 000024 00000000623 11433753343 017237 0ustar00gphatstaff000000 000000 use Test::More tests => 5; BEGIN { use_ok('Graphics::Primitive::Font'); } my $obj = Graphics::Primitive::Font->new( family => 'Myriad Pro', size => 15, slant => 'italic', weight => 'bold' ); cmp_ok($obj->family, 'eq', 'Myriad Pro', 'face'); cmp_ok($obj->size, '==', 15, 'size'); cmp_ok($obj->slant, 'eq', 'italic', 'slant'); cmp_ok($obj->weight, 'eq', 'bold', 'weight'); Graphics-Primitive-0.61/t/01-insets.t000644 000765 000024 00000001646 11433753343 017604 0ustar00gphatstaff000000 000000 use Test::More tests => 15; BEGIN { use_ok('Graphics::Primitive::Insets'); } my $obj = Graphics::Primitive::Insets->new( top => 1, bottom => 2, left => 3, right => 4 ); cmp_ok($obj->top, '==', 1, 'top'); cmp_ok($obj->bottom, '==', 2, 'bottoms'); cmp_ok($obj->left, '==', 3, 'left'); cmp_ok($obj->right, '==', 4, 'right'); my $obj2 = Graphics::Primitive::Insets->new( top => 1, bottom => 2, left => 3, right => 5 ); ok($obj->not_equal_to($obj2), 'not equal'); $obj2->right(4); ok($obj->equal_to($obj2), 'equal'); $obj->zero; cmp_ok($obj->top, '==', 0, 'zero top'); cmp_ok($obj->left, '==', 0, 'zero left'); cmp_ok($obj->bottom, '==', 0, 'zero bottom'); cmp_ok($obj->right, '==', 0, 'zero right'); $obj->width(4); cmp_ok($obj->top, '==', 4, 'width, top'); cmp_ok($obj->left, '==', 4, 'width, left'); cmp_ok($obj->bottom, '==', 4, 'width, bottom'); cmp_ok($obj->right, '==', 4, 'width, right');Graphics-Primitive-0.61/t/02-brush.t000644 000765 000024 00000001301 11433753343 017407 0ustar00gphatstaff000000 000000 use Test::More tests => 8; BEGIN { use_ok('Graphics::Primitive::Brush'); } my $obj = Graphics::Primitive::Brush->new( width => 3, line_cap => 'round', line_join => 'bevel' ); cmp_ok($obj->width, '==', 3, 'width'); cmp_ok($obj->line_cap, 'eq', 'round', 'line_cap'); cmp_ok($obj->line_join, 'eq', 'bevel', 'line_join'); my $obj2 = $obj->clone; ok($obj2->equal_to($obj), 'equal_to'); $obj->dash_pattern([ 1, 2, 3]); $obj2->dash_pattern([ 1, 2, 3]); ok($obj2->equal_to($obj), 'equal_to - dash_pattern'); my $obj3 = $obj->derive({ width => 4 }); ok($obj3->not_equal_to($obj), 'not_equal_to'); $obj2->dash_pattern([ 1, 2, 4]); ok($obj2->not_equal_to($obj), 'not_equal_to - dash_pattern');Graphics-Primitive-0.61/t/20-border.t000644 000765 000024 00000002336 11433753343 017552 0ustar00gphatstaff000000 000000 use Test::More; BEGIN { use_ok('Graphics::Primitive::Border'); } use Graphics::Color::RGB; my $color = Graphics::Color::RGB->new(red => .3); my $obj = Graphics::Primitive::Border->new; $obj->color($color); $obj->width(3); cmp_ok($obj->left->color->red, '==', $color->red, 'left color'); cmp_ok($obj->right->color->red, '==', $color->red, 'right color'); cmp_ok($obj->top->color->red, '==', $color->red, 'top color'); cmp_ok($obj->bottom->color->red, '==', $color->red, 'bottom color'); cmp_ok($obj->left->width, '==', 3, 'left width'); cmp_ok($obj->right->width, '==', 3, 'right width'); cmp_ok($obj->top->width, '==', 3, 'top width'); cmp_ok($obj->bottom->width, '==', 3, 'bottom width'); my $other = $obj->clone; ok($obj->equal_to($other), 'equal_to'); my $color2 = Graphics::Color::RGB->new(red => 1, green => .3); $other->left->color($color2); ok($obj->not_equal_to($other), 'not_equal_to'); ok(!$other->homogeneous, 'not homogeneous'); $other->width(3); $other->color($color); ok($other->homogeneous, 'homogenous'); my $b2 = Graphics::Primitive::Border->new( color => $color, width => 5 ); cmp_ok($b2->top->width, '==', 5, 'width in constructor'); cmp_ok($b2->top->color->red, '==', .3, 'color in constructor'); done_testing;Graphics-Primitive-0.61/t/30-component.t000644 000765 000024 00000004242 11433753343 020276 0ustar00gphatstaff000000 000000 use Test::More tests => 19; BEGIN { use_ok('Graphics::Primitive::Component'); } use Graphics::Color::RGB; use Geometry::Primitive::Point; use Graphics::Primitive::Border; use Graphics::Primitive::Insets; my $color = Graphics::Color::RGB->new(); my $color2 = Graphics::Color::RGB->new(red => .58); my $border = Graphics::Primitive::Border->new; $border->width(2); my $margins = Graphics::Primitive::Insets->new( top => 5, left => 6, bottom => 7, right => 8 ); my $padding = Graphics::Primitive::Insets->new( top => 1, left => 2, bottom => 3, right => 4 ); my $point = Geometry::Primitive::Point->new( x => 5, y => 6 ); my $obj = Graphics::Primitive::Component->new( background_color => $color, border => $border, color => $color2, origin => $point, margins => $margins, padding => $padding, width => 100, height => 200 ); cmp_ok($obj->background_color->red, '==', $color->red, 'background color'); cmp_ok($obj->color->red, '==', $color2->red, 'color'); cmp_ok($obj->border->left->width, '==', 2, 'border'); ok($obj->origin->equal_to($point), 'origin'); ok($obj->margins->equal_to($margins), 'margins'); ok($obj->padding->equal_to($padding), 'padding'); cmp_ok($obj->width, '==', 100, 'width'); cmp_ok($obj->height, '==', 200, 'height'); cmp_ok($obj->visible, '==', 1, 'visible'); cmp_ok($obj->inside_width, '==', 76, 'inside_width'); cmp_ok($obj->inside_height, '==', 180, 'inside_height'); my $ulip = Geometry::Primitive::Point->new(x => 10, y => 8); my $bb = $obj->inside_bounding_box; ok($bb->origin->equal_to($ulip), 'bounding box'); $obj->prepared(1); cmp_ok($obj->prepared, '==', 1, 'prepared'); $obj->width(101); cmp_ok($obj->prepared, '==', 0, 'not prepared'); $obj->width(100); $obj->border->left->width(3); cmp_ok($obj->inside_width, '==', 75, 'left border width'); $obj->border->right->width(3); cmp_ok($obj->inside_width, '==', 74, 'right border width'); $obj->height(200); $obj->border->top->width(3); cmp_ok($obj->inside_height, '==', 179, 'top border width'); $obj->border->bottom->width(3); cmp_ok($obj->inside_height, '==', 178, 'bottom border width'); Graphics-Primitive-0.61/t/35-componentlist.t000644 000765 000024 00000005044 11433753343 021200 0ustar00gphatstaff000000 000000 use strict; use Test::More tests => 13; use Graphics::Primitive::Component; use Graphics::Primitive::Container; BEGIN { use_ok('Graphics::Primitive::ComponentList'); } my $list = Graphics::Primitive::ComponentList->new; isa_ok($list, 'Graphics::Primitive::ComponentList'); my $comp1 = Graphics::Primitive::Component->new(name => 'first', class => 'bar'); $list->add_component($comp1); cmp_ok($list->component_count, '==', 1, 'component_count'); my $comp2 = Graphics::Primitive::Component->new(name => 'second', class => 'bar'); $list->add_component($comp2); cmp_ok($list->component_count, '==', 2, 'component_count'); my $comp3 = Graphics::Primitive::Component->new(name => 'three', class => '2'); $list->add_component($comp3); my $foundi = $list->find_component('first'); my $found = $list->get_component($foundi); cmp_ok($found->name, 'eq', 'first', 'found first by name'); my $index1 = $list->get_component(0); cmp_ok($index1->name, 'eq', 'first', 'found first by index'); my $index2 = $list->get_component(1); cmp_ok($index2->name, 'eq', 'second', 'found second by index'); my $flist = $list->find(sub{ my ($comp, $const) = @_; return $comp->class eq 'bar' }); cmp_ok($flist->component_count, '==', 2, 'find list count'); $flist->each(sub { my ($comp, $const) = @_; $comp->name('foo'); }); cmp_ok($comp1->name, 'eq', 'foo', 'each changed component 1'); cmp_ok($comp2->name, 'eq', 'foo', 'each changed component 2'); $list->find(sub { my ($comp, $const) = @_; return $comp->name eq 'foo' }) ->each(sub { my ($comp, $const) = @_; $comp->class('bar') }); cmp_ok($comp1->class, 'eq', 'bar', 'find->each changed component 1 class'); cmp_ok($comp2->class, 'eq', 'bar', 'find->each changed component 2 class'); my $cont1 = Graphics::Primitive::Container->new; $cont1->add_component($comp1); $cont1->add_component($comp2); $cont1->add_component($comp3); my $comp4 = Graphics::Primitive::Component->new(name => 'four', class => 'gorch'); my $comp5 = Graphics::Primitive::Component->new(name => 'five', class => 'baz'); my $cont2 = Graphics::Primitive::Container->new; $cont2->add_component($comp4); $cont2->add_component($comp5); my $comp6 = Graphics::Primitive::Component->new(name => 'six', class => 'gorch'); my $cont3 = Graphics::Primitive::Container->new; $cont3->add_component($comp6); $cont1->add_component($cont2); $cont1->add_component($cont3); my $gorchlist = $cont1->find(sub { my ($comp, $const) = @_; return 0 unless defined($comp->class); return $comp->class eq 'gorch' }); cmp_ok($gorchlist->component_count, '==', 2, 'sub-container find count'); Graphics-Primitive-0.61/t/40-container.t000644 000765 000024 00000002516 11433753343 020261 0ustar00gphatstaff000000 000000 use strict; use Test::More tests => 12; BEGIN { use_ok('Graphics::Primitive::Container'); } use Graphics::Primitive::Component; my $cont = Graphics::Primitive::Container->new(name => 'root'); isa_ok($cont, 'Graphics::Primitive::Container'); my $comp1 = Graphics::Primitive::Component->new(name => 'first'); $cont->add_component($comp1); cmp_ok($cont->component_count, '==', 1, 'component_count'); cmp_ok($comp1->parent->name, 'eq', $cont->name, 'parent'); my $comp2 = Graphics::Primitive::Component->new(name => 'second'); $cont->add_component($comp2); cmp_ok($cont->component_count, '==', 2, 'component_count'); my $foundi = $cont->find_component('first'); my $found = $cont->get_component($foundi); cmp_ok($found->name, 'eq', 'first', 'found first by name'); my $index1 = $cont->get_component(0); cmp_ok($index1->name, 'eq', 'first', 'found first by index'); my $index2 = $cont->get_component(1); cmp_ok($index2->name, 'eq', 'second', 'found second by index'); $cont->prepared(1); cmp_ok($cont->prepared, '==', 1, 'prepared'); my $comp3 = Graphics::Primitive::Component->new; $cont->add_component($comp3); cmp_ok($cont->prepared, '==', 0, 'not prepared'); my $removed = $cont->remove_component($comp2); ok(!defined($comp2->parent), 'no parent after removal'); $cont->clear_components; ok(!defined($comp1->parent), 'no parent after clear');Graphics-Primitive-0.61/t/50-path.t000644 000765 000024 00000003154 11433753343 017233 0ustar00gphatstaff000000 000000 use strict; use Test::More tests => 14; BEGIN { use_ok('Graphics::Primitive::Path'); use_ok('Geometry::Primitive::Rectangle'); }; my $path = Graphics::Primitive::Path->new; cmp_ok($path->primitive_count, '==', 0, 'primitive count'); my $start = Geometry::Primitive::Point->new(x => 0, y => 0); $path->current_point($start); ok($path->current_point->equal_to($start), 'current_point'); # Add A Line my $line_end = Geometry::Primitive::Point->new(x => 10, y => 0); $path->line_to($line_end); ok($path->current_point->equal_to($line_end), 'line set current_point'); cmp_ok($path->primitive_count, '==', 1, 'primitive count'); # Move to, no primitives my $mover = Geometry::Primitive::Point->new(x => 10, y => 10); $path->move_to($mover); ok($path->current_point->equal_to($mover), 'move_to set current_point'); cmp_ok($path->primitive_count, '==', 1, 'primitive count after move_to'); # Move to again, no primitive $path->move_to(12, 12); cmp_ok($path->current_point->x, '==', 12, 'move to with scalars'); $path->rel_move_to(5, 4); my $chkpt = Geometry::Primitive::Point->new(x => 17, y => 16); ok($path->current_point->equal_to($chkpt), 'rel_move_to'); $path->close_path; my $line = $path->get_primitive($path->primitive_count - 1); isa_ok($line, 'Geometry::Primitive::Line'); $chkpt->x(0); $chkpt->y(0); ok($line->point_end->equal_to($chkpt), 'close path'); $path->arc(5, 0, 1.7); my $a_line = $path->get_primitive($path->primitive_count - 2); my $arc = $path->get_primitive($path->primitive_count - 1); ok($path->current_point->equal_to($arc->point_end), 'post arc current_point'); isa_ok($line, 'Geometry::Primitive::Line'); Graphics-Primitive-0.61/t/55-canvas.t000644 000765 000024 00000003107 11433753343 017555 0ustar00gphatstaff000000 000000 use Test::More tests => 16; use Geometry::Primitive; BEGIN { use_ok('Graphics::Primitive::Canvas'); use_ok('Graphics::Primitive::Operation::Stroke'); } my $canvas = Graphics::Primitive::Canvas->new; isa_ok($canvas, 'Graphics::Primitive::Canvas'); my $point = Geometry::Primitive::Point->new(x => 0, y => 0); ok($canvas->current_point->equal_to($point), 'starting point'); $canvas->move_to(5, 5); $point->x(5); $point->y(5); ok($canvas->current_point->equal_to($point), 'move_to'); $canvas->save; $canvas->move_to(11, 5); $point->x(11); $point->y(5); ok($canvas->current_point->equal_to($point), 'move_to after save'); $canvas->restore; $point->x(5); $point->y(5); ok($canvas->current_point->equal_to($point), 'current after restore'); $point->x(12); ok(!$canvas->current_point->equal_to($point), 'cloned'); $canvas->save; cmp_ok($canvas->path->primitive_count, '==', 0, '0 primitives'); $canvas->do(Graphics::Primitive::Operation::Stroke->new); $point->x(0); $point->y(0); ok($canvas->current_point->equal_to($point), 'current after do'); $canvas->restore; $point->x(5); $point->y(5); ok($canvas->current_point->equal_to($point), 'current after restore'); $canvas->line_to(100, 100); cmp_ok($canvas->path->primitive_count, '==', 1, '1 primitive'); $canvas->line_to(100, 100); cmp_ok($canvas->get_path(0)->{path}->primitive_count, '==', 0, '0 primitives'); cmp_ok($canvas->path_count, '==', 1, '1 path'); $canvas->do(Graphics::Primitive::Operation::Stroke->new); cmp_ok($canvas->path->primitive_count, '==', 0, 'fresh path'); cmp_ok($canvas->path_count, '==', 2, 'path count'); Graphics-Primitive-0.61/t/60-driver.t000644 000765 000024 00000001105 11433753343 017565 0ustar00gphatstaff000000 000000 use lib 't/lib', 'lib'; use strict; use Test::More tests => 4; use Graphics::Primitive::Component; use Graphics::Primitive::Container; BEGIN { use_ok('Graphics::Primitive::Driver'); use_ok('DummyDriver'); } my $driver = DummyDriver->new; isa_ok($driver, 'DummyDriver'); my $container = Graphics::Primitive::Container->new; my $comp = Graphics::Primitive::Component->new; $container->add_component($comp, 'c'); $driver->prepare($container); $driver->finalize($container); $driver->draw($container); cmp_ok($driver->draw_component_called, '==', 2, 'component draws'); Graphics-Primitive-0.61/t/61-textbox.t000644 000765 000024 00000001054 11433753343 017773 0ustar00gphatstaff000000 000000 use strict; use Test::More tests => 7; use Graphics::Primitive::Font; BEGIN { use_ok('Graphics::Primitive::TextBox'); } my $tb = Graphics::Primitive::TextBox->new; isa_ok($tb, 'Graphics::Primitive::TextBox'); cmp_ok($tb->prepared, '==', 0, 'not prepared'); $tb->prepared(1); cmp_ok($tb->prepared, '==', 1, 'prepared'); $tb->text('Different'); cmp_ok($tb->prepared, '==', 0, 'not prepared'); cmp_ok($tb->horizontal_alignment, 'eq', 'left', 'default horizontal alignment'); cmp_ok($tb->vertical_alignment, 'eq', 'top', 'default vertical alignment');Graphics-Primitive-0.61/t/70-op-fill.t000644 000765 000024 00000000453 11433753343 017642 0ustar00gphatstaff000000 000000 use Test::More tests => 2; use Graphics::Primitive::Paint::Solid; BEGIN { use_ok('Graphics::Primitive::Operation::Fill'); } my $stroke = Graphics::Primitive::Operation::Fill->new( paint => Graphics::Primitive::Paint::Solid->new ); isa_ok($stroke, 'Graphics::Primitive::Operation::Fill'); Graphics-Primitive-0.61/t/70-op-stroke.t000644 000765 000024 00000000322 11433753343 020216 0ustar00gphatstaff000000 000000 use Test::More tests => 2; BEGIN { use_ok('Graphics::Primitive::Operation::Stroke'); } my $stroke = Graphics::Primitive::Operation::Stroke->new; isa_ok($stroke, 'Graphics::Primitive::Operation::Stroke'); Graphics-Primitive-0.61/t/70-paint-gradient.t000644 000765 000024 00000002230 11433753343 021201 0ustar00gphatstaff000000 000000 use Test::More tests => 7; use Geometry::Primitive::Circle; use Geometry::Primitive::Line; use Graphics::Color::RGB; BEGIN { use_ok('Graphics::Primitive::Paint::Gradient::Linear'); use_ok('Graphics::Primitive::Paint::Gradient::Radial'); } my $line = Graphics::Primitive::Paint::Gradient::Linear->new( line => Geometry::Primitive::Line->new( start => [0, 0], end => [10, 10] ) ); isa_ok($line, 'Graphics::Primitive::Paint::Gradient::Linear'); my $red = Graphics::Color::RGB->new(red => 1, green => 0, blue => 0); my $blue = Graphics::Color::RGB->new(red => 0, green => 0, blue => 1); cmp_ok($line->stop_count, '==', 0, 'stop count'); $line->add_stop(0.0, $red); cmp_ok($line->stop_count, '==', 1, 'stop count'); $line->add_stop(0.75, $blue); my @stops = $line->stops; cmp_ok(scalar(@stops), '==', 2, '2 stops'); my $rad = Graphics::Primitive::Paint::Gradient::Radial->new( start => Geometry::Primitive::Circle->new( origin => [0, 0], radius => 5 ), end => Geometry::Primitive::Circle->new( origin => [10, 10], radius => 3 ) ); isa_ok($rad, 'Graphics::Primitive::Paint::Gradient::Radial'); Graphics-Primitive-0.61/t/80-serialize.t000644 000765 000024 00000001613 11433753343 020267 0ustar00gphatstaff000000 000000 use strict; use Test::More tests => 4; use Graphics::Color::RGB; use Graphics::Primitive::Brush; use Graphics::Primitive::Border; use Graphics::Primitive::Insets; use Graphics::Primitive::Component; my $brush = Graphics::Primitive::Brush->new; my $brush2 = Graphics::Primitive::Brush->unpack($brush->pack); ok($brush->equal_to($brush2), 'brush equal_to'); my $border = Graphics::Primitive::Border->new; my $border2 = Graphics::Primitive::Border->unpack($border->pack); ok($border->equal_to($border2), 'border equal_to'); my $insets = Graphics::Primitive::Insets->new; my $insets2 = Graphics::Primitive::Insets->unpack($insets->pack); ok($insets->equal_to($insets2), 'insets equal_to'); my $comp = Graphics::Primitive::Component->new( width => 100, height => 50, name => 'foo' ); my $comp2 = Graphics::Primitive::Component->thaw($comp->freeze); is_deeply($comp, $comp2, 'component clone'); Graphics-Primitive-0.61/t/author/000755 000765 000024 00000000000 11571676547 017204 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/t/callback.t000644 000765 000024 00000001502 11571676274 017616 0ustar00gphatstaff000000 000000 use lib 't/lib', 'lib'; use strict; use Test::More; use Graphics::Primitive::Component; use Graphics::Primitive::Container; BEGIN { use_ok('Graphics::Primitive::Driver'); use_ok('DummyDriver'); } my $driver = DummyDriver->new; isa_ok($driver, 'DummyDriver'); my $container = Graphics::Primitive::Container->new(class => 'container'); my $comp = Graphics::Primitive::Component->new(class => 'component'); my $comp_call = 0; $comp->callback(sub { $comp_call = $_[0]->class }); $container->add_component($comp, 'c'); my $cont_call = 0; use Data::Dumper; $container->callback(sub { $cont_call = $_[0]->class }); $driver->prepare($container); $driver->finalize($container); cmp_ok($cont_call, 'eq', 'container', 'container callback fired'); cmp_ok($comp_call, 'eq', 'component', 'component callback fired'); done_testing;Graphics-Primitive-0.61/t/lib/000755 000765 000024 00000000000 11571676547 016450 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/t/lib/DummyDriver.pm000644 000765 000024 00000001342 11433753343 021240 0ustar00gphatstaff000000 000000 package # hide from the CPAN DummyDriver; use Moose; with 'Graphics::Primitive::Driver'; has 'draw_component_called' => ( is => 'rw', isa => 'Int', default => sub { 0 } ); sub _do_fill { } sub _do_stroke { } sub _draw_arc { } sub _draw_bezier { } sub _draw_canvas { } sub _draw_circle { } sub _draw_component { my ($self, $comp) = @_; $self->draw_component_called( $self->draw_component_called + 1 ); } sub _draw_ellipse { } sub _draw_line { } sub _draw_path { } sub _draw_polygon { } sub _draw_rectangle { } sub _draw_textbox { } sub _finish_page { } sub _resize { } sub data { } sub get_text_bounding_box { } sub get_textbox_layout { } sub reset { } sub write { } no Moose; 1;Graphics-Primitive-0.61/t/author/pod-coverage.t000644 000765 000024 00000001323 11433753343 021726 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 $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::Moose' }); Graphics-Primitive-0.61/t/author/pod.t000644 000765 000024 00000000350 11433753343 020134 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(); Graphics-Primitive-0.61/lib/Graphics/000755 000765 000024 00000000000 11571676547 017745 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/lib/Graphics/Primitive/000755 000765 000024 00000000000 11571676547 021715 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/lib/Graphics/Primitive.pm000644 000765 000024 00000006103 11571676427 022250 0ustar00gphatstaff000000 000000 package Graphics::Primitive; use Moose; our $VERSION = '0.61'; __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive - Device and library agnostic graphic primitives =cut =head1 SYNOPSIS Graphics::Primitive is a device and library agnostic system for creating and manipulating various graphical elements such as Borders, Fonts, Paths and the like. my $c = Graphics::Primitive::Component->new( background_color => Graphics::Color::RGB->new( red => 1, green => 0, blue => 0 ), width => 500, height => 350, border => new Graphics::Primitive::Border->new( width => 5 ) ); my $driver = Graphics::Primitive::Driver::Cairo->new(format => 'SVG'); $driver->prepare($c); $driver->finalize($c); $driver->draw($c); $driver->write($filename) =head1 DESCRIPTION Graphics::Primitive is library agnostic system for drawing things. The idea is to allow you to create and manipulate graphical components and then pass them off to a L for actual drawing. =head1 CONCEPTS The root object for Graphics::Primitive is the L. Components contain all the common elements that you'd expect: margins, padding, background color etc. The next most important is the L. Containers are Components that can hold other Components. Containers have all the attributes and methods of a Component with the addition of the I attribute for us with L. Another important Component is the L. The Canvas differs from other components by being a container for various L objects. This allows drawing of arbitrary shapes that do not fit existing components. =head1 DRAWING LIFECYCLE After creating all your components, there is a lifecycle that allows them to do their internal housekeeping to prepare for eventual drawing. The lifecycle is: B, B and B. Detailed explanation of these methods can be found in L. =head1 PREPARATION Graphics::Primitive::Component has a C flag. This flag is set as part of the C method (shocking, I know). If this flag is set, then subsequent calls to C are ignored. Containers also have a prepare flag, but this flag is B set when calling C. A Container's flag should be set by the layout manager. More information may be found with L. =head1 INSPIRATION Most of the concepts that you'll find in Graphics::Primitive are inspired by L's API and L's box model. =head1 AUTHOR Cory Watson, C<< >> =head1 CONTRIBUTORS Florian Ragwitz =head1 ACKNOWLEDGEMENTS Many of the ideas here come from my experience using the Cairo library. =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Aligned.pm000644 000765 000024 00000002574 11433753345 023613 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Aligned; use Moose::Role; use Moose::Util::TypeConstraints; enum 'Graphics::Primitive::Alignment::Horizontals' => qw(center left right); enum 'Graphics::Primitive::Alignment::Verticals' => qw(bottom center top); has 'horizontal_alignment' => ( is => 'rw', isa => 'Graphics::Primitive::Alignment::Horizontals', ); has 'vertical_alignment' => ( is => 'rw', isa => 'Graphics::Primitive::Alignment::Verticals', ); no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Aligned - Role for components that care about alignment. =head1 SYNOPSIS Some components (or things that use components) require a bit more information than origin and width/height. The alignment role allows a component to specify it's horizontal and vertical alignment. package My::Component; extends 'Graphics::Primitive::Component'; with 'Graphics::Primitive::Aligned'; 1; =head1 METHODS =head2 horizontal_alignment Horizontal alignment value. Valid values are 'center', 'left' and 'right'. =head2 vertical_alignment Vertical alignment value. Valid values are 'bottom', 'center' and 'top'. =head1 AUTHOR Cory Watson, C<< >> =head1 SEE ALSO perl(1) =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Border.pm000644 000765 000024 00000011376 11433753624 023465 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Border; use Moose; use MooseX::Storage; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); use Graphics::Color; use Graphics::Primitive::Brush; has 'bottom' => ( is => 'rw', isa => 'Graphics::Primitive::Brush', default => sub { Graphics::Primitive::Brush->new }, traits => [qw(Clone)] ); has 'color' => ( is => 'rw', isa => 'Graphics::Color', trigger => sub { my ($self, $newval) = @_; $self->bottom->color($newval); $self->left->color($newval); $self->right->color($newval); $self->top->color($newval); }, predicate => 'has_color' ); has 'left' => ( is => 'rw', isa => 'Graphics::Primitive::Brush', default => sub { Graphics::Primitive::Brush->new }, traits => [qw(Clone)] ); has 'right' => ( is => 'rw', isa => 'Graphics::Primitive::Brush', default => sub { Graphics::Primitive::Brush->new }, traits => [qw(Clone)] ); has 'top' => ( is => 'rw', isa => 'Graphics::Primitive::Brush', default => sub { Graphics::Primitive::Brush->new }, traits => [qw(Clone)] ); has 'width' => ( is => 'rw', isa => 'Int', trigger => sub { my ($self, $newval) = @_; $self->bottom->width($newval); $self->left->width($newval); $self->right->width($newval); $self->top->width($newval); }, predicate => 'has_width' ); __PACKAGE__->meta->make_immutable; sub BUILD { my ($self) = @_; if($self->has_width) { my $w = $self->width; $self->bottom->width($w); $self->left->width($w); $self->right->width($w); $self->top->width($w); } if($self->has_color) { my $c = $self->color; $self->bottom->color($c); $self->left->color($c); $self->right->color($c); $self->top->color($c); } } # sub color { # my ($self, $c) = @_; # # $self->bottom->color($c); # $self->left->color($c); # $self->right->color($c); # $self->top->color($c); # } sub dash_pattern { my ($self, $d) = @_; $self->bottom->dash_pattern($d); $self->left->dash_pattern($d); $self->right->dash_pattern($d); $self->top->dash_pattern($d); } sub equal_to { my ($self, $other) = @_; unless($self->top->equal_to($other->top)) { return 0; } unless($self->right->equal_to($other->right)) { return 0; } unless($self->bottom->equal_to($other->bottom)) { return 0; } unless($self->left->equal_to($other->left)) { return 0; } return 1; } sub homogeneous { my ($self) = @_; my $b = $self->top; unless($self->bottom->equal_to($b) && $self->left->equal_to($b) && $self->right->equal_to($b)) { return 0; } return 1; } sub not_equal_to { my ($self, $other) = @_; return !$self->equal_to($other); } # sub width { # my ($self, $w) = @_; # # $self->bottom->width($w); # $self->left->width($w); # $self->right->width($w); # $self->top->width($w); # } no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Border - Line around components =head1 DESCRIPTION Graphics::Primitive::Border describes the border to be rendered around a component. =head1 SYNOPSIS use Graphics::Primitive::Border; my $border = Graphics::Primitive::Border->new; =head1 METHODS =head2 new Creates a new Graphics::Primitiver::Border. Borders are composed of 4 brushes, one for each of the 4 sides. See the documentation for L for more information. Note that you can provide a C and C argument to the constructor and it will create brushes of that width for each side. =head2 bottom The brush representing the bottom border. =head2 clone Close this border. =head2 color Set the Color on all 4 borders to the one supplied. Shortcut for setting it with each side. =head2 dash_pattern Set the dash pattern on all 4 borders to the one supplied. Shortcut for setting it with each side. =head2 equal_to ($other) Returns 1 if this border is equal to the one provided, else returns 0. =head2 homogeneous Returns 1 if all of this border's sides are the same. Allows for driver optimizations. =head2 left The brush representing the left border. =head2 not_equal_to Opposite of C. =head2 right The brush representing the right border. =head2 top The brush representing the top border. =head2 width Set the width on all 4 borders to the one supplied. Shortcut for setting it with each side. =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Brush.pm000644 000765 000024 00000007206 11433753624 023330 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Brush; use Moose; use Moose::Util::TypeConstraints; use MooseX::Storage; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); enum 'LineCap' => qw(butt round square); enum 'LineJoin' => qw(miter round bevel); has 'color' => ( is => 'rw', isa => 'Graphics::Color', traits => [qw(Clone)] ); has 'dash_pattern' => ( is => 'rw', isa => 'ArrayRef' ); has 'width' => ( is => 'rw', isa => 'Int', default => sub { 0 } ); has 'line_cap' => ( is => 'rw', isa => 'LineCap', default => 'butt' ); has 'line_join' => ( is => 'rw', isa => 'LineJoin', default => 'miter' ); __PACKAGE__->meta->make_immutable; sub derive { my ($self, $args) = @_; return unless ref($args) eq 'HASH'; my $new = $self->clone; foreach my $key (keys %{ $args }) { $new->$key($args->{$key}) if($new->can($key)); } return $new; } sub equal_to { my ($self, $other) = @_; return 0 unless defined($other); unless($self->width == $other->width) { return 0; } unless($self->line_cap eq $other->line_cap) { return 0; } unless($self->line_join eq $other->line_join) { return 0; } if(defined($self->color)) { unless($self->color->equal_to($other->color)) { return 0; } } else { if(defined($other->color)) { return 0; } } if(defined($self->dash_pattern)) { unless(scalar(@{ $self->dash_pattern }) == scalar(@{ $other->dash_pattern })) { return 0; } for(my $i = 0; $i < scalar(@{ $self->dash_pattern }); $i++) { unless($self->dash_pattern->[$i] == $other->dash_pattern->[$i]) { return 0; } } } else { if(defined($other->dash_pattern)) { return 0; } } return 1; } sub not_equal_to { my ($self, $other) = @_; return !$self->equal_to($other); } no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Brush - Description of a stroke =head1 DESCRIPTION Graphics::Primitive::Brush represents the visible trace of 'ink' along a path. =head1 SYNOPSIS use Graphics::Primitive::Brush; my $stroke = Graphics::Primitive::Brush->new({ line_cap => 'round', line_join => 'miter', width => 2 }); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Brush. Defaults to a width of 1, a line_cap 'butt' and a line_join of 'miter'. =back =head2 Instance Methods =over 4 =item I Set/Get this brush's color. =item I Set/Get the dash pattern. A dash pattern is an arrayref of numbers representing the lengths of the various line segments of the dash. Even numbered elements are considered opaque and odd elements are transparent. =item I Clone this brush but change one or more of it's attributes by passing in a hashref of options: my $new = $brush->derive({ attr => $newvalue }); The returned font will be identical to the cloned one, save the attributes specified. =item I Returns 1 if this brush is equal to the supplied one, else returns 0. =item I Set/Get the line_cap of this stroke. Valid values are butt, round and square. =item I Set/Get the line_join of this stroke. Valid values are miter, round and bevel. =item I Opposite of equal_to. =item I Set/Get the width of this stroke. Defaults to 1 =back =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Canvas.pm000644 000765 000024 00000007604 11433753624 023462 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Canvas; use Moose; use MooseX::Storage; extends 'Graphics::Primitive::Component'; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); use Graphics::Primitive::Path; has path => ( isa => 'Graphics::Primitive::Path', is => 'rw', default => sub { Graphics::Primitive::Path->new }, handles => [ 'arc', 'close_path', 'current_point', 'curve_to', 'line_to', 'move_to', 'rectangle', 'rel_curve_to', 'rel_line_to', 'rel_move_to' ] ); has paths => ( traits => [qw(Array Clone)], isa => 'ArrayRef', is => 'rw', default => sub { [] }, handles => { add_path => 'push', path_count => 'count', get_path => 'get', } ); has saved_paths => ( traits => [qw(Array Copy)], isa => 'ArrayRef', is => 'rw', default => sub { [] }, handles => { push_path => 'push', pop_path => 'pop', saved_path_count => 'count', } ); sub do { my ($self, $op) = @_; $self->add_path({ op => $op, path => $self->path->clone }); # Don't replace the current path if we are preserving. unless($op->preserve) { $self->path(Graphics::Primitive::Path->new); } } sub save { my ($self) = @_; $self->push_path($self->path->clone); } sub restore { my ($self) = @_; return if($self->saved_path_count < 1); $self->path($self->pop_path); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Canvas - Component composed of paths =head1 DESCRIPTION Graphics::Primitive::Canvas is a component for drawing arbitrary things. It holds L and L. =head1 SYNOPSIS use Graphics::Primitive::Canvas; my $canvas = Graphics::Primitive::Canvas->new; $canvas->move_to($point); # or just $x, $y $canvas->do($op); =head1 DESCRIPTION The Canvas is a container for multiple L. It has a I that is the operative path for all path-related methods. You can treat the Canvas as if it was a path, calling methods like I or I. When you are ready to perform an operation on the path, call the I method with the operation you want to call as an argument. Drawing a line and stroking it would look like: $canvas->move_to(0, 0); $canvas->line_to(10, 10); my $op = Graphics::Primitive::Operation::Stroke->new; $stroke->brush->color( Graphics::Color::RGB->new(red => 0, blue => 1, green => 1) ); $canvas->do($op); When you instantiate a Canvas a newly instantiated path resides in I. After you call I that current path is moved to the I list and new path is placed in I. If you want to keep the path around you can call I before I then call I to put a saved copy of the path back into I. =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Canvas =back =head2 Instance Methods =over 4 =item I Given an operation, pushes the current path onto the path stack. FIXME: Example =item I The current path this canvas is using. =item I Count of paths in I. =item I Arrayref of hashrefs representing paths combined with their operations: [ { path => $path, op => $op }, ] =item I Replace the current path by popping the top path from the saved path list. =item I Copy the current path and push it onto the stack of saved paths. =item I List of saved paths. Add to the list with I and pop from it using I. =item I Count of paths saved in I. =back =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Component.pm000644 000765 000024 00000031050 11571676275 024212 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Component; use Moose; use MooseX::Storage; use overload ('""' => 'to_string'); with Storage('format' => 'JSON', 'io' => 'File'); use Forest::Tree; use Graphics::Primitive::Border; use Graphics::Primitive::Insets; use Geometry::Primitive::Point; use Geometry::Primitive::Rectangle; has 'background_color' => ( is => 'rw', isa => 'Graphics::Color', trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'border' => ( is => 'rw', isa => 'Graphics::Primitive::Border', default => sub { Graphics::Primitive::Border->new }, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'callback' => ( traits => ['Code'], is => 'rw', isa => 'CodeRef', predicate => 'has_callback', handles => { fire_callback => 'execute' } ); has 'class' => ( is => 'rw', isa => 'Str' ); has 'color' => ( is => 'rw', isa => 'Graphics::Color', trigger => sub { my ($self) = @_; $self->prepared(0); }, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'height' => ( is => 'rw', isa => 'Num', default => sub { 0 }, trigger => sub { my ($self) = @_; $self->prepared(0); if($self->height < $self->minimum_height) { $self->height($self->minimum_height); } } ); has 'margins' => ( is => 'rw', isa => 'Graphics::Primitive::Insets', default => sub { Graphics::Primitive::Insets->new }, coerce => 1, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'minimum_height' => ( is => 'rw', isa => 'Num', default => sub { 0 }, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'minimum_width' => ( is => 'rw', isa => 'Num', default => sub { 0 }, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'name' => ( is => 'rw', isa => 'Str' ); has 'origin' => ( is => 'rw', isa => 'Geometry::Primitive::Point', default => sub { Geometry::Primitive::Point->new( x => 0, y => 0 ) }, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'padding' => ( is => 'rw', isa => 'Graphics::Primitive::Insets', default => sub { Graphics::Primitive::Insets->new }, coerce => 1, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'page' => ( is => 'rw', isa => 'Bool', default => sub { 0 } ); has 'parent' => ( is => 'rw', isa => 'Maybe[Graphics::Primitive::Component]', weak_ref => 1 ); has 'prepared' => ( is => 'rw', isa => 'Bool', default => sub { 0 } ); has 'visible' => ( is => 'rw', isa => 'Bool', default => sub { 1 } ); has 'width' => ( is => 'rw', isa => 'Num', default => sub { 0 }, trigger => sub { my ($self) = @_; $self->prepared(0); if($self->width < $self->minimum_width) { $self->width($self->minimum_width); } } ); sub get_tree { my ($self) = @_; return Forest::Tree->new(node => $self); } sub inside_width { my ($self) = @_; my $w = $self->width; my $padding = $self->padding; my $margins = $self->margins; my $border = $self->border; $w -= $padding->left + $padding->right; $w -= $margins->left + $margins->right; $w -= $border->left->width + $border->right->width; $w = 0 if $w < 0; return $w; } sub minimum_inside_width { my ($self) = @_; my $w = $self->minimum_width; my $padding = $self->padding; my $margins = $self->margins; my $border = $self->border; $w -= $padding->left + $padding->right; $w -= $margins->left + $margins->right; $w -= $border->left->width + $border->right->width; $w = 0 if $w < 0; return $w; } sub inside_height { my ($self) = @_; my $h = $self->height; my $padding = $self->padding; my $margins = $self->margins; my $border = $self->border; $h -= $padding->bottom + $padding->top; $h -= $margins->bottom + $margins->top; $h -= $border->top->width + $border->bottom->width; $h = 0 if $h < 0; return $h; } sub minimum_inside_height { my ($self) = @_; my $h = $self->minimum_height; my $padding = $self->padding; my $margins = $self->margins; my $border = $self->border; $h -= $padding->bottom + $padding->top; $h -= $margins->bottom + $margins->top; $h -= $border->top->width + $border->bottom->width; $h = 0 if $h < 0; return $h; } sub inside_bounding_box { my ($self) = @_; my $padding = $self->padding; my $margins = $self->margins; my $border = $self->border; my $rect = Geometry::Primitive::Rectangle->new( origin => Geometry::Primitive::Point->new( x => $padding->left + $border->left->width + $margins->left, y => $padding->top + $border->right->width + $margins->top ), width => $self->inside_width, height => $self->inside_height ); } sub outside_width { my $self = shift(); my $padding = $self->padding; my $margins = $self->margins; my $border = $self->border; my $w = $padding->left + $padding->right; $w += $margins->left + $margins->right; $w += $border->left->width + $border->right->width; return $w; } sub outside_height { my $self = shift(); my $padding = $self->padding; my $margins = $self->margins; my $border = $self->border; my $w = $padding->top + $padding->bottom; $w += $margins->top + $margins->bottom; $w += $border->bottom->width + $border->top->width; return $w; } sub finalize { my ($self) = @_; $self->fire_callback($self) if $self->has_callback; } sub prepare { my ($self, $driver) = @_; return if $self->prepared; unless($self->minimum_width) { $self->minimum_width($self->outside_width); } unless($self->minimum_height) { $self->minimum_height($self->outside_height); } } sub to_string { my ($self) = @_; my $buff = defined($self->name) ? $self->name : ref($self); $buff .= ': '.$self->origin->to_string; $buff .= ' ('.$self->width.'x'.$self->height.')'; return $buff; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Component - Base graphical unit =head1 DESCRIPTION A Component is an entity with a graphical representation. =head1 SYNOPSIS my $c = Graphics::Primitive::Component->new({ origin => Geometry::Primitive::Point->new({ x => $x, y => $y }), width => 500, height => 350 }); =head1 LIFECYCLE =over 4 =item B Most components do the majority of their setup in the B. The goal of prepare is to establish it's minimum height and width so that it can be properly positioned by a layout manager. $driver->prepare($comp); =item B This is not a method of Component, but a phase introduced by the use of L. If the component is a container then each of it's child components (even the containers) will be positioned according to the minimum height and width determined during B. Different layout manager implementations have different rules, so consult the documentation for each for details. After this phase has completed the origin, height and width should be set for all components. $lm->do_layout($comp); =item B This final phase provides and opportunity for the component to do any final changes to it's internals before being passed to a driver for drawing. An example might be a component that draws a fleuron at it's extremities. Since the final height and width isn't known until this phase, it was impossible for it to position these internal components until now. It may even defer creation of this components until now. B $driver->finalize($comp); =item B Handled by L. $driver->draw($comp); =back =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Component. =back =head2 Instance Methods =over 4 =item I Set this component's background color. =item I Set this component's border, which should be an instance of L. =item I Optional callback that is fired at the beginning of the C phase. This allows you to add some sort of custom code that can modify the component just before it is rendered. The only argument is the component itself. Note that changing the position or the dimensions of the component will B re-layout the scene. You may have weird results of you manipulate the component's dimensions here. =item I Set/Get this component's class, which is an abitrary string. Graphics::Primitive has no internal use for this attribute but provides it for outside use. =item I Set this component's foreground color. =item I Method to execute this component's C. =item I Get a tree for this component. Since components are -- by definiton -- leaf nodes, this tree will only have the one member at it's root. =item I Predicate that tells if this component has a C. =item I Set this component's height. =item I Returns a L that defines the edges of the 'inside' box for this component. This box is relative to the origin of the component. =item I Get the height available in this container after taking away space for padding, margin and borders. =item I Get the width available in this container after taking away space for padding, margin and borders. =item I Set this component's margins, which should be an instance of L. Margins are the space I the component's bounding box, as in CSS. The margins should be outside the border. =item I Set/Get this component's maximum height. Used to inform a layout manager. =item I Set/Get this component's maximum width. Used to inform a layout manager. =item I Set/Get this component's minimum height. Used to inform a layout manager. =item I Get the minimum height available in this container after taking away space for padding, margin and borders. =item I Get the minimum width available in this container after taking away space for padding, margin and borders. =item I Set/Get this component's minimum width. Used to inform a layout manager. =item I Set this component's name. This is not required, but may inform consumers of a component. Pay attention to that library's documentation. =item I Set/Get the origin point for this component. =item I Get the height consumed by padding, margin and borders. =item I Get the width consumed by padding, margin and borders. =item I Method provided to give component one last opportunity to put it's contents into the provided space. Called after prepare. =item I Set this component's padding, which should be an instance of L. Padding is the space I the component's bounding box, as in CSS. This padding should be between the border and the component's content. =item I If true then this component represents stand-alone page. This informs the driver that this component (and any children) are to be renderered on a single surface. This only really makes sense in formats that have pages such as PDF of PostScript. =item I Method to prepare this component for drawing. This is an empty sub and is meant to be overriden by a specific implemntation. =item I Set/Get this component's preferred height. Used to inform a layout manager. =item I Set/Get this component's preferred width. Used to inform a layout manager. =item I Get a string representation of this component in the form of: $name $x,$y ($widthx$height) =item I Set/Get this component's visible flag. =item I Set/Get this component's width. =back =head1 AUTHOR Cory Watson, C<< >> =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 Copyright 2008-2009 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/ComponentList.pm000644 000765 000024 00000013643 11433753343 025043 0ustar00gphatstaff000000 000000 package Graphics::Primitive::ComponentList; use Moose; use MooseX::Storage; with Storage (format => 'JSON', io => 'File'); has 'components' => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', default => sub { [] }, handles => { 'component_count' => 'count', 'get_component' => 'get', 'push_components' => 'push', 'set_component' => 'set', }, ); has 'constraints' => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', default => sub { [] }, handles => { 'constraint_count' => 'count', 'get_constraint' => 'get', 'push_constraints' => 'push', 'set_constraint' => 'set', }, ); sub add_component { my ($self, $component, $constraint) = @_; push(@{ $self->components }, $component); push(@{ $self->constraints }, $constraint); } sub clear { my ($self) = @_; $self->components([]); $self->constraints([]); } sub each { my ($self, $functor) = @_; for(my $i = 0; $i < scalar(@{ $self->components }); $i++) { my $component = $self->get_component($i); my $constraint = $self->get_constraint($i); next unless defined($component); $functor->($component, $constraint); } } sub find { my ($self, $predicate) = @_; my $newlist = Graphics::Primitive::ComponentList->new; for(my $i = 0; $i < scalar(@{ $self->components }); $i++) { my $component = $self->get_component($i); my $constraint = $self->get_constraint($i); next unless defined($component); if($component->can('component_list')) { my $list = $component->find($predicate); next unless(scalar(@{ $list->components })); $newlist->push_components(@{ $list->components }); $newlist->push_constraints(@{ $list->constraints }); } if($predicate->($component, $constraint)) { $newlist->add_component($component, $constraint); } } return $newlist; } sub find_component { my ($self, $name) = @_; for(my $i = 0; $i <= scalar(@{ $self->components }); $i++) { my $comp = $self->get_component($i); if(defined($comp) && defined($comp->name) && $comp->name eq $name) { return $i; } } return undef; } sub remove_component { my ($self, $component) = @_; my $name; # Handle either a component object or a scalar name if(ref($component)) { if($component->can('name')) { $name = $component->name(); } else { die('Must supply a Component or a scalar name.'); } } else { $name = $component; } my $count = 0; my @dels = (); foreach my $comp (@{ $self->components }) { if(defined($comp) && defined($comp->name) && $comp->name eq $name) { push(@dels, $self->components->[$count]); delete($self->components->[$count]); delete($self->constraints->[$count]); } $count++; } return \@dels; } no Moose; 1; =head1 NAME Graphics::Primitive::ComponentList - List of Components =head1 DESCRIPTION Maintains a list of components and their constraints. This is implemented as a class to provide functionality above and beyond a simple array. =head1 SYNOPSIS my $c = Graphics::Primitive::ComponentList->new; $c->add_component($comp, $constraint); my $cindex = $c->find_component($comp->name); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Container. =back =head2 Instance Methods =over 4 =item I Add a component to the list. Returns a true value if the component was added successfully. A second argument may be required, please consult the POD for your specific layout manager implementation. Before the component is added, it is passed to the validate_component method. If validate_component does not return a true value, then the component is not added. =item I Reset components and constraints to empty arrayrefs. =item I Returns the number of components in this list. =item I Returns the number of constraints in this list. =item I Calls the supplied CODEREF for each component in this list, passing the component and it's constraints as arguments. my $flist = $list->each( sub{ my ($component, $constraint) = @_; $comp->class('foo) } ); =item I Returns a new ComponentList containing only the components for which the supplied CODEREF returns true. The coderef is called for each component and is passed the component and it's constraints. Undefined components (the ones left around after a remove_component) are automatically skipped. my $flist = $list->find( sub{ my ($component, $constraint) = @_; return $comp->class eq 'foo' } ); If no matching components are found then a new list is returned so that simple calls liked $container->find(...)->each(...) don't explode. =item I Returns the index of the first component with the supplied name. Returns undef if no component with that name is found. =item I Get the component at the specified index. =item I Get the constraint at the specified index. =item I Removes a component and it's constraint. B Returns an arrayref of Components that were removed. =back =head1 AUTHOR Copyright 2008-2009 by Cory G Watson. =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 Copyright 2008-2009 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Container.pm000644 000765 000024 00000011717 11433753343 024167 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Container; use Moose; use MooseX::Storage; with Storage (format => 'JSON', io => 'File'); use Graphics::Primitive::ComponentList; use Forest::Tree; extends 'Graphics::Primitive::Component'; with 'MooseX::Clone'; has 'component_list' => ( is => 'rw', isa => 'Graphics::Primitive::ComponentList', default => sub { Graphics::Primitive::ComponentList->new }, handles => [qw(component_count components constraints each find find_component get_component get_constraint)], trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'layout_manager' => ( is => 'rw', isa => 'Layout::Manager', handles => [ 'do_layout' ], trigger => sub { my ($self) = @_; $self->prepared(0); }, ); sub add_component { my ($self, $component, $args) = @_; return 0 unless $self->validate_component($component, $args); $component->parent($self); $self->component_list->add_component($component, $args); $self->prepared(0); return 1; } sub clear_components { my ($self) = @_; # Clear all the component's parent attributes just in case some # outside thingie is holding a reference to it foreach my $c (@{ $self->components }) { next unless(defined($c)); $c->parent(undef); } $self->component_list->clear; $self->prepared(0); } sub get_tree { my ($self) = @_; my $tree = Forest::Tree->new(node => $self); foreach my $c (@{ $self->components }) { $tree->add_child($c->get_tree); } return $tree; } sub prepare { my ($self, $driver) = @_; return if $self->prepared; unless($self->minimum_width) { $self->minimum_width($self->outside_width); } unless($self->minimum_height) { $self->minimum_height($self->outside_height); } } sub remove_component { my ($self, $component) = @_; my $removed = $self->component_list->remove_component($component); if(scalar(@{ $removed })) { foreach my $r (@{ $removed }) { $r->parent(undef); } } return $removed; } sub validate_component { my ($self, $c, $a) = @_; return 1; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Container - Component that holds other Components =head1 DESCRIPTION Containers are components that contain other components. They can also hold an instance of a L for automatic layout of their internal components. See the L for more information. =head1 SYNOPSIS my $c = Graphics::Primitive::Container->new( width => 500, height => 350, layout_manager => Layout::Manager::Compass->new ); $c->add_component($comp, { meta => 'data' }); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Container. =back =head2 Instance Methods =over 4 =item I Add a component to the container. Returns a true value if the component was added successfully. A second argument may be required, please consult the POD for your specific layout manager implementation. Before the component is added, it is passed to the validate_component method. If validate_component does not return a true value, then the component is not added. =item I Remove all components from the layout manager. =item I Returns the number of components in this container. =item I Returns this Container's L. =item I Returns the index of the first component with the supplied name. Returns undef if no component with that name is found. =item I Get the component at the specified index. =item I Get the constraint at the specified index. =item I Returns a Forest::Tree object with this component at the root and all child components as children. Calling this from your root container will result in a tree representation of the entire scene. =item I Prepares this container. Does not mark as prepared, as that's done by the layout manager. =item I Removes a component. B Returns an arrayref of removed components. =item I Optionally overriden by an implementation, allows it to deem a component as invalid. If this sub returns false, the component won't be added. =back =head1 AUTHOR Cory Watson, C<< >> =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 Copyright 2008-2009 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Driver/000755 000765 000024 00000000000 11571676547 023150 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/lib/Graphics/Primitive/Driver.pm000644 000765 000024 00000013007 11433753624 023474 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Driver; use Moose::Role; requires qw( _draw_arc _draw_bezier _draw_canvas _draw_circle _draw_component _draw_ellipse _draw_line _draw_path _draw_polygon _draw_rectangle _draw_textbox _do_fill _do_stroke _finish_page _resize data get_textbox_layout reset write ); has 'height' => ( is => 'rw', isa => 'Num' ); has 'width' => ( is => 'rw', isa => 'Num' ); sub draw { my ($self, $comp) = @_; if($comp->page) { # FIRST_PAGE is a little protection to ensure that we don't call # show page on the first page, as that would mean we'd have an # empty first page all the time. if($self->{FIRST_PAGE}) { $self->_finish_page; } else { $self->{FIRST_PAGE} = 1; } $self->_resize($comp->width, $comp->height); } die('Components must be objects.') unless ref($comp); # The order of this is important, since isa will return true for any # superclass... # TODO Check::ISA if($comp->isa('Graphics::Primitive::Canvas')) { $self->_draw_canvas($comp); } elsif($comp->isa('Graphics::Primitive::Image')) { $self->_draw_image($comp); } elsif($comp->isa('Graphics::Primitive::TextBox')) { $self->_draw_textbox($comp); } elsif($comp->isa('Graphics::Primitive::Component')) { $self->_draw_component($comp); } if($comp->isa('Graphics::Primitive::Container')) { if($comp->can('components')) { foreach my $subcomp (@{ $comp->components }) { $self->draw($subcomp); } } } } sub finalize { my ($self, $comp) = @_; $comp->finalize($self); if($comp->isa('Graphics::Primitive::Container')) { foreach my $c (@{ $comp->components }) { next unless defined($c) && defined($c) && $c->visible; $self->finalize($c); } } } sub prepare { my ($self, $comp) = @_; unless(defined($self->width)) { $self->width($comp->width); } unless(defined($self->height)) { $self->height($comp->height); } $comp->prepare($self); # TODO Check::ISA if($comp->isa('Graphics::Primitive::Container')) { foreach my $c (@{ $comp->components }) { next unless defined($c) && $c->visible; $self->prepare($c); } } } no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Driver - Role for driver implementations =head1 DESCRIPTION What good is a library agnostic intermediary representation of graphical components if you can't feed them to a library specific implementation that turns them into drawings? Psht, none! To write a driver for Graphics::Primitive implement this role. =head1 SYNOPSIS my $c = Graphics::Primitive::Component->new({ origin => Geometry::Primitive::Point->new({ x => $x, y => $y }), width => 500, height => 350 }); =head1 CANVASES When a path is added to the internal list via I, it is stored in the I attribute as a hashref. The hashref has two keys: B and B. The path is, well, the path. The op is the operation provided to I. As canvases are just lists of paths you should consult the next section as well. =head1 PATHS AND HINTING Paths are lists of primitives. Primitives are all descendants of L and therefore have I and I. These two attributes allow the chaining of primitives. To draw a path you should iterate over the primitives, drawing each. When you pull each path from the arrayref you should pull it's accompanying hints via I (the indexes match). The hint may provide you with additional information: =head2 PRIMITIVE HINTS =over 4 =item I True if this primitive is contiguous with the previous one. Example: Used to determine if a new sub-path is needed for the Cairo driver. =back =head2 OPERATION HINTS =over 4 =item I =back =head1 WARNING Only this class or the driver itself should call methods starting with an underscore, as this interface may change. =head1 METHODS =over 4 =item I<_do_stroke ($strokeop)> Perform a stroke. =item I<_do_fill ($fillop)> Perform a fill. =item I<_draw_arc ($arc)> Draw an arc. =item I<_draw_canvas ($canvas)> Draw a canvas. =item I<_draw_component ($comp)> Draw a component. =item I<_draw_line ($line)> Draw a line. =item I<_draw_rectangle ($rect)> Draw a rectangle. =item I<_draw_textbox> Draw a textbox. =item I<_resize ($width, $height)> Resize the current working surface to the size specified. =item I<_finish_page> Finish the current 'page' and start a new one. Some drivers that are not paginated may need to emulate this behaviour. =item I Retrieve the results of this driver's operations. =item I Draws the given Graphics::Primitive::Component. If the component is a container then all components therein are drawn, recursively. =item I Given a L and a string, returns a bounding box of the rendered text. =item I Finalize the supplied component and any child components, recursively. =item I Prepare the supplied component and any child components, recursively. =item I Write out the results of this driver's operations to the specified file. =back =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Font.pm000644 000765 000024 00000011176 11433753624 023154 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Font; use Moose; use MooseX::Storage; use Moose::Util::TypeConstraints; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); enum 'Graphics::Primitive::Font::AntialiasModes' => ( qw(default none gray subpixel) ); enum 'Graphics::Primitive::Font::HintMetrics' => ( 'default', 'off', 'on' ); enum 'Graphics::Primitive::Font::HintStyles' => ( 'default', 'none', 'slight', 'medium', 'full' ); enum 'Graphics::Primitive::Font::Slants' => ( 'normal', 'italic', 'oblique' ); enum 'Graphics::Primitive::Font::SubpixelOrders' => ( qw(default rgb bgr vrgb vbgr) ); enum 'Graphics::Primitive::Font::Variants' => ( 'normal', 'small-caps' ); enum 'Graphics::Primitive::Font::Weights' => ( 'normal', 'bold' ); has 'antialias_mode' => ( is => 'rw', isa => 'Graphics::Primitive::Font::AntialiasModes', default => 'default' ); has 'family' => ( is => 'rw', isa => 'Str', default => 'Sans' ); has 'hint_metrics' => ( is => 'rw', isa => 'Graphics::Primitive::Font::HintMetrics', default => 'default' ); has 'hint_style' => ( is => 'rw', isa => 'Graphics::Primitive::Font::HintStyles', default => 'default' ); has 'size' => ( is => 'rw', isa => 'Num', default => sub { 12 } ); has 'slant' => ( is => 'rw', isa => 'Graphics::Primitive::Font::Slants', default => 'normal' ); has 'subpixel_order' => ( is => 'rw', isa => 'Graphics::Primitive::Font::SubpixelOrders', default => 'default' ); has 'variant' => ( is => 'rw', isa => 'Graphics::Primitive::Font::Variants', default => 'normal' ); has 'weight' => ( is => 'rw', isa => 'Graphics::Primitive::Font::Weights', default => 'normal' ); __PACKAGE__->meta->add_method('face' => __PACKAGE__->can('family')); sub derive { my ($self, $args) = @_; return unless ref($args) eq 'HASH'; my $new = $self->clone; foreach my $key (keys %{ $args }) { $new->$key($args->{$key}) if($new->can($key)); } return $new; } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Font - Text styling =head1 DESCRIPTION Graphics::Primitive::Font represents the various options that are available when rendering text. The options here may or may not have an effect on your rendering. They represent a cross-section of the features provided by various drivers. Setting them should B break anything, but may not have an effect if the driver doesn't understand the option. =head1 SYNOPSIS use Graphics::Primitive::Font; my $font = Graphics::Primitive::Font->new({ family => 'Arial', size => 12, slant => 'normal' }); =head1 METHODS =head2 Constructor =over 4 =back =head1 Attributes =head2 antialias_modes Set the antialiasing mode for this font. Possible values are default, none, gray and subpixel. =head2 family Set this font's family. =head2 hint_metrics Controls whether to hint font metrics. Hinting means quantizing them so that they are integer values in device space. This improves the consistency of letter and line spacing, however it also means that text will be laid out differently at different zoom factors. May not be supported by all drivers. =head2 hint_style Set the the type of hinting to do on font outlines. Hinting is the process of fitting outlines to the pixel grid in order to improve the appearance of the result. Since hinting outlines involves distorting them, it also reduces the faithfulness to the original outline shapes. Not all of the outline hinting styles are supported by all drivers. Options are default, none, slight, medium and full. =head2 size Set/Get the size of this font. =head2 slant Set/Get the slant of this font. Valid values are normal, italic and oblique. =head2 subpixel_order Set the order of color elements within each pixel on the display device when rendering with subpixel antialiasing. Value values are default, rgb, bgr, vrgb and vbgr. =head2 variant Set/Get the variant of this font. Valid values are normal or small-caps. =head2 weight Set/Get the weight of this font. Value valies are normal and bold. =head1 METHODS =head2 new Creates a new Graphics::Primitive::Font. =head2 derive Clone this font but change one or more of it's attributes by passing in a hashref of options: my $new = $font->derive({ attr => $newvalue }); The returned font will be identical to the cloned one, save the attributes specified. =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Image.pm000644 000765 000024 00000002457 11433753624 023272 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Image; use Moose; use MooseX::Storage; extends 'Graphics::Primitive::Component'; with qw(MooseX::Clone Graphics::Primitive::Aligned); with Storage (format => 'JSON', io => 'File'); has image => ( is => 'rw', isa => 'Str' ); has scale => ( is => 'rw', isa => 'ArrayRef', ); __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Graphics::Primitive::Image - Image component =head1 DESCRIPTION Graphics::Primitive::Image is a Component that displays in image. =head1 SYNOPSIS use Graphics::Primitive::Image; my $img = Graphics::Primitive::Image->new( image => '/path/to/filename' ); =head1 WARNING B =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Image. =back =head2 Instance Methods =over 4 =item I Set/Get the horizontal alignment of this component's image. =item I Set/Get the filename of this components image. =item I Set/Get the vertical alignment of this component's image. =back =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Insets.pm000644 000765 000024 00000005377 11433753624 023521 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Insets; use Moose; use MooseX::Storage; with 'Geometry::Primitive::Equal'; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); use Moose::Util::TypeConstraints; coerce 'Graphics::Primitive::Insets' => from 'ArrayRef' => via { Graphics::Primitive::Insets->new( top => $_->[0], right => $_->[1], bottom => $_->[2], left => $_->[3] ) }; coerce 'Graphics::Primitive::Insets' => from 'Num' => via { Graphics::Primitive::Insets->new( top => $_, right => $_, bottom => $_, left => $_ ) }; has 'top' => ( is => 'rw', isa => 'Num', default => 0 ); has 'bottom' => ( is => 'rw', isa => 'Num', default => 0 ); has 'left' => ( is => 'rw', isa => 'Num', default => 0 ); has 'right' => ( is => 'rw', isa => 'Num', default => 0 ); sub as_array { my ($self) = @_; return ($self->top, $self->right, $self->bottom, $self->left); } sub equal_to { my ($self, $other) = @_; return ($self->top == $other->top) && ($self->bottom == $other->bottom) && ($self->left == $other->left) && ($self->right == $other->right); } sub width { my ($self, $width) = @_; $self->top($width); $self->bottom($width); $self->left($width); $self->right($width); } sub zero { my ($self) = @_; $self->width(0); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Insets - Space between things =head1 DESCRIPTION Graphics::Primitive::Insets represents the amount of space that surrounds something. This object can be used to represent either padding or margins (in the CSS sense, one being inside the bounding box, the other being outside) =head1 SYNOPSIS use Graphics::Primitive::Insets; my $insets = Graphics::Primitive::Insets->new({ top => 5, bottom => 5, left => 5, right => 5 }); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Insets. =back =head2 Instance Methods =over 4 =item I Return these insets as an array in the form of top, right, bottom and left. =item I Set/Get the inset from the bottom. =item I Determine if these Insets are equal to another. =item I Set/Get the inset from the left. =item I Set/Get the inset from the right. =item I Set/Get the inset from the top. =item I Sets all the insets (top, left, bottom, right) to 0. =back =head1 AUTHOR Cory Watson, C<< >> =head1 SEE ALSO perl(1) =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Operation/000755 000765 000024 00000000000 11571676547 023655 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/lib/Graphics/Primitive/Operation.pm000644 000765 000024 00000001544 11433753624 024204 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Operation; use Moose; has 'preserve' => ( isa => 'Bool', is => 'rw', default => sub { 0 }, ); __PACKAGE__->meta->make_immutable; no Moose; 1; =head1 NAME Graphics::Primitive::Operation - A drawing instruction =head1 DESCRIPTION Graphics::Primitive::Operation is the base class for operations. An operation is an action that is performed on a path such as a L or L. =head1 METHODS =over 4 =item I Informs the canvas to not clear the current path when performing this operation. Also provides a hint to the driver. =back =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Oriented.pm000644 000765 000024 00000002714 11433753345 024015 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Oriented; use Moose::Role; use Moose::Util::TypeConstraints; enum 'Graphics::Primitive::Orientations' => qw(vertical horizontal); has 'orientation' => ( is => 'rw', isa => 'Graphics::Primitive::Orientations', ); sub is_vertical { my ($self) = @_; return 0 unless $self->orientation; return ($self->orientation eq 'vertical'); } sub is_horizontal { my ($self) = @_; !$self->is_vertical; } no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Oriented - Role for components that care about orientation. =head1 SYNOPSIS Some components (or things that use components) require a bit more information than origin and width/height. The orientation role allows a component to specify whether is vertically or horizontally oriented. package My::Component; extends 'Graphics::Primitive::Component'; with 'Graphics::Primitive::Oriented'; 1; =head1 METHODS =over =item I Returns true if the component is vertically oriented. =item I Returns true if the component is not vertically oriented. =item I The way a component is oriented. Values allowed are 'horizontal' or 'vertical'. =back =head1 AUTHOR Cory Watson, C<< >> =head1 SEE ALSO perl(1) =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Paint/000755 000765 000024 00000000000 11571676547 022770 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/lib/Graphics/Primitive/Paint.pm000644 000765 000024 00000001032 11433753345 023307 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Paint; use Moose; __PACKAGE__->meta->make_immutable; no Moose; 1; =head1 NAME Graphics::Primitive::Paint - A source for drawing on a path =head1 DESCRIPTION Graphics::Primitive::Paint is the base class for paints. A paint is a pattern suitable for use with a L op. =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Path.pm000644 000765 000024 00000020704 11433753624 023137 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Path; use Moose; use MooseX::Storage; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); use Geometry::Primitive::Arc; use Geometry::Primitive::Bezier; use Geometry::Primitive::Ellipse; use Geometry::Primitive::Line; use Geometry::Primitive::Rectangle; has 'current_point' => ( is => 'rw', isa => 'Geometry::Primitive::Point', traits => [qw(Clone)], default => sub { Geometry::Primitive::Point->new(x => 0, y => 0) }, clearer => 'clear_current_point' ); has 'contiguous' => ( isa => 'Str', is => 'rw', default => sub { 0 }, ); has 'hints' => ( is => 'rw', isa => 'ArrayRef[HashRef]', traits => [qw(Array Clone)], default => sub { [] }, handles => { add_hint => 'push', get_hint => 'get', } ); has 'primitives' => ( is => 'rw', isa => 'ArrayRef', traits => [qw(Array Clone)], default => sub { [] }, handles => { add_primitive => 'push', clear_primitives => 'clear', primitive_count => 'count', get_primitive => 'get' } ); after('add_primitive', sub { my ($self, $prim) = @_; my %hint = ( contiguous => 0 ); my $new_end = $prim->point_end->clone; if($self->contiguous) { # If we are contiguous we can pass that hint to the backend. The # Cairo driver needs to know this to avoid creating a sub-path $hint{contiguous} = 1; } else { # We weren't contiguous for this hint, but we WILL be if move_to # isn't used. Set it now so we don't have to later. $self->contiguous(1); } $self->add_hint(\%hint); $self->current_point($new_end); }); sub arc { my ($self, $radius, $start, $end, $line_to) = @_; my $arc = Geometry::Primitive::Arc->new( origin => $self->current_point->clone, radius => $radius, angle_start => $start, angle_end => $end ); unless($line_to) { $self->line_to($arc->point_start); } $self->add_primitive($arc); } sub ellipse { my ($self, $width, $height, $line_to) = @_; my $ell = Geometry::Primitive::Ellipse->new( origin => $self->current_point->clone, width => $width, height => $height ); unless($line_to) { $self->line_to($ell->point_start); } $self->add_primitive($ell); } sub close_path { my ($self) = @_; $self->line_to($self->get_primitive(0)->point_start->clone); } sub curve_to { my ($self, $c1, $c2, $end) = @_; $self->add_primitive(Geometry::Primitive::Bezier->new( start => $self->current_point->clone, control1 => $c1, control2 => $c2, end => $end )); } sub line_to { 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->clone; } $self->add_primitive(Geometry::Primitive::Line->new( start => $self->current_point->clone, end => $point )); } sub move_to { 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; } # Move to effectively creates a new path, so we are no longer contiguous. # This mainly serves as a backend hint. $self->contiguous(0); $self->current_point($point); } sub rectangle { my ($self, $width, $height) = @_; $self->add_primitive(Geometry::Primitive::Rectangle->new( origin => $self->current_point, width => $width, height => $height )); } sub rel_curve_to { my ($self, $x1, $y1, $x2, $y2, $x3, $y3) = @_; my $curr = $self->current_point; $self->curve_to( Geometry::Primitive::Point->new( x => $curr->x + $x1, y => $curr->y + $y1 ), Geometry::Primitive::Point->new( x => $curr->x + $x2, y => $curr->y + $y2 ), Geometry::Primitive::Point->new( x => $curr->x + $x3, y => $curr->y + $y3 ) ); } sub rel_line_to { my ($self, $x, $y) = @_; # FIXME Relative hinting? my $point = $self->current_point->clone; $point->x($point->x + $x); $point->y($point->y + $y); $self->add_primitive(Geometry::Primitive::Line->new( start => $self->current_point->clone, end => $point )); } sub rel_move_to { my ($self, $x, $y) = @_; my $point = $self->current_point->clone; $self->move_to($point->x + $x, $point->y + $y); } __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Path - Collection of primitives =head1 DESCRIPTION Graphics::Primitive::Path is a shape defined by a list of primitives. =head1 SYNOPSIS use Graphics::Primitive::Path; my $path = Graphics::Primitive::Path->new(); $path->add_primitive($line); $path->move_to($point); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Path =back =head2 Instance Methods =over 4 =item I Add a primitive to this Path. =item I $path->arc($radius, $start_angle_in_radians, $end_angle_in_radians); Draw an arc based at the current point with the given radius from the given start angle to the given end angle. B =item I Clears the current point on this Path. =item I Clears all primitives from this Path. NOTE: This does not clear the current point. =item I Close the current path by drawing a line from the I back to the first point in the path. =item I Flag this path as being contiguous at this point. Continuity is important so some path-based drivers such as Cairo. You should not mess with this attribute unless you know what you are doing. It's used for driver hinting. =item I Returns the current -- or last -- point on this Path. =item I Creates a cubic Bézier curve from the current point to the $end point using $control1 and $control2 as control points. =item I Creates an ellipse at the current point with the specified width and height. Optional last argument, if true, skips drawing a line to the ellipse's starting point. =item I Get this path as a series of points. =item I Returns the primitive at the specified offset. =item I List of hint hashrefs. This hint arrayref matches the primitives arrayref one-to-one. Hints are tidbits of information that may assist drivers in optimizing (or successfully handling) primitives in this path's list. You should not mess with this structure unless you know what you are doing. =item I Draw a line from the current point to the one provided. Accepts either a Geoemetry::Primitive::Point or two arguments for x and y. =item I Move the current point to the one specified. This will not add any primitives to the path. Accepts either a Geoemetry::Primitive::Point or two arguments for x and y. =item I Returns the number of primitives on this Path. =item I Draw a rectangle at I of the specified width and height. =item I Creates a cubic Bézier curve from the current point using the provided values as offsets: start = current point control1 = current point + $x1,$y1 control1 = current point + $x2,$y2 end = current point + $x3,$y3 =item I Draw a line by adding the supplied x and y values to the current one. For example if the current point is 5,5 then calling rel_line_to(2, 2) would draw a line from the current point to 7,7. =item I Move to a new point by adding the supplied x and y values to the current ones. =back =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/TextBox.pm000644 000765 000024 00000007077 11560637666 023660 0ustar00gphatstaff000000 000000 package Graphics::Primitive::TextBox; use Moose; use MooseX::Storage; use Moose::Util::TypeConstraints; # enum 'Graphics::Primitive::TextBox::Directions' => ( # 'auto', 'ltr', 'rtl' # ); # enum 'Graphics::Primitive::TextBox::WrapModes' # => qw(word char word_char); # enum 'Graphics::Primitive::TextBox::EllipsizeModes' # => qw(none start middle end); extends 'Graphics::Primitive::Component'; with qw(MooseX::Clone Graphics::Primitive::Aligned); with Storage (format => 'JSON', io => 'File'); use Graphics::Primitive::Font; has 'angle' => ( is => 'rw', isa => 'Num', trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'direction' => ( is => 'rw', isa => 'Str', ); has 'ellipsize_mode' => ( is => 'rw', isa => 'Str', ); has 'font' => ( is => 'rw', isa => 'Graphics::Primitive::Font', default => sub { Graphics::Primitive::Font->new }, trigger => sub { my ($self) = @_; $self->prepared(0); } ); has '+horizontal_alignment' => ( default => sub { 'left'} ); has 'indent' => ( is => 'rw', isa => 'Num', default => sub { 0 } ); has 'justify' => ( is => 'rw', isa => 'Bool', default => sub { 0 } ); has 'layout' => ( is => 'rw', does => 'Graphics::Primitive::Driver::TextLayout', ); has 'lines' => ( is => 'rw', ); has 'line_height' => ( is => 'rw', isa => 'Num', trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'text' => ( is => 'rw', isa => 'Str', trigger => sub { my ($self) = @_; $self->prepared(0); } ); has 'text_bounding_box' => ( is => 'rw', isa => 'Geometry::Primitive::Rectangle', trigger => sub { my ($self) = @_; $self->prepared(0); } ); has '+vertical_alignment' => ( default => sub { 'top'} ); has 'wrap_mode' => ( is => 'rw', isa => 'Str', ); override('prepare', sub { my ($self, $driver) = @_; super; return unless defined($self->text) || defined($self->lines) || defined($self->layout); unless($self->lines) { my $layout = $driver->get_textbox_layout($self); $self->layout($layout); my $mw = $layout->width + $self->outside_width; if($mw > $self->minimum_width) { $self->minimum_width($mw); } my $mh = $layout->height + $self->outside_height; if($mh > $self->minimum_height) { $self->minimum_height($mh); } } }); __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME Graphics::Primitive::TextBox - Text component =head1 DESCRIPTION Graphics::Primitive::TextBox is a Component with text. =head1 SYNOPSIS use Graphics::Primitive::Font; use Graphics::Primitive::TextBox; my $tx = Graphics::Primitive::TextBox->new( font => Graphics::Primitive::Font->new( face => 'Myriad Pro', size => 12 ), text => 'I am a textbox!' ); =head1 WARNING This component is likely to change drastically. Here be dragons. =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::TextBox. =back =head2 Instance Methods =over 4 =item I The angle this text will be rotated. =item I Set this textbox's font =item I Horizontal alignment. See L. =item I Set this textbox's text. =item I Vertical alignment. See L. =back =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Paint/Gradient/000755 000765 000024 00000000000 11571676547 024525 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/lib/Graphics/Primitive/Paint/Gradient.pm000644 000765 000024 00000002471 11433753624 025054 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Paint::Gradient; use Moose; use Moose::Util::TypeConstraints; use MooseX::Storage; extends 'Graphics::Primitive::Paint'; # FIXME key should be <= 1 has color_stops => ( traits => ['Hash'], isa => 'HashRef', is => 'rw', default => sub { {} }, handles => { stop_count => 'count', stops => 'keys', get_stop => 'get', add_stop => 'set', } ); __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Paint::Gradient - Color blending =head1 DESCRIPTION Graphics::Primitive::Paint::Gradient is a base class used by color blending techniques such as linear and radial. You should not use this class directly. =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Gradient =back =head2 Instance Methods =over 4 =item I Adds a color stop at the specified position =item I Hashref of colors and their stops. The stops are the keys. =item I Count of stops added to this Gradient. =item I Get the keys of all color stops. =back =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Paint/Solid.pm000644 000765 000024 00000002040 11433753624 024361 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Paint::Solid; use Moose; use MooseX::Storage; extends 'Graphics::Primitive::Paint'; with qw(MooseX::Clone); with Storage (format => 'JSON', io => 'File'); has color => ( isa => 'Graphics::Color', is => 'rw', traits => [qw(Clone)] ); __PACKAGE__->meta->make_immutable; no Moose; 1; =head1 NAME Graphics::Primitive::Paint::Solid - Solid patch of color =head1 DESCRIPTION Graphics::Primitive::Paint::Solid represents a solid color. =head1 SYNOPSIS use Graphics::Primitive::Paint::Solid; my $solid = Graphics::Primitive::Solid->new; $solid->color(Graphics::Color::RGB->new(red => 1, green => 0, blue => 0)); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Solid =back =head2 Instance Methods =over 4 =item I Get/Set the color of this solid =back =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Paint/Gradient/Linear.pm000644 000765 000024 00000003065 11433753624 026266 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Paint::Gradient::Linear; use Moose; use Moose::Util::TypeConstraints; use MooseX::Storage; extends 'Graphics::Primitive::Paint::Gradient'; with Storage (format => 'JSON', io => 'File'); has line => ( isa => 'Geometry::Primitive::Line', is => 'rw', ); __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Paint::Gradient::Linear - Linear color blending =head1 DESCRIPTION Graphics::Primitive::Paint::Gradient::Linear is a gradient along a line. =head1 SYNOPSIS use Graphics::Primitive::Paint::Gradient::Linear; my $gradient = Graphics::Primitive::Gradient::Linear->new( line => Geometry::Primitive::Line->new( start => Graphics::Primitive::Point->new(x => 0, y => 0), end => Graphics::Primitive::Point->new(x => 0, y => 10), ) ); $gradient->add_stop(0.0, $color1); $gradient->add_stop(1.0, $color2); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Gradient =back =head2 Instance Methods =over 4 =item I Adds a color stop at the specified position =item I Hashref of colors and their stops. The stops are the keys. =item I The line along which the gradient should run. =item I Count of stops added to this Gradient. =item I Get the keys of all color stops. =back =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Paint/Gradient/Radial.pm000644 000765 000024 00000003320 11433753624 026242 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Paint::Gradient::Radial; use Moose; use Moose::Util::TypeConstraints; use MooseX::Storage; extends 'Graphics::Primitive::Paint::Gradient'; with Storage (format => 'JSON', io => 'File'); has 'end' => ( is => 'rw', isa => 'Geometry::Primitive::Circle', required => 1 ); has 'start' => ( is => 'rw', isa => 'Geometry::Primitive::Circle', required => 1 ); __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Paint::Gradient::Radial - Radial color blending =head1 DESCRIPTION Graphics::Primitive::Paint::Gradient::Radial is a color blend between two circles. =head1 SYNOPSIS use Graphics::Primitive::Paint::Gradient::Radial; my $gradient = Graphics::Primitive::Gradient::Radial->new( start => Geometry::Primitive::Circle->new( origin => 0, 0, radius => 5 ), end => Geometry::Primitive::Circle->new( origin => 50, 25, radius => 5 ) ); $gradient->add_stop(0.0, $color1); $gradient->add_stop(1.0, $color2); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Gradient =back =head2 Instance Methods =over 4 =item I Adds a color stop at the specified position =item I Hashref of colors and their stops. The stops are the keys. =item I The "end" circle. =item I The "start" circle. =item I Count of stops added to this Gradient. =item I Get the keys of all color stops. =back =head1 AUTHOR Cory Watson =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. You can redistribute and/or modify this code under the same terms as Perl itself. Graphics-Primitive-0.61/lib/Graphics/Primitive/Operation/Fill.pm000644 000765 000024 00000002267 11433753624 025075 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Operation::Fill; use Moose; use MooseX::Storage; extends 'Graphics::Primitive::Operation'; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); has paint => ( isa => 'Graphics::Primitive::Paint', is => 'rw', required => 1, traits => [qw(Clone)] ); __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Operation::Fill - Paint inside a path =head1 DESCRIPTION Graphics::Primitive::Operation::Fill represents a fill operation to be performed on a path. =head1 SYNOPSIS use Graphics::Primitive::Operation::Fill; my $fill = Graphics::Primitive::Operation::Fill->new; $fill->paint(Graphics::Primitive::Paint::Solid->new); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Operation::Fill. =back =head2 Instance Methods =over 4 =item I Set/Get the L to use for this fill. =back =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Operation/Stroke.pm000644 000765 000024 00000002372 11433753624 025453 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Operation::Stroke; use Moose; use MooseX::Storage; extends 'Graphics::Primitive::Operation'; with 'MooseX::Clone'; with Storage (format => 'JSON', io => 'File'); use Graphics::Primitive::Brush; has brush => ( isa => 'Graphics::Primitive::Brush', is => 'rw', default => sub { Graphics::Primitive::Brush->new }, traits => [qw(Clone)] ); __PACKAGE__->meta->make_immutable; no Moose; 1; __END__ =head1 NAME Graphics::Primitive::Operation::Stroke - Draw along a path =head1 DESCRIPTION Graphics::Primitive::Operation::Stroke represents a stroke operation to be performed on a path. =head1 SYNOPSIS use Graphics::Primitive::Operation::Stroke; my $stroke = Graphics::Primitive::Operation::Stroke->new; $stroke->brush->width(2); =head1 METHODS =head2 Constructor =over 4 =item I Creates a new Graphics::Primitive::Operation::Stroke. Uses a default L. =back =head2 Instance Methods =over 4 =item I Set/Get this Stroke's Brush =back =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/lib/Graphics/Primitive/Driver/TextLayout.pm000644 000765 000024 00000003174 11433753624 025622 0ustar00gphatstaff000000 000000 package Graphics::Primitive::Driver::TextLayout; use Moose::Role; requires 'slice'; has 'component' => ( is => 'rw', isa => 'Graphics::Primitive::TextBox', required => 1 ); has 'height' => ( is => 'rw', isa => 'Num', default => sub { -1 } ); has 'width' => ( is => 'rw', isa => 'Num', lazy => 1, default => sub { my ($self) = @_; $self->component->width } ); no Moose; 1; __END__; =head1 NAME Graphics::Primitive::Driver::TextLayout - TextLayout role =head1 DESCRIPTION Graphics::Primitive::Driver::TextLayout is a role for Driver text layout engines. =head1 SYNOPSIS package MyLayout; use Moose; with 'Graphics::Primitive::Driver::TextLayout'; ... =head1 METHODS =over 4 =item I Set/Get the component from which to draw layout information. =item I Set/Get this layout's height =item I Implemented by role consumer. Given an offset and an optional size, returns a TextBox containing lines from this layout that come as close to C<$size> without exceeding it. This method is provided to allow incremental rendering of text. For example, if you have a series of containers 80 units high, you might write code like this: for(my $i = 0; $i < 3; $i++) { $textbox = $layout->slice($i * 80, 80); # render the text } =item I Set/Get this layout's width. Defaults to the width of the component supplied. =back =head1 AUTHOR Cory Watson, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2008-2010 by Cory G Watson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.Graphics-Primitive-0.61/inc/Module/000755 000765 000024 00000000000 11571676547 017435 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/inc/Module/Install/000755 000765 000024 00000000000 11571676547 021043 5ustar00gphatstaff000000 000000 Graphics-Primitive-0.61/inc/Module/Install.pm000644 000765 000024 00000030135 11571676545 021401 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 Cwd (); use File::Find (); use File::Path (); 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 = '1.01'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # 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 # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # 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)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; 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"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } 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; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } 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 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 ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # 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) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _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 - 2011 Adam Kennedy. Graphics-Primitive-0.61/inc/Module/Install/Base.pm000644 000765 000024 00000002147 11571676546 022256 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.01'; } # 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->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Graphics-Primitive-0.61/inc/Module/Install/Can.pm000644 000765 000024 00000003333 11571676546 022103 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 = '1.01'; @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 Graphics-Primitive-0.61/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 11571676546 022442 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; Graphics-Primitive-0.61/inc/Module/Install/Makefile.pm000644 000765 000024 00000027032 11571676546 023121 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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 or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; 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 ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } 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. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } 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->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } 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"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $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: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $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; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; 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 541 Graphics-Primitive-0.61/inc/Module/Install/Metadata.pm000644 000765 000024 00000043123 11571676546 023123 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract 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 author }; *authors = \&author; 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; } 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"); } $self->{values}{all_from} = $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) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $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 _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $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; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', 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()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => '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, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; 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 one bugtracker 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; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # 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; Graphics-Primitive-0.61/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 11571676546 022302 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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; Graphics-Primitive-0.61/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 11571676546 023133 0ustar00gphatstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @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} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # 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;