view release on metacpan or  search on metacpan

lib/App/Tarotplane/Cards.pm  view on Meta::CPAN

package App::Tarotplane::Cards;
our $VERSION = '2.01';
use 5.016;
use strict;
use warnings;

use Carp;
use List::Util qw(shuffle);

use constant {
	CARD_TERM => 0,
	CARD_DEF  => 1,
};

sub _read_cardfile {

	my $file = shift;

	my @cards;

	open my $fh, '<', $file or croak "Could not open $file: $!";

	my $card = {};

	my $cn = 1;

	my $state = CARD_TERM;

	my $l = '';
	while (defined $l) {

		$l = readline $fh;

		if (not defined $l or $l eq "%\n") {

			# Blank cards are okay
			next if not defined $card->{Term};

			croak "No definition for card #$cn in $file"
				unless $state == CARD_DEF;

			# Trim leading/trailing whitespace
			$card->{Term}       =~ s/^\s+|\s+$//g;
			$card->{Definition} =~ s/^\s+|\s+$//g;

			# Truncate whitespace
			$card->{Term}       =~ s/\s+/ /g;
			$card->{Definition} =~ s/\s+/ /g;

			## Now interpret some escape codes
			# '\:' -> ':'
			$card->{Term}       =~ s/\\:/:/g;
			$card->{Definition} =~ s/\\:/:/g;

			# '\n' -> line break
			$card->{Term}       =~ s/\\n/\n/g;
			$card->{Definition} =~ s/\\n/\n/g;

			# No longer need '\\' substitution null byte
			$card->{Term}       =~ s/\0//g;
			$card->{Definition} =~ s/\0//g;

			push @cards, $card;
			$card = {};
			$state = CARD_TERM;

			$cn++;

			next;

		}

		# Skip comments and blanks
		my $first = substr $l, 0, 1;
		next if $first eq '#' or $first eq "\n";

		# Substitute '\\' now so that '\\:' does not count as an escaped colon.
		# The null byte is added so that the subsequent substitutions do not
		# try to replace any '\\' escaped backslash.
		$l =~ s/\\\\/\\\0/g;

		if ($state == CARD_TERM) {
			# Does card contain non-escaped colon?
			if ($l =~ /(^|[^\\]):/) {
				my (undef,
					$te,
					$de
				) = split(/(^.*[^\\]):/, $l, 2);
				$card->{Term}       .= $te || '';
				$card->{Definition} .= $de || '';
				$state = CARD_DEF;
			} else {
				$card->{Term} .= $l;
			}
		} else {
			$card->{Definition} .= $l;
		}

	}

	close $fh;

	croak "No cards found in $file" unless @cards;

	return @cards;

}

sub new {

	my $class = shift;
	my @files = @_;

	my $self = {
		Cards   => [],
		CardNum => 0,
	};

	foreach my $f (@files) {

		my @cards = _read_cardfile($f);

		push @{$self->{Cards}}, @cards;
		$self->{CardNum} += scalar @cards;

	}

	bless $self, $class;
	return $self;

}

sub get {

	my $self = shift;
	my $get  = shift;

	if (defined $self->{$get}) {
		return $self->{$get};
	}

	return undef;