view release on metacpan or  search on metacpan

lib/DBIx/PgLink/Accessor/BaseAccessor.pm  view on Meta::CPAN

# utility

sub perl_quote {
  my ($self, $str) = @_;
  $str =~ s/\\/\\\\/g;
  $str =~ s/'/\\'/g;
  return "'$str'";
};

sub abstract { confess "Abstract method called" }


# identifier quoting shortcuts

sub QRI { # quote remote identifier
  my $self = shift;
  return $self->adapter->quote_identifier(@_); 
}

sub QRIS { # quote remote identifier with schema (and catalog)
  my ($self, $name) = @_;
  if ($self->adapter->include_catalog_to_qualified_name) {
    return $self->adapter->quote_identifier($self->remote_catalog, $self->remote_schema, $name);
  } elsif ($self->adapter->include_schema_to_qualified_name) {
    return $self->adapter->quote_identifier($self->remote_schema, $name);
  } else {
    return $self->adapter->quote_identifier($name);
  }
}

sub QLI { # quote local identifier
  my $self = shift;
  return pg_dbh->quote_identifier(@_); 
}

sub QLIS { # quote local identifier with schema 
  my ($self, $name) = @_;
  return pg_dbh->quote_identifier($self->local_schema, $name);
}


# NAMES

has 'remote_object_type'  => (is=>'ro', isa=>'Str', required=>1);
has 'remote_catalog'      => (is=>'ro', isa=>'StrNull', required=>0);
has 'remote_schema'       => (is=>'ro', isa=>'StrNull', required=>0);
has 'remote_object'       => (is=>'ro', isa=>'Str', required=>1);

has 'local_schema'        => (is=>'ro', isa=>'Str', required=>1);
has 'local_object'        => (is=>'ro', isa=>'Str', required=>1);

# full qualified, double-quoted name
has 'local_schema_quoted'   => (is=>'rw', isa=>'Str', lazy=>1, default=>sub{ $_[0]->QLI($_[0]->local_schema) } );
has 'local_object_quoted'   => (is=>'rw', isa=>'Str', lazy=>1, default=>sub{ $_[0]->QLIS($_[0]->local_object) } );
has 'remote_object_quoted'  => (is=>'rw', isa=>'Str', lazy=>1, default=>sub{ $_[0]->QRIS($_[0]->remote_object) } );


has 'old_accessor' => (is=>'rw', isa=>'DBIx::PgLink::Accessor::BaseAccessor');

has 'skip_on_errors' => (is=>'ro', isa=>'ArrayRef', auto_deref=>1,
  default=>sub{ ['cannot drop .* because other objects depend on it']} 
);

# -------------------------------------------------------


method build => named (
  use_local_metadata  => { isa => 'Bool', default=> 0 },
) => sub {
  my ($self, $p) = @_;

  $self->building_mode(1);

  trace_msg('INFO', "Building accessor for " . $self->remote_object_type . " " . $self->remote_object_quoted)
    if trace_level >= 1;

  my $savepoint_name = 'build_' . $self->object_id; # unique
  pg_dbh->do("SAVEPOINT $savepoint_name");
  eval {

    $self->load_old_accessor;

    unless ($p->{use_local_metadata}) {
      $self->create_metadata;
      
      $self->delete_metadata_by_id( $self->old_accessor->object_id ) if $self->old_accessor;

      $self->save_metadata;
    }

    $self->create_local_schema;

    $self->old_accessor->drop_local_objects if $self->old_accessor;

    $self->create_local_objects;

  };
  if ($@) {
    my $err = $@;
    for my $skip ($self->skip_on_errors) {
      if ($err =~ /$skip/) {
        # do not raise exception, issue warning and skip this object
        pg_dbh->do("ROLLBACK TO SAVEPOINT $savepoint_name");
        trace_msg('WARNING', "Cannot create accessor for " 
          . $self->remote_object_type . " " . $self->remote_object_quoted
         . ". Error: " . $err);
        return 0;
      }
    }
    die $@;
  }
  pg_dbh->do("RELEASE SAVEPOINT $savepoint_name");

  return 1;
};


sub create_metadata { abstract() }
sub drop_local_objects { abstract() }
sub create_local_objects { abstract() }