File Coverage

blib/lib/XML/Dataset.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package XML::Dataset;

#-------------------------------------------------------------------------------
#   Module  : XML::Dataset
#
#   Purpose : Extracts XML into Datasets based upon a text profile markup
#             language
#-------------------------------------------------------------------------------
use strict;
use warnings;

use XML::LibXML::Reader;
use Data::Alias;

our $VERSION = '0.006';
our @ISA     = qw(Exporter);
our @EXPORT  = qw(parse_using_profile);

#-------------------------------------------------------------------------------
#   Call the _run method if the module was called as a script
#-------------------------------------------------------------------------------
__PACKAGE__->_run(qw ( Parameter1 Parameter2 )) unless caller();

#-------------------------------------------------------------------------------
#   Constructor
#
#   Object constructor parameters are passed directly to the object
#-------------------------------------------------------------------------------
sub new {
   my $class = shift;
   my $self  = {@_};

   # bless REF, CLASSNAME
   bless $self, $class;

   # return object
   return $self;
}

#-------------------------------------------------------------------------------
#   Subroutine : _process_record
#
#   Input      : $nodeName, $nodeValue, $record
#
#   Purpose    : Stores node information based on the profile
#-------------------------------------------------------------------------------
sub _process_record {
   my ( $self, $nodeName, $nodeValue, $record ) = @_;

   #-------------------------------------------------------------------------------
   #  If a 'name' entry is defined we want to use a custom name, replace
   #  the key name accordingly
   #-------------------------------------------------------------------------------
   my $name = defined $record->{name} ? $record->{name} : $nodeName;

   #-------------------------------------------------------------------------------
   #  If a 'prefix' entry is defined we want to prefix with a custom value, update
   #  the key name accordingly
   #-------------------------------------------------------------------------------
   $name = defined $record->{prefix} ? $record->{prefix} . ${name} : $name;

   #-------------------------------------------------------------------------------
   #  If a process declaration is made, pass the current value through the
   #  corresponding process filter prior to storing the value
   #-------------------------------------------------------------------------------
   if ( defined $record->{process} ) {

      # Check for the required process method in the main namespace
      if ( main->can("$record->{process}") ) {
         no strict "refs";    ## no critic
         $nodeValue = &{"main\::$record->{process}"}($nodeValue);
      }
      else {
         die("could not find method $record->{process} for processing");
      }
   }

   #-------------------------------------------------------------------------------
   #  If there is a dataset value
   #-------------------------------------------------------------------------------
   if ( defined $record->{dataset} ) {

      #-------------------------------------------------------------------------------
      #  If we are going to clobber an existing value or if the dataset does not
      #  already exist, create a new dataset
      #-------------------------------------------------------------------------------
      if (  ( !defined $self->{current_data}->{ $record->{dataset} } )
         || ( exists $self->{current_data}->{ $record->{dataset} }->{$name} ) ) {

         #-------------------------------------------------------------------------------
         #  Create a named hashref - $temporary_hash
         #-------------------------------------------------------------------------------
         my $temporary_hash = {};

         #-------------------------------------------------------------------------------
         #  Copy the existing external references if applicable to $temporary_hash
         #-------------------------------------------------------------------------------
         for my $external_reference ( @{ $self->{__EXTERNAL_REFERENCES__} } ) {
            if ( defined $self->{current_data}->{ $record->{dataset} }->{$external_reference} ) {
               $temporary_hash->{$external_reference} =
                 $self->{current_data}->{ $record->{dataset} }->{$external_reference};
            }
         }

         #-------------------------------------------------------------------------------
         #  Dispatch Dataset if required
         #-------------------------------------------------------------------------------
         if ( ( defined $self->{dispatch} ) && ( defined $self->{current_data}->{ $record->{dataset} } ) ) {
            $self->_dispatch_dataset( $record->{dataset} );
         }

         #-------------------------------------------------------------------------------
         #  Push the $temporary_hash on to the datastructure
         #-------------------------------------------------------------------------------
         push @{ $self->{data_structure}->{ $record->{dataset} } }, $temporary_hash;

         #-------------------------------------------------------------------------------
         #  Update the current reference with the $temporary_hash pointer
         #-------------------------------------------------------------------------------
         $self->{current_data}->{ $record->{dataset} } = $temporary_hash;
      }

      #-------------------------------------------------------------------------------
      #  Store the data within the dataset
      #-------------------------------------------------------------------------------
      $self->{current_data}->{ $record->{dataset} }->{$name} = $nodeValue;
   }

   #-------------------------------------------------------------------------------
   #  Store external data
   #-------------------------------------------------------------------------------
   elsif ( defined $record->{external_dataset} ) {

      # If the external doesn't exist, create it with a default value
      if ( !defined $self->{external_data}->{ $record->{external_dataset} }->{$name} ) {
         push @{ $self->{external_data}->{ $record->{external_dataset} }->{$name} }, '';
      }

      # If the value exists and the last entry has a value which is not '', create a new holder
      elsif ( ( defined $self->{external_data}->{ $record->{external_dataset} }->{$name}[-1] )
         && ( $self->{external_data}->{ $record->{external_dataset} }->{$name}[-1] ne '' ) ) {
         push @{ $self->{external_data}->{ $record->{external_dataset} }->{$name} }, '';
      }

      # Store the data
      $self->{external_data}->{ $record->{external_dataset} }->{$name}[-1] = $nodeValue;
   }
}

#-------------------------------------------------------------------------------
#   Subroutine : _dispatch_all
#
#   Purpose    : Dispatches all datasets or all remaining datasets
#-------------------------------------------------------------------------------
sub _dispatch_all {
   my $self = shift;
   if ( defined $self->{dispatch} ) {
      for my $dataset ( keys %{ $self->{data_structure} } ) {
         $self->_dispatch_dataset( $dataset, 1 );
      }
   }
}

#-------------------------------------------------------------------------------
#   Subroutine : _dispatch_dataset
#
#   Input      : $self, $dataset, $flush
#
#   Purpose    : Dispatches a dataset
#-------------------------------------------------------------------------------
# Closures used to isolate $dispatch_counter ( equivalent to state )
{
   my $dispatch_counter = {};

   sub _dispatch_dataset {
      my ( $self, $dataset, $flush ) = @_;

      # Increase the counter
      $dispatch_counter->{$dataset}++;

      my $counter_trigger = 0;
      if (  ( defined $self->{dispatch}->{$dataset}->{counter} )
         || ( defined $self->{dispatch}->{__generic__}->{counter} ) ) {
         $counter_trigger =
           defined $self->{dispatch}->{$dataset}->{counter}
           ? $self->{dispatch}->{$dataset}->{counter}
           : $self->{dispatch}->{__generic__}->{counter};
      }
      else {
         # Alert
      }

      my $counter_coderef;
      if (  ( defined $self->{dispatch}->{$dataset}->{coderef} )
         || ( defined $self->{dispatch}->{__generic__}->{coderef} ) ) {
         $counter_coderef =
           defined $self->{dispatch}->{$dataset}->{coderef}
           ? $self->{dispatch}->{$dataset}->{coderef}
           : $self->{dispatch}->{__generic__}->{coderef};
         if ( ref($counter_coderef) ne 'CODE' ) {

            # Alert
         }
      }
      else {
         # Alert
      }

      if ( defined $self->{data_structure}->{$dataset} ) {
         if ( ( scalar( @{ $self->{data_structure}->{$dataset} } ) >= $counter_trigger ) || ( defined $flush ) ) {

            # Call the CODEREF with the Payload
            &{$counter_coderef}( { $dataset => $self->{data_structure}->{$dataset} } );

            # Delete the processed entries
            delete $self->{data_structure}->{$dataset};
         }
      }
   }
}

sub _logging_clobber_external_information {
   my %args = @_;
}

sub _log_xml_attribute_not_defined_in_profile {
   warn "missing profile entry for attribute name=$_[0]->{name} depth=$_[0]->{depth}";
}

sub _log_xml_element_not_defined_in_profile {
   warn "missing profile entry for element name=$_[0]->{name} depth=$_[0]->{depth}";
}

#-------------------------------------------------------------------------------
#   Subroutine : _process_data
#
#   Input      : $data = Perl Structure, $profile = Text Profile
#
#   Output     : Perl Structure
#
#   Purpose    : Processes perl structures based on input profiles
#-------------------------------------------------------------------------------
sub _process_data {
   my $self = shift;
   my $node = shift;

   #-------------------------------------------------------------------------------
   #  Dispatch Table - Based on perl reference type
   #-------------------------------------------------------------------------------
   my $xml_dispatch_table = {
      0 => sub {    # XML_READER_TYPE_NONE

         #-------------------------------------------------------------------------------
         # Process all nodes in the document
         #-------------------------------------------------------------------------------
         while ( $node->read ) {

            #-------------------------------------------------------------------------------
            # Process data
            #-------------------------------------------------------------------------------
            $self->_process_data($node);
         }

      },
      1 => sub {    # XML_READER_TYPE_ELEMENT

         #-------------------------------------------------------------------------------
         # Store the previous nodeName if applicable
         #-------------------------------------------------------------------------------
         $self->{_previous_key} = defined $self->{_current_key} ? $self->{_current_key} : '';

         #-------------------------------------------------------------------------------
         #  Store the current nodeName
         #-------------------------------------------------------------------------------
         $self->{_current_key} = $node->name;

         if ( $#{ $self->{_profiles} } >= $node->depth ) {
            $self->{_profile} = $self->{_profiles}[ $node->depth - 1 ];
         }

         #-------------------------------------------------------------------------------
         #  Compare the key against the profile
         #-------------------------------------------------------------------------------
         if ( defined $self->{_profile}->{ $self->{_current_key} } ) {

            # Update the profile to the current_key
            $self->{_profile} = $self->{_profile}->{ $self->{_current_key} };

            # Store the updated profile
            $self->{_profiles}[ $node->depth ] = $self->{_profile};

            #-------------------------------------------------------------------------------
            #  If the key exists and has an __NEW_EXTERNAL_VALUE_HOLDER__ element, configure
            #  external holders
            #-------------------------------------------------------------------------------
            if ( defined $self->{_profile}->{__NEW_EXTERNAL_VALUE_HOLDER__} ) {

               #-------------------------------------------------------------------------------
               #  Process all External Values
               #-------------------------------------------------------------------------------
               for my $dataset ( @{ $self->{_profile}->{__NEW_EXTERNAL_VALUE_HOLDER__}->{__record__} } ) {
                  my ( $ext_dataset, $ext_name ) = %{$dataset};

                  push @{ $self->{external_data}->{$ext_dataset}->{$ext_name} }, '';
               }

            }

            #-------------------------------------------------------------------------------
            #  If the key exists and has an __IGNORE__ element, ignore and move to the
            #  next record
            #-------------------------------------------------------------------------------
            if ( defined $self->{_profile}->{'__IGNORE__'} ) {
            }

            #-------------------------------------------------------------------------------
            #  Otherwise continue
            #-------------------------------------------------------------------------------
            else {

               #-------------------------------------------------------------------------------
               #  Check for a new dataset marker
               #-------------------------------------------------------------------------------
               if ( defined $self->{_profile}->{__NEW_DATASET__} ) {
                  for my $dataset ( @{ $self->{_profile}->{__NEW_DATASET__} } ) {

                     #-------------------------------------------------------------------------------
                     #  Dispatch Dataset if required
                     #-------------------------------------------------------------------------------
                     if ( ( defined $self->{dispatch} ) && ( defined $self->{current_data}->{$dataset} ) ) {
                        $self->_dispatch_dataset($dataset);
                     }

                     #-------------------------------------------------------------------------------
                     #  Create a named hashref
                     #-------------------------------------------------------------------------------
                     my $temporary_hash = {};

                     #-------------------------------------------------------------------------------
                     # Push on to the datastructure
                     #-------------------------------------------------------------------------------
                     push @{ $self->{data_structure}->{$dataset} }, $temporary_hash;

                     #-------------------------------------------------------------------------------
                     #  Update the current reference with the same pointer
                     #-------------------------------------------------------------------------------
                     $self->{current_data}->{$dataset} = $temporary_hash;
                  }
               }

               #-------------------------------------------------------------------------------
               #  Check for an __EXTERNAL_VALUE__
               #-------------------------------------------------------------------------------
               if ( defined $self->{_profile}->{__EXTERNAL_VALUE__} ) {

                  #-------------------------------------------------------------------------------
                  #  Initialise default holder for external values
                  #-------------------------------------------------------------------------------
                  $self->{__EXTERNAL_REFERENCES__} = [];

                  #-------------------------------------------------------------------------------
                  #  Process all External Values
                  #-------------------------------------------------------------------------------
                  for my $dataset ( @{ $self->{_profile}->{__EXTERNAL_VALUE__} } ) {

                     #-------------------------------------------------------------------------------
                     #  Seperate the record
                     #-------------------------------------------------------------------------------
                     my ( $ext_dataset, $ext_name, $forward_dataset, $forward_name ) = split( ':', $dataset );

                     #-------------------------------------------------------------------------------
                     #  Use the supplied forwarding name if available, otherwise use the original name
                     #-------------------------------------------------------------------------------
                     if ( !defined $forward_name ) { $forward_name = $ext_name }

                     #-------------------------------------------------------------------------------
                     #  Store the external values within the object, if we encounter a clobber
                     #  situation where a new dataset is created to prevent data being overwritten
                     #  this list will provide a corresponding reference to the external values
                     #  to copy
                     #-------------------------------------------------------------------------------
                     push @{ $self->{__EXTERNAL_REFERENCES__} }, $forward_name;

                     #-------------------------------------------------------------------------------
                     #  If we've encountered the external data before we've created a dataset holder,
                     #  or the external data already exists in the dataset, create a new dataset
                     #-------------------------------------------------------------------------------
                     if (  ( !defined $self->{current_data}->{$forward_dataset} )
                        || ( defined $self->{current_data}->{$forward_dataset}->{$forward_name} ) ) {

                        #-------------------------------------------------------------------------------
                        #  Create a named hashref
                        #-------------------------------------------------------------------------------
                        my $temporary_hash = {};

                        #-------------------------------------------------------------------------------
                        # Push on to the datastructure
                        #-------------------------------------------------------------------------------
                        push @{ $self->{data_structure}->{$forward_dataset} }, $temporary_hash;

                        #-------------------------------------------------------------------------------
                        #  Update the current reference with the same pointer
                        #-------------------------------------------------------------------------------
                        $self->{current_data}->{$forward_dataset} = $temporary_hash;
                     }

                     #-------------------------------------------------------------------------------
                     #  Verify that the external data does not already exist within the dataset,
                     #  If it doesn't store accordingly
                     #-------------------------------------------------------------------------------
                     if ( !defined $self->{current_data}->{$forward_dataset}->{$forward_name} ) {

                        #-------------------------------------------------------------------------------
                        #  Check for scenarios where we are using external data before the external
                        #  data has been processed...
                        #-------------------------------------------------------------------------------
                        if ( !defined $self->{external_data}->{$ext_dataset}->{$ext_name} ) {

                           die(
                              "An attempt has been made to use external data before that data has been processed, this can result in invalid datasets.  See the __NEW_EXTERNAL_VALUE_HOLDER__ profile option within the perldoc - $ext_dataset $ext_name"
                           );
                        }

                        #-------------------------------------------------------------------------------
                        #  alias through Data::Alias  ... example taken from
                        #  http://stackoverflow.com/questions/12514234/alias-a-hash-element-in-perl
                        #-------------------------------------------------------------------------------
                        alias $self->{current_data}->{$forward_dataset}->{$forward_name} =
                          $self->{external_data}->{$ext_dataset}->{$ext_name}[-1];
                     }
                  }
               }
            }

            #-------------------------------------------------------------------------------
            #  Process attributes if they exist, these will always be key/value pairs
            #-------------------------------------------------------------------------------
            if ( $node->hasAttributes ) {
               while ( $node->moveToNextAttribute ) {

                  #-------------------------------------------------------------------------------
                  #  If the key exists and has an __IGNORE__ element, ignore and move to the
                  #  next record
                  #-------------------------------------------------------------------------------
                  if ( defined $self->{_profile}->{ $node->name }->{'__IGNORE__'} ) {
                  }

                  #-------------------------------------------------------------------------------
                  # If the attribute is defined in the profile, process
                  #-------------------------------------------------------------------------------
                  elsif ( defined $self->{_profile}->{ $node->name }->{__record__} ) {
                     for my $record ( @{ $self->{_profile}->{ $node->name }->{__record__} } ) {
                        $self->_process_record( $node->name, $node->value, $record );
                     }
                  }

                  #-------------------------------------------------------------------------------
                  # Alert if the XML Attribute is not defined according to object parameters
                  #-------------------------------------------------------------------------------
                  else {
                     if ( $self->{warn_missing_profile_entry} ) {
                        _log_xml_attribute_not_defined_in_profile(
                           {
                              name  => $node->name,
                              depth => $node->depth,
                           }
                        );
                     }
                  }
               }
            }
         }

         #-------------------------------------------------------------------------------
         #  Otherwise the element is not defined in the profile, warn or die depending
         #  on the constructor options
         #-------------------------------------------------------------------------------
         else {


            if ( $self->{warn_missing_profile_entry} ) {
               _log_xml_element_not_defined_in_profile(
                  {
                     name  => $node->name,
                     depth => $node->depth,
                  }
               );
            }

            # Skip to the next node
            $node->next;

         }
      },
      2 => sub {    # XML_READER_TYPE_ATTRIBUTE
                    # Not needed as attributes are processed within Elements
      },
      3 => sub {    # XML_READER_TYPE_TEXT
         if ( defined $self->{_profile}->{__record__} ) {
            for my $record ( @{ $self->{_profile}->{__record__} } ) {
               $self->_process_record( $self->{_current_key}, $node->value, $record );
            }
         }
      },
      4  => sub { },
      5  => sub { },
      6  => sub { },
      7  => sub { },
      8  => sub { },
      9  => sub { },
      10 => sub { },
      11 => sub { },
      12 => sub { },
      13 => sub { },
      14 => sub { },
      15 => sub { },
      16 => sub { },
      17 => sub { },
   };

   # Call the dispatch table with the node type
   &{ $xml_dispatch_table->{ $node->nodeType } };
}

#-------------------------------------------------------------------------------
#   Subroutine : parse_using_profile
#
#   Input      : $data = Perl Structure, $profile = Text Profile
#
#   Output     : Perl Structure
#
#   Purpose    : Processes perl structures based on input profiles
#-------------------------------------------------------------------------------
sub parse_using_profile {
   my ( $xml, $profile, %options ) = @_;

   #-------------------------------------------------------------------------------
   #  Create an internal XML::Dataset object
   #-------------------------------------------------------------------------------
   my $self = XML::Dataset->new( %options );

   #-------------------------------------------------------------------------------
   #  Create an XML::LibXML::Reader Parser object
   #-------------------------------------------------------------------------------
   my $doc = XML::LibXML::Reader->new( string => $xml );

   #-------------------------------------------------------------------------------
   #  Convert the simplified profile to a perl based profile
   #  Store the profile and process
   #-------------------------------------------------------------------------------
   $self->{_profile} = $self->_expand_profile($profile);
   $self->_process_data($doc);

   #-------------------------------------------------------------------------------
   #  Delete any __external_value__ keys
   #-------------------------------------------------------------------------------
   for my $key ( keys %{ $self->{data_structure} } ) {
      if ( $key =~ m/__external_value__/ ) {
         delete $self->{data_structure}->{$key};
      }
   }

   #-------------------------------------------------------------------------------
   #  If called with a dispatch logic, dispatch any remaining entries
   #-------------------------------------------------------------------------------
   if ( defined $self->{dispatch} ) {
      $self->_dispatch_all;
   }

   else {
      my $data_structure = $self->{data_structure};

      #-------------------------------------------------------------------------------
      #  Return the data structure to the caller
      #-------------------------------------------------------------------------------
      return $self->{data_structure};
   }

}

#-------------------------------------------------------------------------------
#   Subroutine : _expand_profile
#
#   Input      : $profile_input = Text Profile
#
#   Output     : Perl Structure
#
#   Purpose    : Turns a simple profile into a perl based structure
#-------------------------------------------------------------------------------
sub _expand_profile {
   my ( $self, $profile_input ) = @_;

   #-------------------------------------------------------------------------------
   #  Holder for the complex_profile
   #-------------------------------------------------------------------------------
   my $complex_profile          = {};
   my $complex_profile_history  = [ \$complex_profile ];
   my $current_profile_position = ${ $complex_profile_history->[-1] };

   #-------------------------------------------------------------------------------
   #  Starting indentation
   #-------------------------------------------------------------------------------
   my $indentation;
   my $previous_indentation;
   my $indentation_history = [];

   #-------------------------------------------------------------------------------
   #  Capture tokens based on carriage returns
   #-------------------------------------------------------------------------------
   my @tokens = split( "\n", $profile_input );

   #-------------------------------------------------------------------------------
   #  Process all tokens
   #-------------------------------------------------------------------------------
   for my $token (@tokens) {

      #-------------------------------------------------------------------------------
      #  If the does not contain an empty entry, or whitespace only, continue
      #-------------------------------------------------------------------------------
      if ( $token !~ m/^(\s+)?$/ ) {

         #-------------------------------------------------------------------------------
         #  Capture the token data and indentation ( if available )
         #-------------------------------------------------------------------------------
         my $token_data;

         if ( $token =~ m/^(\s+)(.*)/ ) {
            $indentation = length($1);
            $token_data  = $2;
         }
         elsif ( $token =~ m/(.*)/ ) {
            $indentation = 0;
            $token_data  = $1;
         }

         #-------------------------------------------------------------------------------
         #  Capture the previous indentation, if the previous indentation is not
         #  available, mark the previous_indentation as 0
         #-------------------------------------------------------------------------------
         $previous_indentation = ( scalar( @{$indentation_history} ) > 0 ) ? $indentation_history->[-1] : 0;

         #-------------------------------------------------------------------------------
         #  If the indentation has increased, store the indentation in the history
         #-------------------------------------------------------------------------------
         if ( $indentation > $previous_indentation ) {
            push @{$indentation_history}, $indentation;
         }

         #-------------------------------------------------------------------------------
         #  Otherwise if the indentation has decreased
         #-------------------------------------------------------------------------------
         elsif ( $previous_indentation > $indentation ) {
            while ( $previous_indentation > $indentation ) {
               pop @{$indentation_history};
               $previous_indentation = $indentation_history->[-1];
               pop @{$complex_profile_history};
               $current_profile_position = ${ $complex_profile_history->[-1] };
            }
         }

         #-------------------------------------------------------------------------------
         #  Process if the token contains an equals
         #-------------------------------------------------------------------------------
         if ( $token_data =~ m/=/ ) {

            #-------------------------------------------------------------------------------
            #  Seperate the key and record holder based on the equal
            #-------------------------------------------------------------------------------
            my ( $key, $record_holder ) = split( '=', $token_data );

            #-------------------------------------------------------------------------------
            #  Remove any whitespace from the key and record_holder <-- address with common
            #-------------------------------------------------------------------------------
            $key =~ s/^\s+//g;
            $key =~ s/\s+$//g;
            $record_holder =~ s/^\s+//g;
            $record_holder =~ s/\s+$//g;

            #-------------------------------------------------------------------------------
            #  Check for __IGNORE__, place the corresponding marker if required and
            #  move to the next record
            #-------------------------------------------------------------------------------
            if ( $record_holder =~ m/__IGNORE__/ ) {
               $current_profile_position->{$key}{'__IGNORE__'} = 1;
               next;
            }

            #-------------------------------------------------------------------------------
            #  Seperate unprocessed records from the record_holder using whitespace as
            #  the seperator
            #-------------------------------------------------------------------------------
            my @records_unprocessed = split( /\s+/, $record_holder );

            #-------------------------------------------------------------------------------
            #  If there is a marker for a __NEW_DATASET__ store the corresponding dataset
            #  names against the marker
            #-------------------------------------------------------------------------------
            if ( $key =~ m/__NEW_DATASET__/ ) {
               $current_profile_position->{__NEW_DATASET__} = \@records_unprocessed;
            }

            #-------------------------------------------------------------------------------
            #  If there is a marker for a __EXTERNAL_VALUE__ store the corresponding dataset
            #  names against the marker
            #-------------------------------------------------------------------------------
            elsif ( $key =~ m/__EXTERNAL_VALUE__/ ) {
               $current_profile_position->{__EXTERNAL_VALUE__} = \@records_unprocessed;
            }

            #-------------------------------------------------------------------------------
            #  Otherwise treat as unprocessed records
            #-------------------------------------------------------------------------------
            else {
               for my $record_unprocessed (@records_unprocessed) {

                  #-------------------------------------------------------------------------------
                  #  Initialise a hash_ref store
                  #-------------------------------------------------------------------------------
                  my $hash_ref = {};

                  #-------------------------------------------------------------------------------
                  #  For each record ( seperated by , ) store key value pair in hash_ref
                  #  ( where key values are seperated by : )
                  #-------------------------------------------------------------------------------
                  for my $record ( split( ',', $record_unprocessed ) ) {
                     my ( $record_key, $record_value ) = split( ':', $record );

                     #-------------------------------------------------------------------------------
                     #  Store the item in the profile
                     #-------------------------------------------------------------------------------
                     $hash_ref->{$record_key} = $record_value;
                  }

                  #-------------------------------------------------------------------------------
                  #  Push the hash_ref onto the profile
                  #-------------------------------------------------------------------------------
                  push( @{ $current_profile_position->{$key}->{__record__} }, $hash_ref );
               }
            }
         }

         #-------------------------------------------------------------------------------
         #  Otherwise treat the record as a structural marker
         #-------------------------------------------------------------------------------
         else {
            # Initialise the new token as an anonymous hash
            $current_profile_position->{$token_data} = {};

            # Push the new position on to the stack
            push( @{$complex_profile_history}, \$current_profile_position->{$token_data} );

            # Update the current position
            $current_profile_position = ${ $complex_profile_history->[-1] };
         }

      }

      #-------------------------------------------------------------------------------
      #  Incompatible markers holder
      #-------------------------------------------------------------------------------
      else {
      }

   }
   return $complex_profile;
}

#-------------------------------------------------------------------------------
#   Subroutine : run
#
#   Purpose    : Testing subroutine
#-------------------------------------------------------------------------------
sub _run {
   my $example_data = qq(



         Gambardella, Matthew
         XML Developer's Guide
         Computer
         44.95
         2000-10-01
         An in-depth look at creating applications
         with XML.


         Ralls, Kim
         Midnight Rain
         Fantasy
         5.95
         2000-12-16
         A former architect battles corporate zombies,
         an evil sorceress, and her own childhood to become queen
         of the world.


         Corets, Eva
         Maeve Ascendant
         Fantasy
         5.95
         2000-11-17
         After the collapse of a nanotechnology
         society in England, the young survivors lay the
         foundation for a new society.


         Corets, Eva
         Oberon's Legacy
         Fantasy
         5.95
         2001-03-10
         In post-apocalypse England, the mysterious
         agent known only as Oberon helps to create a new life
         for the inhabitants of London. Sequel to Maeve
         Ascendant.


         Corets, Eva
         The Sundered Grail
         Fantasy
         5.95
         2001-09-10
         The two daughters of Maeve, half-sisters,
         battle one another for control of England. Sequel to
         Oberon's Legacy.


         Randall, Cynthia
         Lover Birds
         Romance
         4.95
         2000-09-02
         When Carla meets Paul at an ornithology
         conference, tempers fly as feathers get ruffled.


         Thurman, Paula
         Splish Splash
         Romance
         4.95
         2000-11-02
         A deep sea diver finds true love twenty
         thousand leagues beneath the sea.


         Knorr, Stefan
         Creepy Crawlies
         Horror
         4.95
         2000-12-06
         An anthology of horror stories about roaches,
         centipedes, scorpions  and other insects.


         Kress, Peter
         Paradox Lost
         Science Fiction
         6.95
         2000-11-02
         After an inadvertant trip through a Heisenberg
         Uncertainty Device, James Salway discovers the problems
         of being quantum.


         O'Brien, Tim
         Microsoft .NET: The Programming Bible
         Computer
         36.95
         2000-12-09
         Microsoft's .NET initiative is explored in
         detail in this deep programmer's reference.


         O'Brien, Tim
         MSXML3: A Comprehensive Guide
         Computer
         36.95
         2000-12-01
         The Microsoft MSXML3 parser is covered in
         detail, with attention to XML DOM interfaces, XSLT processing,
         SAX and more.


         Galos, Mike
         Visual Studio 7: A Comprehensive Guide
         Computer
         49.95
         2001-04-16
         Microsoft Visual Studio 7 is explored in depth,
         looking at how Visual Basic, Visual C++, C#, and ASP+ are
         integrated into a comprehensive development
         environment.



);

   my $profile = qq(
   catalog
      lowest
      __NEW_EXTERNAL_VALUE_HOLDER__ = __external_value__1:number
         number = external_dataset:__external_value__1
         book
           __NEW_DATASET__ = 1 2
           id     = dataset:1,name:custom_id
           author = dataset:1 dataset:2
           title  = dataset:1 dataset:2
           genre  = dataset:1
           price  = dataset:1
           publish_date = dataset:1
           description  = dataset:1
           __EXTERNAL_VALUE__ = __external_value__1:number:1
);

   use Data::Dumper;
   print Dumper( parse_using_profile( $example_data, $profile ) );
}

1;

# ABSTRACT: Extracts XML into Perl Datasets based upon a simple text profile markup language

__END__