[CDBI] Class::DBI Has Many Error

Jay Hargreaves jay at rigadon.com
Wed Nov 16 13:49:03 GMT 2005


Hi everyone!

So I have written a small database application using Class::DBI and I 
have a table of Links and a table of LinkCategories. Each Link has a 
LinkCategory and thus each LinkCategory has many Links. I have written 
an admin interface so I can create new Links and LinkCategories as I 
wish. All works as expected on my PC.

However, I have now uploaded the code to my laptop and it does not work 
on there! My laptop is using the latest Class::DBI version available on 
CPAN - my PC is using version 0.95!! If I replace the DBI.pm file on my 
laptop with the one on my PC everything works fine!

So that's the background - here is the error message:

Can't use an undefined value as a HASH reference at 
C:/Perl/site/lib/Class/DBI/Relationship/HasMany.pm line 51. Compilation 
failed in require at c:\httpd\bowdonrufc\cgi-bin/BowdonRUFC/Admin.pm 
line 104.

Anyone got an idea what could be going wrong? Please find my Link.pm, 
LinkCategory.pm and Admin.pm attached if that is of any help!?

Thanks
Jay

-- 
bingo, bango, bosh...
-------------- next part --------------
#
# Admin.pm
# This file may not be reproduced without written permission
# 

package BowdonRUFC::Admin;

use CGI::Builder
qw| CGI::Builder::Session
    CGI::Builder::Auth
    CGI::Builder::Magic
    BowdonRUFC
  |;

use strict;

use Data::Dumper;
use HTML::Entities;

sub OH_init
{ my $s = shift;
  $s->require_group = [ 'ADMIN' ];
}

sub PH_index
{ my $s = shift;

  $s->title = "Welcome To Bowdon R.U.F.C (Admin Interface)";
  $s->content = <<_END_HTML_;
Please select from the following options:<br>
<ul>
  <li><b>Pages</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=Page">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=Page">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=Page">Delete</a> ]
  </li>
  <br>
  <li><b>Links</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=Link">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=Link">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=Link">Delete</a> ]
  </li>
  <li><b>Link Categories</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=LinkCategory">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=LinkCategory">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=LinkCategory">Delete</a> ]
  </li>
  <br>
  <li><b>Contacts</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=Contact">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=Contact">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=Contact">Delete</a> ]
  </li>
  <br>
  <li><b>News</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=News">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=News">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=News">Delete</a> ]
  </li>
  <li><b>News Categories</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=NewsCategory">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=NewsCategory">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=NewsCategory">Delete</a> ]
  </li>
  <br>
  <li><b>Clubs</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=Club">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=Club">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=Club">Delete</a> ]
  </li>
  <li><b>Teams</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=Team">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=Team">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=Team">Delete</a> ]
  </li>
  <br>
  <li><b>Competitions</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=Competition">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=Competition">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=Competition">Delete</a> ]
  </li>
  <li><b>Fixtures</b>
    [ <a href="/cgi-bin/admin.cgi?p=create&m=Fixture">Create</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=modify&m=Fixture">Modify</a> ]
    [ <a href="/cgi-bin/admin.cgi?p=delete&m=Fixture">Delete</a> ]
  </li>
</ul>
_END_HTML_
}


sub SH_create
{ my $s = shift;
  return $s->switch_to('index') unless $s->cgi->param('m');
}

sub PH_create
{ my $s = shift;

  my $m = $s->cgi->param('m');
  $s->title = "Create A $m";

  my $module = "BowdonRUFC::$m";
  unless (eval { require File::Spec->catfile(split /::/, "$module.pm") })
  { $s->errstr = "The specified module ($module) does not exist.";
    $s->debug .= $@;
    return $s->switch_to('error');
  }

  my $columns = eval ( '$' . $module . '::columns' );
  unless ($columns)
  { $s->errstr = "Unable to obtain column list for the specified module ($module).";
    return $s->switch_to('error');
  }

  if (defined $s->cgi->param('do_create') and
      &do_create($s, $m, $module))
  { my $url = $s->cgi->url . "?m=$m&" . $s->cgi_page_param . "=" . $s->cgi->param($s->cgi_page_param);
    return $s->content = "Success! Your $m was successfully created.<p>Click <a href='$url'>here</a> to create another $m";
  } else
  { return $s->content = &show_form($s, $m, $module);
  }
}


sub PH_select
{ my $s = shift;

  my ($m, $module) = @_;

  my @options;
  foreach my $mi (sort $module->retrieve_all)
  { my $id = $mi->id;
    push @options, "<option value='$id'>$mi</option>";
  }

  unless (@options)
  { $s->errstr = "No $m available for selection";
    return $s->switch_to('error');
  }
    
  my $start_form = $s->cgi->start_multipart_form();
  my $end_form = $s->cgi->end_form();

  my $page_param = $s->cgi->hidden($s->cgi_page_param);
  my $m_param = $s->cgi->hidden('m');

  my $primary_column = $module->primary_column;
  $s->content .= <<_END_HTML_;
$start_form
$page_param
$m_param
<div id="form">
  <div class="wrapper" style="padding: 10px;">
    <h3>Select $m</h3>
    <div style="padding-bottom: 30px;">
      <div class="clearfix"><span class="field">$m:</span><select name="select_$primary_column" class="flat" style="float: left;">@options</select><span style="padding-left: 10px;"><b>(required)</b></span></div>
      <div id="submit"><span class="field">Submit:</span><input type="submit" value="Select $m" class="button"></div>
    </div>
  </div>
</div>
_END_HTML_

}


sub SH_modify
{ my $s = shift;
  return $s->switch_to('index') unless $s->cgi->param('m');
}

sub PH_modify
{ my $s = shift;

  my $m = $s->cgi->param('m');
  $s->title = "Modify An Existing $m";

  my $module = "BowdonRUFC::$m";
  unless (eval { require File::Spec->catfile(split /::/, "$module.pm") })
  { $s->errstr = "The specified module ($module) does not exist.";
    $s->debug .= $@;
    return $s->switch_to('error');
  }

  my $select_id = $s->cgi->param('select_' . $module->primary_column);
  unless (defined $select_id)
  { return $s->switch_to('select', $m, $module);
  }

  my $obj = $module->retrieve($select_id);
  unless (defined $obj)
  { $s->errstr = "The selected $m does not exist";
    return $s->switch_to('error');
  }

  if (defined $s->cgi->param('do_modify') and
      &do_modify($s, $m, $module, $obj))
  { my $url = $s->cgi->url . "?m=$m&" . $s->cgi_page_param . "=" . $s->cgi->param($s->cgi_page_param);
    return $s->content = "Success! Your $m was successfully modified.<p>Click <a href='$url'>here</a> to modify another $m";
  } else
  { return $s->content = &show_form($s, $m, $module, $obj);
  }
}


sub PH_delete
{ my $s = shift;

  my $m = $s->cgi->param('m');
  $s->title = "Delete An Existing $m";

  my $module = "BowdonRUFC::$m";
  unless (eval { require File::Spec->catfile(split /::/, "$module.pm") })
  { $s->errstr = "The specified module ($module) does not exist.";
    $s->debug .= $@;
    return $s->switch_to('error');
  }

  my $select_id = $s->cgi->param('select_' . $module->primary_column);
  unless (defined $select_id)
  { return $s->switch_to('select', $m, $module);
  }

  my $obj = $module->retrieve($select_id);
  unless (defined $obj)
  { $s->errstr = "The selected $m does not exist";
    return $s->switch_to('error');
  }

  if (defined $s->cgi->param('do_delete') and
      &do_delete($s, $m, $module, $obj))
  { my $url = $s->cgi->url . "?m=$m&" . $s->cgi_page_param . "=" . $s->cgi->param($s->cgi_page_param);
    return $s->content = "Success! Your $m was successfully deleted.<p>Click <a href='$url'>here</a> to delete another $m";
  } else
  { return $s->content = &show_delete_form($s, $m, $module, $obj);
  }
}


#
# utility functions
#
sub do_create
{ my $s = shift;

  my ($m, $module) = @_;

  my $columns = eval ( '$' . $module . '::columns' );
  unless ($columns)
  { $s->errstr = "Unable to obtain column list for the specified module ($module).";
    return $s->switch_to('error');
  }

  my ($require, $obj);
  foreach my $c (@$columns) # check required values are provided and encode HTML where necessary
  { if ($c->{REQUIRED} and
        $s->cgi->param($c->{NAME}) eq '')
    { push @$require, "Required field $c->{NAME} missing";
      next;
    }

    $obj->{$c->{NAME}} = $c->{NOENCODE} ? $s->cgi->param($c->{NAME})
                                        : &HTML::Entities::encode_entities($s->cgi->param($c->{NAME}));
  }

  if (defined $require)
  { $BowdonRUFC::errstr = &handle_error($s, $require);
    return undef;
  }

  unless (eval { $module->create($obj) })
  { $BowdonRUFC::errstr = &handle_error($s, $@);
    return undef;
  }

  return 1;
}


sub do_modify
{ my $s = shift;

  my ($m, $module, $obj) = @_;

  my $columns = eval ( '$' . $module . '::columns' );
  unless ($columns)
  { $s->errstr = "Unable to obtain column list for the specified module ($module).";
    return $s->switch_to('error');
  }

  my ($require, $new);
  foreach my $c (@$columns) # check required values are provided and encode HTML where necessary
  { if ($c->{REQUIRED} and
        $s->cgi->param($c->{NAME}) eq '')
    { push @$require, "Required field $c->{NAME} missing";
      next;
    }

    $new->{$c->{NAME}} = $c->{NOENCODE} ? $s->cgi->param($c->{NAME})
                                        : &HTML::Entities::encode_entities($s->cgi->param($c->{NAME}));
  }

  if (defined $require)
  { $BowdonRUFC::errstr = &handle_error($s, $require);
    return undef;
  }

  my $command = '$obj->update';
  if ($new->{$module->primary_column} ne $obj->id)
  { $command = '$module->move($obj, $new) and $obj->delete';
  } else
  { foreach my $k (keys %$new)
    { unless (eval { $obj->$k($new->{$k}) })
      { $BowdonRUFC::errstr = &handle_error($s, $@);
        return undef;
      }
    }
  }

  unless (eval($command))
  { $BowdonRUFC::errstr = &handle_error($s, $@);
    return undef;
  }

  return 1;
}


sub do_delete
{ my $s = shift;

  my ($m, $module, $obj) = @_;

  my $columns = eval ( '$' . $module . '::columns' );
  unless ($columns)
  { $s->errstr = "Unable to obtain column list for the specified module ($module).";
    return $s->switch_to('error');
  }

  unless (eval { $obj->delete })
  { $BowdonRUFC::errstr = "An error occurred while deleting your $m";
    return undef;
  }

  return 1;
}


sub show_form
{ my $s = shift;

  my ($m, $module, $obj) = @_;

  my $columns = eval ( '$' . $module . '::columns' );
  unless ($columns)
  { $s->errstr = "Unable to obtain column list for the specified module ($module).";
    return $s->switch_to('error');
  }

  my $start_form = $s->cgi->start_multipart_form();
  my $end_form = $s->cgi->end_form();

  my $page_param = $s->cgi->hidden($s->cgi_page_param);
  my $m_param = $s->cgi->hidden('m');

  my $action = $obj ? 'Modify' : 'Create';
  my $do_param = $s->cgi->hidden('do_' . lc $action, 'true');

  my $primary_column = $module->primary_column;
  my $select_id_param = $s->cgi->hidden("select_$primary_column");

  $s->content .= "<span class='error'>$BowdonRUFC::errstr</span><br><br>" if (defined $BowdonRUFC::errstr);

  $s->content .= <<_END_HTML_;
$start_form
$page_param
$m_param
$do_param
$select_id_param
<div id="form">
  <div class="wrapper" style="padding: 10px;">
    <h3>$m Details</h3>
    <div style="padding-bottom: 30px;">
_END_HTML_

  my $param;
  foreach my $c (@$columns)
  { my $name = $c->{NAME};
    if (defined $s->cgi->param($name))
    { $param->{$name} = $s->cgi->param($name);
    } elsif (defined $obj and $obj->can($name))
    { $param->{$name} = $obj->$name;
    }
  }

  foreach my $c (@$columns)
  { next if ($c->{REQUIRE_GROUP} and
             not $s->auth->require_group($c->{REQUIRE_GROUP})); # some fields are only available to priviliged users
    my $name = $s->functions->format_column($c->{NAME});
    my $value = $param->{$c->{NAME}};
    my $required = '<b>(required)</b>' if $c->{REQUIRED};
    if ($c->{TYPE} eq 'GENERATE') # generate id and pass as hidden field
    { $value = ($value or $s->functions->generate_id);
      $s->content .= <<_END_HTML_;
<input type="hidden" name="$c->{NAME}" value="$value">
_END_HTML_
    } elsif ($c->{TYPE} eq 'DATE') # create date field
    { $value = ($value or $s->functions->parse_date);
      $s->content .= <<_END_HTML_;
<div class="clearfix"><span class="field">$name:</span><input type="TEXT" name="$c->{NAME}" value="$value" class="flat" style="float: left;"><span style="padding-left: 10px;">$required</span></div>
_END_HTML_
    } elsif ($c->{TYPE} eq 'TEXT') # create simple plain text field
    { $s->content .= <<_END_HTML_;
<div class="clearfix"><span class="field">$name:</span><input type="TEXT" name="$c->{NAME}" value="$value" class="flat" style="float: left;"><span style="padding-left: 10px;">$required</span></div>
_END_HTML_
    } elsif ($c->{TYPE} eq 'TEXTAREA') # create simple textarea field
    { $s->content .= <<_END_HTML_;
<div class="clearfix"><span class="field">$name:</span><textarea name="$c->{NAME}" class="flat" style="float: left">$value</textarea><span style="padding-left: 10px;">$required</span></div>
_END_HTML_
    } elsif ($c->{TYPE} eq 'LIST') # load the required module and query values for dropdown list
    { unless (eval { require File::Spec->catfile(split /::/, "$c->{MODULE}.pm") })
      { $s->errstr = "The specified module ($c->{MODULE}) does not exist.";
        $s->debug .= $@;
        return $s->switch_to('error');
      }

      my $id = $obj ? $value->id : $value;
      my $selected = { $id => "selected='selected'" };
      my @options = ( "<option value=''>--- Select An Option ---</option>" );
      foreach my $lc ($c->{MODULE}->retrieve_all)
      { my $id = $lc->id;
        push @options, "<option value='$id' $selected->{$id}>$lc</option>";
      }

      $s->content .= <<_END_HTML_;
<div class="clearfix"><span class="field">$name:</span><select name="$c->{NAME}" class="flat" style="float: left;">@options</select><span style="padding-left: 10px;">$required</span></div>
_END_HTML_
    }
  }

  $s->content .= <<_END_HTML_;
    </div>
    <h3>$action $m</h3>
    <div>
      <div id="submit"><span class="field">Submit:</span><input type="submit" value="$action $m" class="button"></div>
    </div>
  </div>
</div>
$end_form
_END_HTML_
}


sub show_delete_form
{ my $s = shift;

  my ($m, $module, $obj) = @_;

  my $columns = eval ( '$' . $module . '::columns' );
  unless ($columns)
  { $s->errstr = "Unable to obtain column list for the specified module ($module).";
    return $s->switch_to('error');
  }

  my $start_form = $s->cgi->start_multipart_form();
  my $end_form = $s->cgi->end_form();

  my $page_param = $s->cgi->hidden($s->cgi_page_param);
  my $m_param = $s->cgi->hidden('m');

  my $do_param = $s->cgi->hidden('do_delete', 'true');

  my $primary_column = $module->primary_column;
  my $select_id_param = $s->cgi->hidden("select_$primary_column");

  $s->content .= "<span class='error'>$BowdonRUFC::errstr</span><br><br>" if (defined $BowdonRUFC::errstr);

  $s->content .= <<_END_HTML_;
$start_form
$page_param
$m_param
$do_param
$select_id_param
<div id="form">
  <div class="wrapper" style="padding: 10px;">
    <h3>$m Details</h3>
    <div style="padding-bottom: 30px;">
_END_HTML_

  foreach my $c (@$columns)
  { next if ($c->{REQUIRE_GROUP} and
             not $s->auth->require_group($c->{REQUIRE_GROUP})); # some fields are only available to priviliged users
    my $name = $c->{NAME};
    my $title = $s->functions->format_column($name);
    my $value = $obj->$name;
    $s->content .= <<_END_HTML_;
<div class="clearfix"><span class="field">$title:</span><span style="float: left; display: block;">$value</span></div>
_END_HTML_
  }

  $s->content .= <<_END_HTML_;
    </div>
    <h3>Delete $m</h3>
    <div>
      <div id="submit"><span class="field">Submit:</span><input type="submit" value="Delete $m" class="button"></div>
    </div>
  </div>
</div>
$end_form
_END_HTML_
}


#
# error handling
#
sub handle_error
{ my ($s, $e) = @_;
  my $errstr = 'The following error(s) were encountered:';
  if (ref $e eq 'HASH')
  { my $method = $e->{INFO}->{method};
    if ($method eq 'validate_column_values')
    { my $err = $e->{INFO}->{data};
      foreach my $k (keys %$err)
      { $errstr .= "<p>Invalid value provided for $k field</p>";
      }
    } elsif ($e->{INFO}->{err} =~ /duplicate/i)
    { $errstr .= "<p>Duplicate entry - please provide an alternative ID</p>";
    }
  } elsif (ref $e eq 'ARRAY')
  { $errstr .= join('<br>', @$e);
  }
  $s->debug .= '<pre>' . Dumper($e) . '</pre>';
  return $errstr;
}


1;
-------------- next part --------------
#
# BowdonRUFC::Link.pm
#

package BowdonRUFC::Link;
use base BowdonRUFC::DBI;

$BowdonRUFC::Link::columns = [ { NAME => 'link_id',
                                 REQUIRED => 1,
                                 TYPE => 'GENERATE',
                               },
                               { NAME => 'title',
                                 REQUIRED => 1,
                                 TYPE => 'TEXT',
                               },
                               { NAME => 'description',
                                 TYPE => 'TEXTAREA',
                               },
                               { NAME => 'url',
                                 REQUIRED => 1,
                                 TYPE => 'TEXT',
                               },
                               { NAME => 'link_category',
                                 REQUIRED => 1,
                                 TYPE => 'LIST',
                                 MODULE => 'BowdonRUFC::LinkCategory',
                               } ];

__PACKAGE__->table("Links");
__PACKAGE__->columns(All => map { $_->{NAME} } @$BowdonRUFC::Link::columns);
__PACKAGE__->columns(Stringify => qw/title/);

__PACKAGE__->constrain_column(url => UntaintPatched => "url");

__PACKAGE__->has_a(link_category => 'BowdonRUFC::LinkCategory' );

1;
-------------- next part --------------
#
# BowdonRUFC::LinkCategory.pm
#

package BowdonRUFC::LinkCategory;
use base BowdonRUFC::DBI;

$BowdonRUFC::LinkCategory::columns = [ { NAME => 'link_category_id',
                                         REQUIRED => 1,
                                         TYPE => 'GENERATE',
                                       },
                                       { NAME => 'title',
                                         REQUIRED => 1,
                                         TYPE => 'TEXT',
                                       },
                                       { NAME => 'description',
                                         TYPE => 'TEXTAREA',
                                       } ];

__PACKAGE__->table("LinkCategories");
__PACKAGE__->columns(All => map { $_->{NAME} } @$BowdonRUFC::LinkCategory::columns);
__PACKAGE__->columns(Stringify => qw/title/);
__PACKAGE__->has_many(links => 'BowdonRUFC::Link');

1;


More information about the ClassDBI mailing list