###################################################################### package DndSpells; ###################################################################### =head1 NAME DndSpells -- spell stats for Dungeons and Dragons, 3rd edition =head1 SYNOPSIS use DndSpells; my $s= new DndSpells; $s->readdescriptionfile($file); $s->readlistfile($file); my @list= getclasslist("Bard",1); my @list= getclasslist("Cleric",1,"War"); my $dur= $s->getstat($spell,"Duration"); =head1 DESCRIPTION This module parses and serves information on 3rd edition D&D spells. These are available through the D20 SRD files, which this module can parse. Note that there were some errors in the SRD spell description files which needed to be fixed for it to be parsed: mainly spell parameter lines which improperly have a break in the middle of the line. (i.e. "Duration: 1 turn/level or
concentration"). =cut require 5.003; use strict; use Carp; use FileHandle; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); require Exporter; @ISA = qw(Exporter AutoLoader); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @EXPORT = qw( getclasses getdomains getschools getstats isaclass isadomain isaschool isastat ); @EXPORT_OK = qw( ); $VERSION = '0.01'; ###################################################################### # these are general class variables my $debug=0; ###################################################################### =head1 METHODS The following methods are available: =over 4 =item setdebug This sets the debug variable, which by default is zero. =cut sub setdebug { $debug= shift(); $debug= shift() if (ref($debug)); # if this was called by object } =item getclasses Returns a list of class names. =cut sub getclasses { return qw(Bard Druid Ranger Cleric Paladin Wizard); } =item isaclass Returns the correctly-capitalized name if the given string matches a spell-casting character class, or undef otherwise. =cut my %classhash; sub isaclass { my $string= lc(shift); $string=~ s/^\s+//; # remove leading spaces $string=~ s/\s+$//; # remove trailing spaces unless (keys %classhash) { foreach (getclasses()) { $classhash{lc($_)}=$_; } $classhash{"sorcerer"}= "Wizard"; $classhash{"brd"}= "Bard"; $classhash{"clr"}= "Cleric"; $classhash{"drd"}= "Druid"; $classhash{"rgr"}= "Ranger"; $classhash{"pal"}= "Paladin"; $classhash{"sor"}= "Wizard"; $classhash{"wiz"}= "Wizard"; $classhash{"sor/wiz"}= "Wizard"; } return $classhash{$string}; } =item getdomains Returns a list of Cleric spell domains. =cut sub getdomains { return qw(Air Animal Chaos Death Destruction Earth Evil Fire Good Healing Knowledge Law Luck Magic Plant Protection Strength Sun Travel Trickery War Water); } =item isadomain Returns the correctly-capitalized name if the given string matches Cleric spell domain, or undef otherwise =cut my %domainhash; sub isadomain { my $string= shift; if (keys %domainhash) { return $string if $domainhash{$string}; } else { foreach (getdomains()) { $domainhash{$_}=1; } } foreach my $domain (getdomains()) { return $domain if ($string=~/^\s*$domain\s*$/i); } return undef; } =item getschools Returns a list of spell schools =cut sub getschools { return qw(Abjuration Conjuration Divination Enchantment Evocation Illusion Necromancy Transmutation Universal); } =item isaschool Returns the correctly-capitalized name if the given string matches a spell school, or undef otherwise. =cut my %schoolhash; sub isaschool { my $string= shift; if (keys %schoolhash) { return $string if $schoolhash{$string}; } else { foreach (getschools()) { $schoolhash{$_}=1; } } foreach my $school (getschools()) { return $school if ($string=~/^\s*$school\s*$/i); } return undef; } =item getstats Returns a list of spell stats. =cut sub getstats { return ("School" , "Other" , "Level" , "Components" , "Casting Time" , "Range" , "Effect" , "Duration" , "Saving Throw" , "Target" , "Area" , "Spell Resistance" , "Description" , "XP Cost" , "Focus" , "Material Components" , "Base Spell" , "Blurb"); } =item isastat Returns the correctly-capitalized stat name if the given string matches a spell stat, or undef otherwise. =cut my %stathash; sub isastat { my $string= shift; if (keys %stathash) { return $string if $stathash{$string}; } else { foreach (getstats()) { $stathash{$_}=1; } } # These are aliases used in spell descriptions, which often apply # when stats are combined. $string=~s/^\s*(.*?)\s*$/$1/; # remove leading and trailing whitespace $string=~s/^(Targets|Target or Targets)$/Target/; $string=~s/^(Targets? or Area|Area or Targets?)$/Target/; $string=~s/^(Targets? or Effect|Targets?\/Effect)$/Target/; $string=~s/^(Targets?, Effect, or Area)$/Target/; $string=~s/Component$/Components/; $string=~s/(Arcane )?Material Components?/Material Components/; foreach my $stat (getstats()) { # recognize whitespace around, and ignore case return $stat if ($string=~/^\s*$stat\s*$/i); # also recognize stat name with whitespace removed my $statword= lc($stat); $statword=~s/\s+//; return $stat if ($string=~/^$statword$/i); } return undef; } ###################################################################### =item new (Constructor) Create a new instance of this class by writing $myspells = DndSpells->new(); =cut sub new { my $that= shift; # either class name or template object my $self= {}; # $self is a hash reference bless($self, $that); return $self; } ###################################################################### =item getspells Returns a list of all spells, or all spells which match the inputted pattern. =cut sub getspells { my ($self, $pattern)= @_; my @list; foreach (keys %$self) { next if (defined($pattern) and not (/$pattern/)); push(@list,$_) unless (/\n/s); } return @list; } ###################################################################### =item isaspell Returns the exact name if the named spell is recognized, or undef otherwise. =cut sub isaspell { my ($self,$name)= @_; return $name if (defined($self->{$name})); $name=~s/Mord's/Mordenkainen's/; foreach my $spell (keys %$self) { return $spell if ($name=~/^\s*$spell\s*$/i); } } ###################################################################### =item newspell Sets the single argument as a recognized spellname with no stats. =cut sub newspell { my ($self,$name)= @_; $self->{$name}= {} unless (defined($self->{$name})); } ###################################################################### =item getstat Gets the value of the named stat $statvalue = $spells->getstat($spellname,$statname); =cut sub getstat { my ($self, $spellname, $statname)= @_; my $stat= isastat($statname) or croak "Unknown stat '$statname'"; my $spell= $self->isaspell($spellname) or croak "Unknown spell '$spellname'"; return $self->{$spell}->{$stat}; } ###################################################################### =item setstat Sets the value of the named stat $statvalue = $spells->setstat($spellname,$statname,$statvalue); =cut sub setstat { my ($self, $spellname, $statname, $statvalue)= @_; my $stat= isastat($statname) or croak "Unknown stat '$statname'"; my $spell= $self->isaspell($spellname) or croak "Unknown spell '$spellname'"; croak "No stat value given" unless (defined($statvalue)); return $self->{$spell}->{$stat}= $statvalue; } ###################################################################### =item addspelltolist Adds a spell to the spell list for a given class. It has an optional fourth argument which is domain for $spells->addspelltolist($spellname,$classname,$level,$domain); =cut sub addspelltolist { my ($self, $spellname, $classname, $level, $domain)= @_; my $class= isaclass($classname) or croak "Unknown class '$classname'"; croak "Bad level argument '$level'" unless ($level=~/^\d$/); my $spell= $self->isaspell($spellname) or croak "Unknown spell '$spellname'"; croak "Unknown domain '$domain'" if (defined($domain) and not isadomain($domain)); my $key= "$class\n$level"; $key .= "\n$domain" if $domain; if (defined($self->{$key})) { push(@{$self->{$key}},$spell); } else { my @list= ($spell); $self->{$key}= \@list; } } ###################################################################### =item getclasslist Returns the list of spells for a given class and level. =cut sub getclasslist { my ($self, $classname, $level, $domain)= @_; my $class= isaclass($classname) or croak "Unknown class '$classname'"; croak "Bad level argument '$level'" unless ($level=~/^\d$/); croak "Unknown domain '$domain'" if (defined($domain) and not isadomain($domain)); my $key= "$class\n$level"; $key .= "\n$domain" if $domain; if (defined($self->{$key})) { my @list= @{$self->{$key}}; return @list; } else { return (); } } ###################################################################### =item get_abbr_castingtime Returns an abbreviated form of the casting time, or "*" for special. =cut sub get_abbr_castingtime { my $self= shift; my $spellname= shift; my $time= $self->getstat($spellname,"Casting Time"); my $abbr= undef; ### Mark as "see text" if so noted my $seetext; if (($time=~/^\s*\(?see text\)?\s*$/i) or ($time=~/^$/)) { return "*"; } elsif (($time=~s/\(see text\)//i) or ($time=~s/or see text//i)) { $seetext= 1; } ### special cases $time=~s/\(D\)\s*$//i; # erroneous "(D)" for Guards and Wards $time=~s/, plus 1 action per bolt called$//i; # Call Lightning ### replace redundant "full round" with just "round" $time=~s/full round/round/i; ### replace numbers, using word break "\b" to distinguish $time=~s/\bone\b/1/i; $time=~s/\btwo\b/2/i; $time=~s/\bthree\b/3/i; $time=~s/\bfour\b/4/i; $time=~s/\bfive\b/5/i; $time=~s/\bsix\b/6/i; $time=~s/\bseven\b/7/i; $time=~s/\beight\b/8/i; $time=~s/\bnine\b/9/i; $time=~s/\bten\b/10/i; ### remove leading and trailing spaces $time=~s/^\s+//; $time=~s/\s+$//; my %tabbr=("round"=>"rnd","minute"=>"min","hour"=>"hr","day"=>"day"); my $unit= "round|minute|hour|day"; if ($time=~/^1 action$/) { $abbr= "1 act"; } elsif ($time=~/^(\d+) ($unit)s?$/) { $abbr= "$1 $tabbr{$2}s"; } else { return "*"; } if ($seetext) { $abbr .= "(*)"; } return $abbr; } ###################################################################### =item get_abbr_duration Returns an abbreviated form of the duration, or "*" for special. =cut sub get_abbr_duration { my $self= shift; my $spellname= shift; my $dur= $self->getstat($spellname,"Duration"); my $abbr= undef; ### Mark as "dismissable" if (D) at end of line my $dismissable= undef; if ($dur=~s/\(D\)\s*$//) { $dismissable= 1; } ### Mark as "concentration" if so noted my $concentration= undef; if ($dur=~/^\s*Concentration\s*$/) { return "Conc"; } elsif ($dur=~s/^\s*Concentration\s*\+\s*//) { $concentration= "+"; } elsif ($dur=~s/^\s*Concentration\s*(\(|,)\s*(up to|maximum)(.+?)\)?/$3/) { $concentration= "/"; } ### Mark as "see text" if so noted my $seetext; if (($dur=~/^\s*\(see text\)\s*$/i) or ($dur=~/^$/)) { return "*"; } elsif (($dur=~s/\(see text\)//i) or ($dur=~s/and see text//i)) { $seetext= 1; } ### Mark as "until discarge" if so noted my $discharge; if ($dur=~/^\s*until discharged?\s*$/i) { return "Dischg"; } elsif ($dur=~/^\s*until triggered or broken\s*$/i) { return "Dischg"; } elsif ($dur=~/^\s*until expended or/i) { $discharge= 1; } elsif ($dur=~s/until discharged\s*\([^\)]+\)\s*or//i) { $discharge= 1; } elsif ($dur=~s/( or )?until discharged(, whichever comes first)?$//i) { $discharge= 1; } elsif ($dur=~s/( or )?until used//i) { $discharge= 1; } ### remove extraneous "up to" or "no more than" statements $dur=~s/^(up to|no more than)\s*//i; ### special cases $dur=~s/\(apparent time\)//i; # Time Stop comment $dur=~s/^until landing or//i; # Feather Fall comment $dur=~s/or until the character returns to the character\'s body$//i; if ($dur=~s/or until [\w\s]+$//i) { $seetext++; } # Suggestion comment ### replace numbers, using word break "\b" to distinguish $dur=~s/\bone\b/1/i; $dur=~s/\btwo\b/2/i; $dur=~s/\bthree\b/3/i; $dur=~s/\bfour\b/4/i; $dur=~s/\bfive\b/5/i; $dur=~s/\bsix\b/6/i; $dur=~s/\bseven\b/7/i; $dur=~s/\beight\b/8/i; $dur=~s/\bnine\b/9/i; $dur=~s/\bten\b/10/i; ### remove leading and trailing spaces $dur=~s/^\s+//; $dur=~s/\s+$//; my %tabbr=("round"=>"rnd","minute"=>"min","hour"=>"hr","day"=>"day"); my $unit= "round|minute|hour|day"; if ($dur=~/^(1 round\/)?Instantaneous( \(1 round\))?$/) { $abbr= "Inst"; } elsif ($dur=~/^Permanent$/) { $abbr= "Perm"; } elsif ($dur=~/^1 action$/) { $abbr= "1 act"; } elsif ($dur=~/^([\dd+]+) ($unit)s?$/) { # i.e. "2","1d6+2",... $abbr= "$1 $tabbr{$2}s"; } elsif ($dur=~/^(\d\d?) ($unit)s?\s?\/\s?level$/) { $abbr= "Lx$1 $tabbr{$2}s"; } elsif ($dur=~/^(\d) ($unit)s?\s*\+\s*(\d) ($unit)s?\/(\d )?levels?$/) { $abbr= "$1 + Lx$3/$5 $tabbr{$2}s"; } else { return "*"; } $abbr= "Conc".$concentration.$abbr if ($concentration); $abbr .= "/Dischg" if ($discharge); if ($seetext) { $abbr .= "(*)"; } elsif ($dismissable) { $abbr .= "(D)"; } return $abbr; } ###################################################################### =item readdescriptionfile This takes in a filename and parses it for spell descriptions in the original SRD format. =cut sub readdescriptionfile { my $self= shift; my $file= shift; my $spellname= undef; my $num= 0; my $fh= new FileHandle; open($fh,$file) or die "Couldn't open file '$file'"; while (<$fh>) { if (//) { croak "non-title " unless /

\s*(.*?)\s*<\/em><\/p>/; $num++; $spellname= $1; $spellname=~s/’/'/g; $spellname=~s/ / /g; $spellname=~s/Mord's/Mordenkein's/; $self->newspell($spellname); } elsif (not $spellname) { next; # ignore text before a spell is there } elsif (/<\/body/) { last; } elsif ((/^(

)?([\w\s,\/]+):/) && isastat($2)) { # the stat may go over line - continue until
or

while (not m/(
|<\/p>)/) { chomp($_); $_=$_." ".<$fh>; } m/^(

)?([\w\s,\/]+):\s+(.*?)\s*(
|<\/p>)/ or croak "Bad stat line in '$file' line $., under '$spellname'\n$_"; my ($stat,$value)= (isastat($2),$3); $value=~s/’/'/g; $value=~s/ / /g; if (defined($self->getstat($spellname,"Description")) and not ($stat=~/Focus|XP Cost|Components/) and $debug) { warn "Possible parsing error in '$file' line $.\n" . " -> '$spellname' stat '$stat' comes after desc start\n"; } if ($stat eq "Level") { my $bad=undef; my @parts= split(',',$value); for (@parts) { m/^\s*([\w\/]+) (\d)\s*$/ or $bad="Bad pattern '$_'"; isaclass($1) or isadomain($1) or $bad="Unknown class/domain '$1'"; } warn $bad if (defined($bad)); } if ($stat eq "Components") { my $p= "V|S|M|F|DF|XP"; # must match "(V), M, F/DF (see text)" $value=~m/^(\s*\(?($p)\)?[,\/])*\s*($p)\s*(\(see text\))?/ or warn "Unknown component '$value'"; } $self->setstat($spellname,$stat,$value); } elsif ((/^(

)(\w+)\s*(.*)(
)?/) && isaschool($2)) { while (not m/(
|<\/p>)/) { # may go over line chomp($_); $_=$_." ".<$fh>; } m/^(

)(\w+)\s*(.*)
/ or die; $self->setstat($spellname,"School",$2); $self->setstat($spellname,"Other",$3); } elsif (/\w/) { ### The phrase "As " at the start of a ### description indicates that it defaults to the stats ### of another spell (i.e. the "Base Spell") ### ### Right now always assign a base spell. We can ### only check if it is an actual base spell later (since ### we don't know all the spell names yet). if (m/^(

)?As ([^,]+),/ and not $self->getstat($spellname,"Description")) { my $basespell= $2; $basespell=~s/’/'/g; $self->setstat($spellname,"Base Spell",$basespell); } # description is previous description plus this line my $descrip= $self->getstat($spellname,"Description") . $_; $self->setstat($spellname,"Description",$descrip); } } close($fh); return $num; } ###################################################################### =item readlistfile This takes in a filename and parses it for class spell lists in the original SRD format. =cut sub readlistfile { my $self= shift; my $file= shift; # temporary variables to keep track of what class, level, domain, # and info we are currently in. my $class= undef; my $level= undef; my $domain= undef; my $rowtext= undef; my $num; my $fh= new FileHandle; open($fh,$file) or croak "Couldn't open file '$file'"; while (<$fh>) { if (//) { # underline tags denote title lines # append the next line if neccessary if (not m/<\/u>/) { chomp($_); $_=$_." ".<$fh>; } # make sure it is appropriate (catch "SORCEROR AND WIZARD") if (m/(\d)\w*-LEVEL\s+([A-Z]+)[A-Z ]*\s+SPELLS.*<\/u>/i) { $level= $1; $class= isaclass($2) or croak "Unknown class '$2' in file '$file' line $."; $domain= undef; } elsif (m/\s*(\w+)\s+Domain\s*<\/u>/) { $level= undef; $class= isaclass("cleric"); $domain= $1; } else { croak "non-title tag in file '$file' line $."; } } elsif (not ($class or $level or $domain)) { next; } elsif (/<\/body>/) { last; } if ((/]*>//g; # remove + $rowtext=~s/ / /g; # put spaces in for   $rowtext=~s/&\#146;/\'/g; # put "'" in for ’ $rowtext=~s/\s+/ /g; # remove multiple spaces while ($rowtext=~/]*>\s*([^<]*?)\s*addspelltolist($prefix.$_,$class,$level); $self->setstat($prefix.$_,"Blurb",$blurb); } } else { $spellname=~s/\s*\(\w+\/?\w*\)\s*$//; $self->addspelltolist($spellname,$class,$level); $self->setstat($spellname,"Blurb",$blurb); } } elsif (defined($rowtext)) { $rowtext.=$_; } } # end of while (<$fh>) close($fh); return $num; } ###################################################################### =item usebasespell This runs through all known spells and for those with a recognized "Base Spell", it tries to fill in unknown stats by taking the value from the base spell stat. =cut sub usebasespell { my $self= shift; my @statlist= $self->getstats(); my @spelllist= $self->getspells(); foreach my $spell (@spelllist) { my $basespell= $self->getstat($spell,"Base Spell"); next unless defined($basespell); warn "'$spell' has unknown base spell '$basespell'\n" if ($debug and not $self->isaspell($basespell)); next unless $self->isaspell($basespell); foreach my $stat (@statlist) { next if defined($self->getstat($spell,$stat)); my $value= $self->getstat($basespell,$stat); next unless defined($value); $self->setstat($spell,$stat,$value); } } } ###################################################################### 1; # required end of module line __END__ =head1 NOTE This is tailored for reading the d20SRD document. However, it does not reproduce any of the material therein. =head1 Requirements I'd recommend using at least perl 5.003 -- if you don't have it, this is the time to upgrade! Get 5.005_02 or better. =head1 AUTHORS John H. Kim =cut