view release on metacpan or  search on metacpan

lib/DBD/TreeData.pm  view on Meta::CPAN

               $columns->{$col_key} = $grp_table_name;
            }

            # Add new row
            $group_id[$i] = ++($ids->{table}{$grp_table_name}) unless ($group_id[$i]);  # only increment once (per group type)
            if ($is_id) {  # ID column: $item = ID, and this goes in a group table (id/data table already processed)
               print_debug($depth+1, "ARRAY ===> $grp_table_name => [ $group_id[$i], $item ] (new ID row for an group table)");
               push(@{$t->{data}}, [ $group_id[$i], $item ]);
            }
            else {        # data column: $item = data, and we process both tables
               my $itbl_name = to_PL($strip);  # like blahs
               $itbl_name =~ s/ /_/g;
               my $data_col = $strip;
               $data_col =~ s/ /_/g;

               # Create new id table (if it doesn't already exist)
               unless ($tables->{$itbl_name}) {
                  print_debug($depth+1, "ARRAY ===> Creating new ID table '$itbl_name'");

                  $tables->{$itbl_name} = {
                     columns => [ $icol, $data_col ],
                     data    => [],
                  };
               }
               my $n = $tables->{$itbl_name};
               my $col_key = join('|', @{$n->{columns}});
               $columns->{$col_key} = $itbl_name;
               $types->{$icol} = 'ID';

               $max_id[$i-1] = $icol;
               print_debug($depth+1, "ARRAY ===> max_id = ".int($i-1)."/$icol");
               ### FIXME: Assuming that table doesn't exist with the same columns ###

               # First, check serial tree with single value
               my $stree = Data::Dumper->new([$item], ['*'.$icol])->Reset->Indent(0)->Dump;
               if ($ids->{trees}{$stree} && $depth) {
                  # Add new group row (with proper col_id)
                  my $id = (split(/\|/, $ids->{trees}{$stree}))[1];
                  print_debug($depth+1, "ARRAY ===> $grp_table_name => [ $group_id[$i], $id ] (serial tree found)");
                  push(@{$t->{data}}, [ $group_id[$i], $id ] );

                  # (no need to add into main table; already exists)
               }
               else {
                  # Add new group row (with proper col_id)
                  my $id = ++($ids->{table}{$itbl_name});
                  if ($depth) {
                     print_debug($depth+1, "ARRAY ===> $grp_table_name => [ $group_id[$i], $id ] (new group row)");
                     push(@{$t->{data}}, [ $group_id[$i], $id ]);
                  }

                  # Add new id row
                  $ids->{trees}{$stree} = $icol.'_id|'.$id;
                  print_debug($depth+2, "ARRAY ===> $itbl_name => [ $id, $item ] (new ID/data row)");
                  push(@{$n->{data}}, [ $id, $item ]);
               }
            }
         }

         # Pass back an ID
         my ($gid_col, $gid) = (pop(@max_id) || $col, pop(@group_id));  # undef @max_id might happen with an empty array

         print_debug($depth+1, "ARRAY <=== $gid_col => $gid");
         $serialized_tree =~ s/^(\W{1,2})XXXX/$1$gid_col/;
         $ids->{trees}{$serialized_tree} = $gid_col.'|'.$gid;
         $types->{$gid_col} = 'ID';
         return $gid_col => $gid;
      }
      # An actual scalar; return back the proper column name and data
      when ('' || undef) {
         return type_detect($col, $tree);
      }
      # De-reference
      when (/SCALAR|VSTRING/) {
         return type_detect($col, $$tree);
      }
      # Warn and de-reference
      when (/Regexp|LVALUE/i) {
         $drh->set_err(0, "Found a ".(reftype $tree)."; just going to treat this like a SCALAR...");
         return type_detect($col, $$tree);
      }
      # Warn and de-reference (for further examination)
      when ('REF') {
         $drh->set_err(0, "Found a REF; going to dive in the rabbit hole...");
         return $drh->tree_process_hash_tree($col => $$tree, $depth + 1);
      }
      # Warn and de-reference (for further examination)
      when ('GLOB') {
         foreach my $t (qw(Regexp VSTRING IO FORMAT LVALUE GLOB REF CODE HASH ARRAY SCALAR)) {  # scalar last, since a ref is still a scalar
            if (defined *$$tree{$t}) {
               $drh->set_err(0, "Found a GLOB (which turn out to be a $t); going to dive in the rabbit hole...");
               return $drh->tree_process_hash_tree($col => *$$tree{$t}, $depth + 1);
            }
         }
         $drh->set_err(0, "Found a GLOB, but it didn't point to anything...");
         return $col => undef;
      }
      # Warn and throw away
      when ('CODE') {
         ### TODO: Warn immediately, eval block with timer to use as output, then continue ###
         ### Definitely need a switch, though ###
         $drh->set_err(0, "Found a CODE block; not going to even touch this one...");
         return $col => undef;
      }
      default {
         $drh->set_err(0, "Found a ".(reftype $tree)."; WTF is this?  Can't use this at all...");
         return $col => undef;
      }
   }

   die "WTF?!  Perl broke my given/when!  Alert the Pumpking!!!";
}

# Find items in @B that are in @A
sub foundin (\@\@) {
   my ($A, $B) = @_;
   return grep { my $i = $_; any { $i eq $_ } @$A; } @$B;
}

# Find items in @B that are not in @A
sub notin (\@\@) {
   my ($A, $B) = @_;
   return grep { my $i = $_; none { $i eq $_ } @$A; } @$B;
}

sub col2word ($) {
   my $word = $_[0];