From 0a772512de0d0023f9e298e662bd3924e32a0d72 Mon Sep 17 00:00:00 2001 From: Andreas Voegele Date: Fri, 18 Apr 2014 20:33:19 +0200 Subject: [PATCH 1/2] Add Perl 5 implementation --- perl/GildedRose.pm | 74 ++++++++++++++++++++++++++++++++++++++++++++++ perl/Item.pm | 16 ++++++++++ perl/test.pl | 18 +++++++++++ 3 files changed, 108 insertions(+) create mode 100644 perl/GildedRose.pm create mode 100644 perl/Item.pm create mode 100755 perl/test.pl diff --git a/perl/GildedRose.pm b/perl/GildedRose.pm new file mode 100644 index 00000000..7cc74a1e --- /dev/null +++ b/perl/GildedRose.pm @@ -0,0 +1,74 @@ +package GildedRose; + +use strict; +use warnings; + +sub new { + my ( $class, %attrs ) = @_; + return bless \%attrs, $class; +} + +sub update_quality { + my $self = shift; + for my $item ( @{ $self->{items} } ) { + if ( $item->{name} ne 'Aged Brie' + && $item->{name} ne 'Backstage passes to a TAFKAL80ETC concert' ) + { + if ( $item->{quality} > 0 ) { + if ( $item->{name} ne 'Sulfuras, Hand of Ragnaros' ) { + $item->{quality} = $item->{quality} - 1; + } + } + } + else { + if ( $item->{quality} < 50 ) { + $item->{quality} = $item->{quality} + 1; + + if ( $item->{name} eq + 'Backstage passes to a TAFKAL80ETC concert' ) + { + if ( $item->{sell_in} < 11 ) { + if ( $item->{quality} < 50 ) { + $item->{quality} = $item->{quality} + 1; + } + } + + if ( $item->{sell_in} < 6 ) { + if ( $item->{quality} < 50 ) { + $item->{quality} = $item->{quality} + 1; + } + } + } + } + } + + if ( $item->{name} ne 'Sulfuras, Hand of Ragnaros' ) { + $item->{sell_in} = $item->{sell_in} - 1; + } + + if ( $item->{sell_in} < 0 ) { + if ( $item->{name} ne 'Aged Brie' ) { + if ( $item->{name} ne + 'Backstage passes to a TAFKAL80ETC concert' ) + { + if ( $item->{quality} > 0 ) { + if ( $item->{name} ne 'Sulfuras, Hand of Ragnaros' ) { + $item->{quality} = $item->{quality} - 1; + } + } + } + else { + $item->{quality} = $item->{quality} - $item->{quality}; + } + } + else { + if ( $item->{quality} < 50 ) { + $item->{quality} = $item->{quality} + 1; + } + } + } + } + return; +} + +1; diff --git a/perl/Item.pm b/perl/Item.pm new file mode 100644 index 00000000..04b0c2ae --- /dev/null +++ b/perl/Item.pm @@ -0,0 +1,16 @@ +package Item; + +use strict; +use warnings; + +sub new { + my ( $class, %attrs ) = @_; + return bless \%attrs, $class; +} + +sub _data_printer { ## no critic (ProhibitUnusedPrivateSubroutines) + my ( $self, $properties ) = @_; + return $self->{name} . ', ' . $self->{sell_in} . ', ' . $self->{quality}; +} + +1; diff --git a/perl/test.pl b/perl/test.pl new file mode 100755 index 00000000..0ffecaf1 --- /dev/null +++ b/perl/test.pl @@ -0,0 +1,18 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Test::More 0.96; + +use_ok 'GildedRose'; +use_ok 'Item'; + +subtest 'foo' => sub { + my $items = [ Item->new( name => 'foo', sell_in => 0, quality => 0 ) ]; + my $app = GildedRose->new( items => $items ); + $app->update_quality(); + is( $app->{items}->[0]->{name}, 'fixme' ); +}; + +done_testing(); From 9d1856b254feceeaa13e8a797c668e10ca9a1f3c Mon Sep 17 00:00:00 2001 From: Andreas Voegele Date: Fri, 2 May 2014 12:25:12 +0200 Subject: [PATCH 2/2] add texttest fixture for Perl 5 code --- perl/Item.pm | 4 +-- perl/texttest_fixture.pl | 72 ++++++++++++++++++++++++++++++++++++++++ texttests/config.gr | 4 +++ texttests/environment.gr | 1 + 4 files changed, 79 insertions(+), 2 deletions(-) create mode 100755 perl/texttest_fixture.pl diff --git a/perl/Item.pm b/perl/Item.pm index 04b0c2ae..556d215a 100644 --- a/perl/Item.pm +++ b/perl/Item.pm @@ -8,8 +8,8 @@ sub new { return bless \%attrs, $class; } -sub _data_printer { ## no critic (ProhibitUnusedPrivateSubroutines) - my ( $self, $properties ) = @_; +sub to_string { + my ($self) = @_; return $self->{name} . ', ' . $self->{sell_in} . ', ' . $self->{quality}; } diff --git a/perl/texttest_fixture.pl b/perl/texttest_fixture.pl new file mode 100755 index 00000000..565a8b61 --- /dev/null +++ b/perl/texttest_fixture.pl @@ -0,0 +1,72 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use GildedRose; +use Item; + +print 'OMGHAI!', "\n"; +my $items = [ + Item->new( + name => '+5 Dexterity Vest', + sell_in => 10, + quality => 20 + ), + Item->new( + name => 'Aged Brie', + sell_in => 2, + quality => 0 + ), + Item->new( + name => 'Elixir of the Mongoose', + sell_in => 5, + quality => 7 + ), + Item->new( + name => 'Sulfuras, Hand of Ragnaros', + sell_in => 0, + quality => 80 + ), + Item->new( + name => 'Sulfuras, Hand of Ragnaros', + sell_in => -1, + quality => 80 + ), + Item->new( + name => 'Backstage passes to a TAFKAL80ETC concert', + sell_in => 15, + quality => 20 + ), + Item->new( + name => 'Backstage passes to a TAFKAL80ETC concert', + sell_in => 10, + quality => 49 + ), + Item->new( + name => 'Backstage passes to a TAFKAL80ETC concert', + sell_in => 5, + quality => 49 + ), + Item->new( # This Conjured item does not work properly yet + name => 'Conjured Mana Cake', + sell_in => 3, + quality => 6 + ), +]; + +my $days = 2; +if ( $#ARGV >= 0 ) { + $days = $ARGV[0]; +} + +my $gilded_rose = GildedRose->new( items => $items ); +for my $day ( 0 .. $days ) { + print "-------- day $day --------", "\n"; + print 'name, sellIn, quality', "\n"; + for my $item ( @{$items} ) { + print $item->to_string(), "\n"; + } + print "\n"; + $gilded_rose->update_quality(); +} diff --git a/texttests/config.gr b/texttests/config.gr index e6cfd5c7..5be96e39 100755 --- a/texttests/config.gr +++ b/texttests/config.gr @@ -22,6 +22,10 @@ interpreter:java # Settings for the C# version #executable:${TEXTTEST_CHECKOUT}/GildedRose.exe +# Settings for the Perl version +#executable:${TEXTTEST_CHECKOUT}/perl/texttest_fixture.pl +#interpreter:perl + # turn on one of these if you prefer them to notepad or emacs. [view_program] *:mate diff --git a/texttests/environment.gr b/texttests/environment.gr index d419d84d..1483a513 100755 --- a/texttests/environment.gr +++ b/texttests/environment.gr @@ -1,2 +1,3 @@ # If your .class files are somewhere else, add the path to the list CLASSPATH:${TEXTTEST_CHECKOUT}/Java:${TEXTTEST_CHECKOUT}/Java/bin +PERL5OPT:-I${TEXTTEST_CHECKOUT}/perl