Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #!/usr/bin/perl
- use common::sense;
- use IO::File;
- use XML::Parser;
- use XML::Writer;
- use File::HomeDir;
- use File::Spec;
- use Data::Dumper;
- use Clone qw(clone);
- use Readonly;
- #### Prototypes
- sub order_to_rank;
- sub build_word_maps;
- sub tag_to_word;
- sub tag_to_name;
- sub remember_element;
- my %thing_read;
- my %thing_write;
- sub StartThing;
- sub StartNested;
- sub StartPassthrough;
- sub StartTag;
- sub EndTag;
- sub Char;
- sub Text;
- sub ConvertFDPower;
- sub WriteThing;
- sub WriteElements;
- #### Variables
- Readonly my $default_directory => File::Spec->catdir( File::HomeDir->my_data, q{Hero Lab}, q{Data}, q{4e} );
- my @element_path;
- my $thing_element;
- my $active_element;
- my @active_element;
- my %tag_name;
- my %tag_abbrev;
- my $active_text;
- my $next_pad;
- my $xml_writer;
- my %attribute_order = (
- document => [ qw( signature ) ],
- thing => [ qw( id compset name description summary isunique holdable maxlimit panellink stacking lotsize replaces buytemplate xactspecial isprivate ) ],
- fieldval => [ qw( field value ) ],
- arrayval => [ qw( field index column value ) ],
- usesource => [ qw( source name parent ) ],
- tag => [ qw( group tag name abbrev ) ],
- bootstrap => [ qw( thing index ) ],
- containerreq => [ qw( phase priority name ) ],
- link => [ qw( linkage thing ) ],
- eval => [ qw( phase priority index runlimit iseach sortas name isprimary ) ],
- evalrule => [ qw( phase priority message summary index severity runlimit iseach reportlimit issilent sortas name isprimary ) ],
- pickreq => [ qw( thing iserror ispreclude onlyonce issilent ) ],
- exprreq => [ qw( message iserror onlyonce issilent ) ],
- prereq => [ qw( message iserror onlyonce issilent ) ],
- child => [ qw( entity ) ],
- minion => [ qw( id ownmode isinherit ) ],
- before => [ qw( name ) ],
- after => [ qw( name ) ],
- autotag => [ qw( group tag ) ],
- assignval => [ qw( field value behavior ) ],
- );
- my %attribute_rank;
- order_to_rank( \%attribute_order, \%attribute_rank );
- my %has_text = (
- containerreq => 1,
- holdlimit => 1,
- gear => 1,
- eval => 1,
- evalrule => 1,
- exprreq => 1,
- match => 1,
- test => 1,
- validate => 1,
- );
- my %element_order = (
- document => [ qw( procedure thing portal template layout panel form sheet dossier hidden editthing faq ) ],
- thing => [ qw( fieldval arrayval usesource tag bootstrap containerreq holdlimit gear link eval evalrule pickreq exprreq prereq child minion ) ],
- bootstrap => [ qw( match containerreq autotag assignval ) ],
- containerreq => [ qw( match before after ) ],
- eval => [ qw( match before after ) ],
- evalrule => [ qw( match before after ) ],
- prereq => [ qw( match test validate ) ],
- child => [ qw( tag bootstrap ) ],
- minion => [ qw( tag bootstrap ) ],
- );
- # We do not really need to worry about these elements:
- # procedure portal template layout panel form sheet dossier hidden editthing faq
- my %element_rank;
- order_to_rank( \%element_order, \%element_rank );
- my %full_discipline_tags = (
- PowerType => 1,
- ReqLevel => 1,
- PowerClass => 1,
- PowerDest => 1,
- PowerPath => 1,
- RecomClass => 1,
- ReqSkill => 1,
- User => {
- NeedChosen => 1,
- PwrAsClass => 1,
- },
- # FeatureChk NeedChosen PwrAsClass
- # AttrMental AttrPhys RangeDex
- );
- my %attack_technique_supress_tags = (
- PowerClass => 1,
- PowerDest => 1,
- PowerPath => 1,
- ReqSkill => 1,
- User => {
- NeedChosen => 1,
- PwrAsClass => 1
- },
- );
- my %type_keywords = map { $_ => 1 } qw( PowerType PowerSrc PowerAcc DamageType EffectType );
- my %action_range = map { $_ => 1 } qw( ActionType AttackType );
- my %prefer_words = (
- q{Move Action} => 1,
- q{Free Action} => 1,
- q{No Action} => 1,
- q{Standard Action} => 1,
- q{Minor Action} => 1,
- q{Teleport} => 1,
- q{At-Will} => 1,
- q{Daily} => 1,
- q{Encounter} => 1,
- );
- my %word_to_tag_by_group = (
- q{} => {
- q{Aura} => q{Aura},
- q{Elemental} => q{Elemental}
- },
- q{ActionType} => {
- q{Free} => q{Free},
- q{Free Action} => q{Free},
- q{Free Action (Special)} => q{Free},
- q{Immediate Interrupt} => q{ImmedInt},
- q{Immediate Reaction} => q{ImmedReact},
- q{Minor} => q{Minor},
- q{Minor Action} => q{Minor},
- q{Move} => q{Move},
- q{Move Action} => q{Move},
- q{No Action} => q{None},
- q{None} => q{None},
- q{Opportunity Action} => q{Opportun},
- q{Standard} => q{Standard},
- q{Standard Action} => q{Standard}
- },
- q{AttackType} => {
- q{Area Burst} => q{AreaBurst},
- q{Area Wall} => q{AreaWall},
- q{Area} => q{Area},
- q{Close Blast} => q{CloseBlast},
- q{Close Burst} => q{CloseBurst},
- q{Close} => q{Close},
- q{Melee Touch} => q{MeleeTouch},
- q{Melee Weapon} => q{MeleeWep},
- q{Melee} => q{Melee},
- q{Personal} => q{Personal},
- q{Ranged Sight} => q{RangeSight},
- q{Ranged Weapon} => q{RangeWep},
- q{Ranged} => q{Range}
- },
- q{DamageType} => {
- q{Acid} => q{Acid},
- q{Cold} => q{Cold},
- q{Fire} => q{Fire},
- q{Force} => q{Force},
- q{Lightning} => q{Lightning},
- q{Necrotic} => q{Necrotic},
- q{Psychic} => q{Psychic},
- q{Radiant} => q{Radiant},
- q{Thunder} => q{Thunder}
- },
- q{EffectType} => {
- q{Artifice} => q{Artifice},
- q{Augmentable} => q{Augment},
- q{Beast} => q{Beast},
- q{Beast Form} => q{BeastForm},
- q{Charm} => q{Charm},
- q{Conjuration} => q{Conjur},
- q{Fear} => q{Fear},
- q{Full Discipline} => q{FullDisc},
- q{Healing} => q{Healing},
- q{Illusion} => q{Illusion},
- q{Invigorating} => q{Invigorat},
- q{Paralysis} => q{Paralysis},
- q{Poison} => q{Poison},
- q{Polymorph} => q{Polymorph},
- q{Psionic} => q{Psionic},
- q{Rage} => q{Rage},
- q{Rattling} => q{Rattling},
- q{Reliable} => q{Reliable},
- q{Shadow} => q{Shadow},
- q{Sleep} => q{Sleep},
- q{Special} => q{Special},
- q{Stance} => q{Stance},
- q{Summoning} => q{Summoning},
- q{Teleport} => q{Teleport},
- q{Teleportation} => q{Teleport},
- q{Zone} => q{Zone}
- },
- q{PowerAcc} => {
- q{Implement} => q{Implement},
- q{Weapon} => q{Weapon}
- },
- q{PowerSrc} => {
- q{Arcane} => q{Arcane},
- q{Divine} => q{Divine},
- q{Martial} => q{Martial},
- q{Primal} => q{Primal}
- },
- q{PowerType} => {
- q{At-Will (Special)} => q{AtWill},
- q{At-Will} => q{AtWill},
- q{Daily (Special)} => q{Daily},
- q{Daily} => q{Daily},
- q{Encounter (Special)} => q{Encounter},
- q{Encounter} => q{Encounter}
- }
- );
- my %word_to_group;
- my %tag_to_word;
- build_word_maps;
- # Functions
- sub order_to_rank {
- my ( $order_var, $rank_var ) = @_;
- foreach my $key ( keys %{ $order_var } ) {
- my $rank = 0;
- $rank_var->{ $key } = { map { $_ => ++$rank } @{ $order_var->{ $key } } };
- }
- }
- sub build_word_maps {
- while ( my ( $group, $records ) = each %word_to_tag_by_group ) {
- while ( my ( $word, $tag ) = each %{ $records } ) {
- $word_to_group{ $word } = $group;
- my $old_word = $tag_to_word{ $tag };
- if ( $prefer_words{ $word } || !defined $old_word ) {
- $tag_to_word{ $tag } = $word;
- }
- elsif ( ! $prefer_words{ $old_word } ) {
- warn qq{$old_word vs $word};
- }
- }
- }
- $tag_to_word{ defAC } = q{AC};
- $tag_to_word{ defFort } = q{Fort};
- $tag_to_word{ defRef } = q{Ref};
- $tag_to_word{ defWill } = q{Will};
- $tag_to_word{ attrStr } = q{Strength};
- $tag_to_word{ attrCon } = q{Constitution};
- $tag_to_word{ attrDex } = q{Dexterity};
- $tag_to_word{ attrInt } = q{Intelligence};
- $tag_to_word{ attrWis } = q{Wisdom};
- $tag_to_word{ attrCha } = q{Charisma};
- }
- sub tag_to_word {
- my ( $tag ) = @_;
- return $tag_abbrev{ $tag } // ( $tag_to_word{ $tag } //= $tag );
- }
- sub tag_to_name {
- my ( $tag ) = @_;
- return $tag_name{ $tag } // ( $tag_to_word{ $tag } //= $tag );
- }
- sub remember_element {
- my ( $rec, $key ) = @_;
- my $array = $rec->{ $key };
- if ( q{ARRAY} ne ref $array ) {
- if ( ref $array ) {
- $array = [ $array ];
- }
- else {
- $array = [];
- }
- $rec->{ $key } = $array;
- }
- push @{ $array }, $active_element;
- }
- $thing_read{ fieldval } = sub {
- my %attrs = @_;
- my $field = $attrs{ field };
- my $value = $attrs{ value };
- $thing_element->{ fieldval }->{ $field } = $value;
- };
- $thing_read{ arrayval } = sub {
- my %attrs = @_;
- my $field = $attrs{ field };
- my $value = $attrs{ value };
- my $index = $attrs{ index };
- my $column = $attrs{ column };
- if ( defined $column ) {
- $thing_element->{ matrixval }->{ $field }->[ $index ]->[ $column ] = $value;
- }
- else {
- $thing_element->{ arrayval }->{ $field }->[ $index ] = $value;
- }
- };
- $thing_read{ usesource } = sub {
- my %attrs = @_;
- my $source = $attrs{ source };
- remember_element( $thing_element->{ usesource } //= {}, $source );
- };
- $thing_read{ tag } = sub {
- my %attrs = @_;
- my $group = $attrs{ group };
- my $tag = $attrs{ tag };
- my $name = $attrs{ name };
- my $abbrev = $attrs { abbrev };
- if ( defined $name ) {
- $tag_name{ $tag } //= $name;
- }
- if ( defined $abbrev ) {
- $tag_abbrev{ $tag } //= $abbrev;
- }
- $thing_element->{ tag }->{ $group }->{ $tag } = 1;
- };
- $thing_read{ bootstrap } = sub {
- my %attrs = @_;
- my $thing = $attrs{ thing };
- remember_element( $thing_element->{ bootstrap } //= {}, $thing );
- };
- sub StartThing {
- my ( $name, $pad, @attrs ) = @_;
- $thing_element = {
- attr => { @attrs },
- pad => $pad,
- };
- $active_element = $thing_element;
- }
- sub StartNested {
- my ( $name, $pad, @attrs ) = @_;
- push @active_element, $active_element;
- my $parent_element = $active_element;
- my $is_thing_top = ( $parent_element == $thing_element );
- $active_element = {
- attr => { @attrs },
- pad => $pad,
- };
- my $code;
- if ( $is_thing_top ) {
- $code = $thing_read{ $name };
- }
- if ( $code ) {
- $code->( @attrs );
- }
- else {
- remember_element( $parent_element->{elements} //= {}, $name );
- }
- }
- sub StartPassthrough {
- my ( $name, $pad, @attrs ) = @_;
- }
- sub StartTag {
- my ( $e, $name, @attrs ) = @_;
- Text();
- my $pad = $next_pad;
- undef $next_pad;
- push @element_path, $name;
- if ( $thing_element ) {
- StartNested( $name, $pad, @attrs );
- }
- elsif ( 2 == scalar @element_path
- && $element_path[ 0 ] eq q{document}
- && $element_path[ 1 ] eq q{thing} ) {
- StartThing( $name, $pad, @attrs );
- }
- else {
- StartPassthrough( $name, $pad, @attrs );
- }
- }
- sub EndTag {
- pop @element_path;
- Text();
- my $pad = $next_pad;
- undef $next_pad;
- if ( $thing_element ) {
- if ( $thing_element == $active_element ) {
- if ( $thing_element->{ tag }->{ EffectType }->{ FullDisc }
- && $thing_element->{ attr }->{ compset } eq q{Power} ) {
- ConvertFDPower( $thing_element );
- }
- undef $thing_element;
- }
- $active_element = pop @active_element;
- }
- }
- sub Char {
- my ( $e, $text ) = @_;
- $active_text .= $text;
- }
- sub Text {
- if ( $active_text =~ s{ \n ( \h* ) \z }{}xms ) {
- $next_pad = $1;
- }
- else {
- undef $next_pad;
- }
- if ( $active_element && $active_text ne q{} ) {
- $active_element->{ text } .= $active_text;
- }
- $active_text = q{};
- }
- sub TagsForGroup {
- my ( $power, @groups ) = @_;
- my @res;
- foreach my $group ( @groups ) {
- my $tags = $power->{ tag }->{ $group };
- next unless $tags;
- push @res, grep { $tags->{ $_ } } keys %{ $tags };
- }
- return @res;
- }
- sub InfoPower {
- my ( $power, %args ) = @_;
- my $details = q{{align center}{b}} . $power->{ attr }->{ name } . q{{/b}{br}{align left}};
- if ( !$args{ no_flavor } && defined $power->{ fieldval }->{ pwFlavor } ) {
- $details .= q{{i}} . $power->{ fieldval }->{ pwFlavor } . q{{/i}{br}{br}};
- }
- if ( !$args{ no_usage } ) {
- my $any;
- my @use;
- foreach my $group ( qw( PowerUse PowerType ) ) {
- @use = map { tag_to_word( $_ ) } TagsForGroup( $power, $group );
- last if @use;
- }
- my @keywords = map { tag_to_word( $_ ) } TagsForGroup( $power, qw( PowerSrc EffectType PowerAcc DamageType ) );
- if ( @use || @keywords ) {
- $details .= q{{b}} . join( q{{/b} {font Wingdings}w{font revert} {b}}, @use, join( q{, }, @keywords ) ) . q{{/b}{br}};
- }
- }
- my ( $action ) = TagsForGroup( $power, q{ActionType} );
- my ( $attack ) = TagsForGroup( $power, q{AttackType} );
- if ( $action || $attack ) {
- $details .= q{{b}};
- if ( $action ) {
- $details .= tag_to_name( $action );
- if ( $attack ) {
- $details .= q{ - };
- }
- }
- if ( $attack ) {
- $details .= tag_to_name( $attack );
- }
- $details .= q{{/b}};
- if ( $power->{ fieldval }->{ pwRange1 } ) {
- $details .= q{ } . $power->{ fieldval }->{ pwRange1 };
- if ( $power->{ fieldval }->{ pwRange2 } ) {
- $details .= q{ Within } . $power->{ fieldval }->{ pwRange2 } . q{ Square};
- if ( $power->{ fieldval }->{ pwRange2 } != 1 ) {
- $details .= q{s};
- }
- }
- }
- $details .= q{{br}};
- }
- my ( $link ) = TagsForGroup( $power, q{ PowerLink } );
- if ( $link ) {
- $details .= q{{b}} . tag_to_name( $link ) . q{{/b}};
- if ( $link =~ m{(\d+)$} ) {
- $details .= qq{ ($1 use} . ( $1 != 1 ? q{s} : q{} ) . q{ total)};
- }
- $details .= q{{br}};
- }
- my $special = $power->{ fieldval }->{ pwSpecial };
- if ( $special ) {
- $details .= q{{b}Special:{/b} }. $special . q{{br}};
- }
- my $require = $power->{ fieldval }->{ pwRequire };
- if ( $require ) {
- $details .= q{{b}Requirements:{/b} }. $require . q{{br}};
- }
- my $target = $power->{ fieldval }->{ pwTarget };
- if ( $target ) {
- $details .= q{{b}Target:{/b} } . $target . q{{br}};
- }
- ( $attack ) = TagsForGroup( $power, q{Attack} );
- if ( $attack ) {
- $details .= q{{b}Attack:{/b} };
- if ( $power->{ fieldval }->{ spcNotes } ) {
- $details .= q{{b}} . $power->{ fieldval }->{ spcNotes } . q{{/b} (};
- }
- $details .= tag_to_name( $attack );
- my $atk_mode = 0 + $power->{ fieldval }->{ pwAtkMod };
- if ( $atk_mode ) {
- $details .= q{ } . $atk_mode;
- }
- my ( $vs ) = TagsForGroup( $power, q{AttackVs} );
- if ( $vs ) {
- $details .= q{ vs. } . tag_to_word( $vs );
- }
- my $extra = $power->{ fieldval }->{ pwAtkExtra };
- if ( defined $extra ) {
- $details .= $extra;
- }
- if ( $power->{ fieldval }->{ spcNotes } ) {
- $details .= q{)};
- }
- $details .= q{{br}};
- }
- $details =~ s{ (?: {br} )* \z}{{br}{br}}xms;
- return $details;
- }
- sub SplitDescription {
- my ( $orig_power, $fd_power, $at_power, $mt_power, $base_name ) = @_;
- my $mt_detail;
- my @at_desc;
- my @mt_desc;
- my $desc = $orig_power->{ attr }->{ description };
- my @desc = split( m[ {br}{br} (?! {br} ) ]xms, $desc );
- while ( @desc ) {
- my $piece = shift @desc;
- if ( $piece =~ s{ \A \Q${base_name}\E\s* \[ \w* \s Technique \] }{}xms ) {
- $mt_detail = $piece;
- @mt_desc = @desc;
- last;
- }
- push @at_desc, $piece;
- }
- # Hot fix Tiger Claw Rake
- if ( $base_name eq q{Tiger Claw Rake} ) {
- if ( !defined $mt_detail ) {
- $mt_detail = q{{b}Encounter{/b} {b}{b}Full Discipline{/b}, {b}Psionic{/b}{br}{b}Move Action{/b}{b}Personal{/b} };
- @mt_desc = ( q{{i}This power did not parse correctly. Should be something like:{/i}{br}Move 2+ speed, ignoring difficult terrain and mark ( until end of turn ) and do strength mod damage to any enemy that makes an op attack against you during this move.} );
- }
- }
- if ( !defined $mt_detail ) {
- warn $base_name, q{ does not have information for movement technique};
- return;
- }
- if ( $mt_detail =~ m{ \A {i} (.*) {/i} \z }xms ) {
- $mt_power->{ fieldvar }->{ pwFlavor } = $1;
- $mt_detail = shift @mt_desc;
- }
- my ( $type_keywords, $action_range ) = split( m{ {br} }xms, $mt_detail, 2 );
- state $match_word = qr{ (?<= \{ b \} ) ( (?: [^\{]++ | \{ (?! /b \} ) )*+ ) (?= \{ /b \} ) }xms;
- $type_keywords =~ s[ {b}(?:{b})+ ][{b}]xms;
- foreach my $keyword ( $type_keywords =~ m{ $match_word }xmsgo ) {
- my $word_type = $word_to_group{ $keyword } // q{Unknown group};
- next if ( $word_type eq q{} );
- my $word_tag = $word_to_tag_by_group{ $word_type }->{ $keyword };
- unless ( $type_keywords{ $word_type } && defined $word_tag ) {
- warn q{Unable to process keyword: }, $keyword, q{ / group: }, $word_type, q{ skipping: }, $base_name, q{\n};
- return;
- }
- $mt_power->{ tag }->{ $word_type }->{ $word_tag } = 1;
- }
- $action_range =~ s[ {b}(?:{b})+ ][{b}]xms;
- foreach my $keyword ( $action_range =~ m{ $match_word }xmsgo ) {
- my $word_type = $word_to_group{ $keyword } // q{Unknown group};
- next if ( $word_type eq q{} );
- my $word_tag = $word_to_tag_by_group{ $word_type }->{ $keyword };
- unless ( $action_range{ $word_type } && defined $word_tag ) {
- warn q{Unable to process keyword: }, $keyword, q{ / group: }, $word_type, q{ skipping: }, $base_name, q{\n};
- return;
- }
- $mt_power->{ tag }->{ $word_type }->{ $word_tag } = 1;
- }
- $action_range =~ s{ .* {/b} }{}xms;
- $action_range =~ s{ \A \s* (?: : \s* )? }{}xms;
- $action_range =~ s{ \s* \z }{}xms;
- my ( $attack_type ) = keys %{ $mt_power->{ tag }->{ AttackType } };
- $attack_type //= q{Personal};
- delete $mt_power->{ tag }->{ AttackType };
- if ( $action_range =~ s{ \s* Within \s+ ( \d+ ) \s+ squares? \z}{}xmsi ) {
- $mt_power->{ fieldval }->{ pwRange2 } = $1;
- }
- if ( $action_range =~ s{ \s* ( \d+ ) \z}{}xmsi ) {
- $mt_power->{ fieldval }->{ pwRange1 } = $1;
- }
- given( $action_range ) {
- when ( qr{\A Weapon \z}xmsi ) {
- if ( $attack_type =~ m{ \A (?: Melee | Range ) \z } ) {
- $attack_type .= "Wep";
- }
- else {
- undef $attack_type;
- }
- }
- when ( qr{\A Touch \z}xmsi ) {
- if ( $attack_type eq q{Melee} ) {
- $attack_type = "MeleeTouch";
- }
- else {
- undef $attack_type;
- }
- }
- when ( qr{\A Sight \z}xmsi ) {
- if ( $attack_type eq q{Range} ) {
- $attack_type = "RangeSight";
- }
- else {
- undef $attack_type;
- }
- }
- when ( qr{\A Burst \z}xmsi ) {
- if ( $attack_type =~ m{ \A (?: Close | Area ) \z } ) {
- $attack_type .= q{Burst};
- }
- else {
- undef $attack_type;
- }
- }
- when ( qr{\A Wall \z}xmsi ) {
- if ( $attack_type eq q{Area} ) {
- $attack_type .= q{Burst};
- }
- else {
- undef $attack_type;
- }
- }
- when ( qr{\A Blast \z}xmsi ) {
- if ( $attack_type eq q{Close} ) {
- $attack_type .= q{Burst};
- }
- else {
- undef $attack_type;
- }
- }
- default {
- if ( $attack_type eq q{Close} ) {
- undef $attack_type;
- }
- }
- }
- if ( defined $attack_type ) {
- $mt_power->{ tag }->{ AttackType }->{ $attack_type } = 1;
- }
- else {
- delete $mt_power->{ fieldval }->{ pwRange1 };
- delete $mt_power->{ fieldval }->{ pwRange2 };
- }
- unless ( TagsForGroup( $mt_power, q{PowerType} ) ) {
- my ( $type ) = TagsForGroup( $orig_power, qw{PowerUse PowerType} );
- $mt_power->{ tag }->{ PowerType }->{ $type } = 1;
- }
- my $at_desc = $at_power->{ attr }->{ description } = join( q{{br}{br}}, @at_desc );
- my $mt_desc = $mt_power->{ attr }->{ description } = join( q{{br}{br}}, @mt_desc );
- $fd_power->{ attr }->{ description } = join( q{{br}{br}},
- q{This is a full discipline power which consists of both a attack technique and movement technique.},
- InfoPower( $orig_power, no_flavor => 1 ) . $at_desc,
- InfoPower( $mt_power, no_flavor => 1 ) . $mt_desc,
- );
- return 1;
- }
- sub ConvertFDPower {
- my ( $orig_power ) = @_;
- if ( $orig_power->{ elements }->{ eval } ) {
- warn q{Can not process: }, $orig_power->{ attr }->{ name }, qq{\n};
- return;
- }
- my $fd_power = {};
- my $at_power = {};
- my $mt_power = {};
- # Attributes
- $fd_power->{ attr } = clone( $orig_power->{ attr } // {} );
- $at_power->{ attr } //= {};
- $mt_power->{ attr } //= {};
- # Attribute( id )
- my $orig_id = $orig_power->{ attr }->{ id };
- my $post_id = $orig_id;
- $post_id =~ s{\A (..) .. }{}xms;
- my $pre_id = $1;
- my $fd_id = $pre_id . q{FD} . $post_id;
- my $at_id = $pre_id . q{AT} . $post_id;
- my $mt_id = $pre_id . q{MT} . $post_id;
- $fd_power->{ attr }->{ id } = $fd_id;
- $fd_power->{ attr }->{ replaces } = $orig_id;
- $at_power->{ attr }->{ id } = $at_id;
- $mt_power->{ attr }->{ id } = $mt_id;
- # Fields
- $at_power->{ fieldval } = clone( $orig_power->{ fieldval } // {} );
- $at_power->{ arrayval } = clone( $orig_power->{ arrayval } // {} );
- $at_power->{ matrixval } = clone( $orig_power->{ matrixval } // {} );
- if ( defined $orig_power->{ fieldval }->{ pwFlavor } ) {
- $mt_power->{ fieldval }->{ pwFlavor } //= $orig_power->{ fieldval }->{ pwFlavor };
- }
- # Attribute( name )
- my $orig_name = $orig_power->{ attr }->{ name };
- ( my $base_name = $orig_name ) =~ s{ \s* \[ \w* \s Technique \] \s* \z}{}xms;
- $fd_power->{ attr }->{ name } = $base_name . q{ [Full Discipline]};
- $at_power->{ attr }->{ name } = $orig_name;
- $mt_power->{ attr }->{ name } = $base_name . q{ [Movement Technique]};
- # Tags
- my $groups = $orig_power->{ tag } // {};
- foreach my $group ( keys %{ $groups } ) {
- my $fd_status = $full_discipline_tags{ $group };
- my $at_status = $attack_technique_supress_tags{ $group };
- my $tags = $groups->{ $group };
- foreach my $tag ( keys %{ $tags } ) {
- if ( $fd_status ) {
- if ( !ref $fd_status || $fd_status->{ $tag } ) {
- $fd_power->{ tag }->{ $group }->{ $tag } = 1;
- }
- }
- if ( $at_status ) {
- if ( ref $at_status && !$at_status->{ $tag } ) {
- $at_power->{ tag }->{ $group }->{ $tag } = 1;
- }
- }
- else {
- $at_power->{ tag }->{ $group }->{ $tag } = 1;
- }
- }
- }
- $fd_power->{ tag }->{ Hide }->{ Special } = 1;
- # Tags ( PowerLink )
- # Change the if ( 1 ) to an if ( 0 ) if you do not want the link between the powers
- if ( 1 ) {
- my $link_id = q{fd} . $post_id . q{1};
- $tag_name{ $link_id } = $fd_power->{ attr }->{ name };
- $tag_abbrev{ $link_id } = $base_name;
- $at_power->{ tag }->{ PowerLink }->{ $link_id } = 1;
- $mt_power->{ tag }->{ PowerLink }->{ $link_id } = 1;
- }
- # Attribute ( compset )
- $fd_power->{ attr }->{ compset } = q{Power};
- $at_power->{ attr }->{ compset } = q{Power};
- $mt_power->{ attr }->{ compset } = q{Power};
- # Attribute( description )
- SplitDescription( $orig_power, $fd_power, $at_power, $mt_power, $base_name )
- or return;
- # Attribute( isunique )
- my $val = $orig_power->{ attr }->{ isunique };
- if ( defined $val ) {
- $fd_power->{ attr }->{ isunique } = $val;
- $at_power->{ attr }->{ isunique } = $val;
- $mt_power->{ attr }->{ isunique } = $val;
- }
- # Source
- $fd_power->{ usesource } = $orig_power->{ usesource };
- $at_power->{ usesource } = $orig_power->{ usesource };
- $mt_power->{ usesource } = $orig_power->{ usesource };
- # Bootstraps
- $fd_power->{ bootstrap } = clone( $orig_power->{ bootstrap } // {} );
- $fd_power->{ bootstrap }->{ $at_id } //= 1;
- $fd_power->{ bootstrap }->{ $mt_id } //= 1;
- # Elements
- $fd_power->{ elements } = clone( $orig_power->{ elements } // {} );
- #WriteThing( $orig_power );
- WriteThing( $at_power );
- WriteThing( $mt_power );
- WriteThing( $fd_power );
- }
- sub WriteThing {
- my ( $thing ) = @_;
- my $pad = qq{\n };
- my $attrs = $thing->{ attr };
- my @attrs = ();
- my $attr_order = $attribute_order{ thing };
- my $attr_rank = $attribute_rank{ thing };
- foreach my $attr_name ( @{ $attr_order } ) {
- if ( exists $attrs->{ $attr_name } ) {
- push @attrs, $attr_name, $attrs->{ $attr_name };
- }
- }
- foreach my $attr_name ( sort keys %{ $attrs } ) {
- if ( ! $attr_rank->{ $attr_name } ) {
- push @attrs, $attr_name, $attrs->{ $attr_name };
- }
- }
- $xml_writer->characters( $pad );
- $xml_writer->startTag( q{thing}, @attrs );
- my $elements = $thing->{ elements };
- my $elem_order = $element_order{ thing } //= [];
- my $elem_rank = $element_rank{ thing } //= {};
- foreach my $elem_name ( @{ $elem_order } ) {
- my $code = $thing_write{ $elem_name };
- if ( $code ) {
- $code->( $thing );
- next;
- }
- next unless $elements->{ $elem_name };
- WriteElements( 0, $elem_name, @{ $elements->{ $elem_name } } );
- }
- foreach my $elem_name ( sort keys %{ $elements } ) {
- next if $elem_rank->{ $elem_name };
- my $code = $thing_write{ $elem_name };
- if ( $code ) {
- $code->( $thing );
- next;
- }
- WriteElements( 0, $elem_name, @{ $elements->{ $elem_name } } );
- }
- $xml_writer->characters( $pad );
- $xml_writer->endTag( q{thing} );
- }
- $thing_write{ fieldval } = sub {
- my ( $thing ) = @_;
- my $fields = $thing->{ fieldval };
- return unless $fields;
- my $pad = qq{\n };
- foreach my $field ( sort keys %{ $fields } ) {
- my $value = $fields->{ $field };
- next unless defined $value;
- $xml_writer->characters( $pad );
- $xml_writer->emptyTag( q{fieldval}, field => $field, value => $value );
- }
- };
- $thing_write{ arrayval } = sub {
- my ( $thing ) = @_;
- my $pad = qq{\n };
- my $arrays = $thing->{ arrayval };
- my $matrices = $thing->{ maxtrixval };
- if ( $arrays ) {
- foreach my $field ( sort keys %{ $arrays } ) {
- my $array = $arrays->{ $field };
- my $index_size = scalar @{ $array };
- for ( my $index = 0; $index < $index_size; ++$index ) {
- my $value = $array->[ $index ];
- next unless defined $value;
- $xml_writer->characters( $pad );
- $xml_writer->emptyTag( q{arrayval}, field => $field, index => $index, value => $value );
- }
- }
- }
- if ( $matrices ) {
- foreach my $field ( sort keys %{ $matrices } ) {
- my $matrix = $matrices->{ $field };
- my $index_size = scalar @{ $matrix };
- for ( my $index = 0; $index < $index_size; ++$index ) {
- my $row = $matrix->[ $index ];
- next unless $row;
- my $column_size = scalar @{ $row };
- for ( my $column = 0; $column < $column_size; ++$column ) {
- my $value = $row->[ $column ];
- next unless defined $value;
- $xml_writer->characters( $pad );
- $xml_writer->emptyTag( q{arrayval}, field => $field, index => $index, column => $column, value => $value );
- }
- }
- }
- }
- };
- $thing_write{ usesource } = sub {
- my ( $thing ) = @_;
- my $sources = $thing->{ usesource };
- return unless $sources;
- my $pad = qq{\n };
- foreach my $source ( sort keys %{ $sources } ) {
- $xml_writer->characters( $pad );
- $xml_writer->emptyTag( q{usesource}, source => $source );
- }
- };
- $thing_write{ tag } = sub {
- my ( $thing ) = @_;
- my $groups = $thing->{ tag };
- return unless $groups;
- my $pad = qq{\n };
- foreach my $group ( sort keys %{ $groups } ) {
- my $tags = $groups->{ $group };
- next unless $tags;
- foreach my $tag ( sort keys %{ $tags } ) {
- next unless $tags->{ $tag };
- my @extra;
- state %tag_written;
- if ( ! $tag_written{ $tag } ) {
- $tag_written{ $tag } = 1;
- if ( exists $tag_name{ $tag } ) {
- push @extra, name => $tag_name{ $tag };
- }
- if ( exists $tag_abbrev{ $tag } ) {
- push @extra, abbrev => $tag_abbrev{ $tag };
- }
- }
- $xml_writer->characters( $pad );
- $xml_writer->emptyTag( q{tag}, group => $group, tag => $tag, @extra );
- }
- }
- };
- $thing_write{ bootstrap } = sub {
- my ( $thing ) = @_;
- my $bootstraps = $thing->{ bootstrap };
- return unless $bootstraps;
- my $pad = qq{\n };
- foreach my $bootstrap ( keys %{ $bootstraps } ) {
- my $value = $bootstraps->{ $bootstrap };
- next unless $value;
- if ( ref $value ) {
- if ( @{ $value } ) {
- WriteElements( 0, q{bootstrap}, @{ $value } );
- next;
- }
- }
- $xml_writer->characters( $pad );
- $xml_writer->emptyTag( q{bootstrap}, thing => $bootstrap );
- }
- };
- sub WriteElements {
- my ( $depth, $name, @records ) = @_;
- my $pad = qq{\n} . ( ' ' x ( 4 + 2 * $depth ) );
- foreach my $record ( @records ) {
- my $attrs = $record->{ attr };
- my @attrs = ();
- my $attr_order = $attribute_order{ $name } //= [];
- my $attr_rank = $attribute_rank{ $name } //= {};
- foreach my $attr_name ( @{ $attr_order } ) {
- next unless exists $attrs->{ $attr_name };
- push @attrs, $attr_name, $attrs->{ $attr_name };
- }
- foreach my $attr_name ( sort keys %{ $attrs } ) {
- next if $attr_rank->{ $attr_name };
- push @attrs, $attr_name, $attrs->{ $attr_name };
- }
- $xml_writer->characters( $pad );
- if ( exists $record->{ elements } || exists $record->{ text } || $has_text{ $name } ) {
- $xml_writer->startTag( $name, @attrs );
- if ( exists $record->{ text } ) {
- $xml_writer->characters( $record->{ text } );
- }
- my $elements = $record->{ elements };
- my $elem_order = $element_order{ $name } //= [];
- my $elem_rank = $element_rank{ $name } //= {};
- foreach my $elem_name ( @{ $elem_order } ) {
- next unless $elements->{ $elem_name };
- WriteElements( $depth+1, $elem_name, @{ $elements->{ $elem_name } } );
- }
- foreach my $elem_name ( sort keys %{ $elements } ) {
- next if $elem_rank->{ $elem_name };
- WriteElements( $depth+1, $elem_name, @{ $elements->{ $elem_name } } );
- }
- $xml_writer->characters( $pad );
- $xml_writer->endTag( $name );
- }
- else {
- $xml_writer->emptyTag( $name, @attrs );
- }
- }
- }
- Readonly my $powers_filename => shift // q{ddi_powers.dat};
- Readonly my $fd_filename => shift // q{fd_powers.user};
- Readonly my $powers_in_path => ( -e $powers_filename ? $powers_filename : File::Spec->catfile( $default_directory, $powers_filename ) );
- Readonly my $powers_out_path => $fd_filename eq q{-}? $fd_filename : ( -e $powers_filename ? $fd_filename : File::Spec->catfile( $default_directory, $fd_filename ) );
- unless ( -e $powers_in_path ) {
- die "Unable to find: $powers_filename\n";
- }
- my $parser = XML::Parser->new( Handlers => {
- Start => \&StartTag,
- End => \&EndTag,
- Char => \&Char
- } );
- my $output = IO::File->new( q{>} . $powers_out_path )
- or die "Unable to create output file: $powers_out_path: $!\n";
- $xml_writer = XML::Writer->new( ENCODING => q{utf-8}, OUTPUT => $output );
- $xml_writer->xmlDecl();
- $xml_writer->startTag( q{document}, signature => q{Hero Lab Data} );
- $parser->parsefile( $powers_in_path );
- $xml_writer->characters( qq{\n} );
- $xml_writer->endTag( q{document} );
- $xml_writer->end();
- $output
- or die "Error writing: $powers_out_path: $!\n";
- ####
- 1;
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement