view release on metacpan or  search on metacpan

lib/DBIx/QuickORM.pm  view on Meta::CPAN

        return \@caller;
    }

    return;
}

sub unimport {
    my $class = shift;
    my $caller = caller;

    $class->unimport_from($caller);
}

sub unimport_from {
    my $class = shift;
    my ($caller) = @_;

    my $stash = do { no strict 'refs'; \%{"$caller\::"} };

    # Remove exactly the names that were installed for this caller, which may
    # differ from the default export names when a 'rename' was used at import.
    my @items = $INSTALLED_NAMES{$caller} ? keys %{$INSTALLED_NAMES{$caller}} : (@EXPORT, 'builder');

    for my $item (@items) {
        next unless exists $stash->{$item} && defined(*{$stash->{$item}}{CODE});

        my $glob = delete $stash->{$item};

        {
            no strict 'refs';
            no warnings 'redefine';

            for my $type (qw/SCALAR HASH ARRAY FORMAT IO/) {
                next unless defined(*{$glob}{$type});
                *{"$caller\::$item"} = *{$glob}{$type};
            }
        }
    }
}

sub new {
    my $class = shift;
    my %params = @_;

    croak "'package' is a required attribute" unless $params{+PACKAGE};

    $params{+STACK}   //= [{base => 1, plugins => [], building => '', build => 'Should not access this', meta => 'Should not access this'}];

    $params{+ORMS}    //= {};
    $params{+DBS}     //= {};
    $params{+SCHEMAS} //= {};
    $params{+SERVERS} //= {};

    return bless(\%params, $class);
}

sub quick {
    my $class = shift;
    my %params = @_;

    my $creds   = delete $params{credentials};
    my $connect = delete $params{connect};
    my $types   = delete $params{auto_types} // [];
    my $dialect = delete $params{dialect};
    my $autorow = delete $params{autorow};    # 0 = off (default), 1 = generated namespace, or a class-name prefix
    my $row_manager = delete $params{row_manager} // 'DBIx::QuickORM::RowManager::Cached';
    my $no_volatile = delete $params{no_volatile};    # 1 = every table, or an arrayref of table names

    croak "Unknown parameter(s) to quick(): " . join(', ', sort keys %params) if keys %params;

    croak "'no_volatile' must be a true scalar (every table) or an arrayref of table names"
        if defined($no_volatile) && ref($no_volatile) && ref($no_volatile) ne 'ARRAY';

    croak "quick() requires exactly one of 'credentials' or 'connect'"
        unless (($creds ? 1 : 0) + ($connect ? 1 : 0)) == 1;

    croak "'credentials' must be a hashref" if $creds   && ref($creds) ne 'HASH';
    croak "'connect' must be a coderef"     if $connect && ref($connect) ne 'CODE';
    croak "'auto_types' must be an arrayref" if ref($types) ne 'ARRAY';

    my ($dialect_class, $db_name) = $class->_quick_detect($dialect, $creds, $connect);

    require DBIx::QuickORM::DB;
    my %db_params = (dialect => $dialect_class, db_name => $db_name);
    if ($creds) {
        if (my @bad = grep { $_ !~ /^(?:dsn|user|pass|attrs|dbd)$/ } keys %$creds) {
            croak "Unknown credentials key(s): " . join(', ' => sort @bad) . " (valid: dsn, user, pass, attrs, dbd)";
        }
        $db_params{dsn}        = $creds->{dsn}   if defined $creds->{dsn};
        $db_params{user}       = $creds->{user}  if defined $creds->{user};
        $db_params{pass}       = $creds->{pass}  if defined $creds->{pass};
        $db_params{attributes} = $creds->{attrs} if defined $creds->{attrs};
        $db_params{dbi_driver} = $creds->{dbd}   if defined $creds->{dbd};
    }
    else {
        $db_params{connect} = $connect;
    }
    my $db = DBIx::QuickORM::DB->new(%db_params);

    my (%type_map, %affinities);
    for my $type (@$types) {
        my $type_class = load_class($type, 'DBIx::QuickORM::Type') or croak "Could not load type '$type': $@";
        $type_class->qorm_register_type(\%type_map, \%affinities);
    }

    my %autofill_args = (types => \%type_map, affinities => \%affinities, hooks => {}, skip => {});
    $autofill_args{no_volatile} = $no_volatile if defined $no_volatile;
    if ($autorow) {
        my $base = "$autorow" eq '1' ? $class->_generate_autorow_base : $autorow;
        $autofill_args{hooks}{post_table} = [$class->_autorow_hook($base, undef, (caller)[1])];
    }
    my $autofill = DBIx::QuickORM::Schema::Autofill->new(%autofill_args);

    load_class($row_manager) or croak "Could not load row_manager '$row_manager': $@"
        unless ref $row_manager;

    require DBIx::QuickORM::ORM;
    my $orm = DBIx::QuickORM::ORM->new(db => $db, autofill => $autofill, row_manager => $row_manager);

    return $orm->connection;
}

sub _generate_autorow_base {
    my $class = shift;
    state $counter = 0;
    $counter++;
    return "DBIx::QuickORM::Row::Auto${counter}";
}

sub _autorow_hook {
    my $class = shift;
    my ($base, $name_to_class, $caller_file) = @_;

    $name_to_class //= sub {
        my $name = shift;
        my @parts = split /_/, $name;
        return join '' => map { ucfirst(lc($_)) } @parts;
    };

    local $@;
    my $parent = load_class($base);
    unless ($parent) {
        # Only fall back to the stock Row class when the base genuinely does not
        # exist on disk; a base that exists but fails to compile must surface
        # its error rather than silently losing the user's methods.
        my $err = $@;
        die $err unless $err =~ m/Can't locate .+ in \@INC/;
        $parent = load_class('DBIx::QuickORM::Row') or die $@;
    }

    return sub {
        my %params = @_;
        my $autofill = $params{autofill};
        my $table = $params{table};

        my $postfix = $name_to_class->($table->{name});
        my $package = "$base\::$postfix";

        local $@;
        unless (load_class($package)) {
            # A missing per-table row class is expected (autofill generates it);
            # a compile error in an existing one must not be swallowed.
            my $err = $@;
            die $err unless $err =~ m/Can't locate .+ in \@INC/;
        }

        my $isa = do { no strict 'refs'; \@{"$package\::ISA"} };
        push @$isa => $parent unless @$isa;

        my $file = $package;
        $file =~ s{::}{/}g;
        $file .= ".pm";
        $INC{$file} ||= $caller_file;

        $table->{row_class} = $package;
        $table->{row_class_autofill} = $autofill;
    };
}

sub _quick_detect {
    my $class = shift;
    my ($explicit, $creds, $connect) = @_;

    my ($driver, $name_source);
    if ($creds) {
        $name_source = $creds->{dsn};
        if (my $dbd = $creds->{dbd}) {
            ($driver = $dbd) =~ s/^DBD:://;
        }
        elsif (my $dsn = $creds->{dsn}) {
            ($driver) = $dsn =~ m/^dbi:([^:]+):/i
                or croak "Could not parse a driver from the dsn '$dsn'";
        }
        elsif (!$explicit) {
            croak "quick() credentials need a 'dsn' or 'dbd' to detect the dialect, or pass an explicit 'dialect'";
        }
    }
    else {
        my $dbh = $connect->() or croak "The 'connect' callback did not return a database handle";
        $driver      = $dbh->{Driver}->{Name};
        $name_source = $dbh->{Name};
        $dbh->disconnect;
    }

    my $dialect;
    if ($explicit) {
        $dialect = load_class($explicit, 'DBIx::QuickORM::Dialect') // croak "Could not load dialect '$explicit': $@";
    }
    else {
        my $dialect_name = $class->_dialect_for_driver($driver)
            or croak "Could not determine a dialect for driver '$driver'; pass an explicit 'dialect'";
        $dialect = load_class($dialect_name, 'DBIx::QuickORM::Dialect') // croak "Could not load dialect '$dialect_name': $@";
    }

    my $db_name = $class->_quick_dbname($name_source) // 'quickorm';

    return ($dialect, $db_name);
}

sub _quick_dbname {
    my $class = shift;
    my ($source) = @_;

    return undef unless defined $source;
    return $1 if $source =~ m/(?:dbname|database|db)=([^;]+)/i;
    return undef;
}

sub _dialect_for_driver {
    my $class = shift;
    my ($driver) = @_;

    return undef unless defined $driver;
    return 'SQLite'     if $driver =~ m/^SQLite$/i;
    return 'PostgreSQL' if $driver =~ m/^Pg/i;
    return 'MySQL'      if $driver =~ m/^(?:mysql|MariaDB)$/i;
    return 'DuckDB'     if $driver =~ m/^DuckDB$/i;
    return undef;
}

sub import_into {
    my $self = shift;
    my ($caller, $name, @extra) = @_;

    croak "Not enough arguments, caller is required" unless $caller;
    croak "Too many arguments" if @extra;

    $name //= 'qorm';

    no strict 'refs';
    *{"${caller}\::${name}"} = sub {
        return $self unless @_;

        my ($type, $name, @extra) = @_;

lib/DBIx/QuickORM.pm  view on Meta::CPAN

=item C<hostname $HOSTNAME>

Provide a hostname or IP address for database connections

    db mydb => sub {
        host 'mydb.mydomain.com';
    };

Can be nested under C<db> or C<server>.

=item C<port $PORT>

Provide a port number for database connection.

    db mydb => sub {
        port 1234;
    };

Can be nested under C<db> or C<server>.

=item C<socket $SOCKET_PATH>

Provide a socket instead of a host+port

    db mydb => sub {
        socket '/path/to/db.socket';
    };

Can be nested under C<db> or C<server>.

=item C<user $USERNAME>

=item C<username $USERNAME>

provide a database username

    db mydb => sub {
        user 'bob';
    };

Can be nested under C<db> or C<server>.

=item C<pass $PASSWORD>

=item C<password $PASSWORD>

provide a database password

    db mydb => sub {
        pass 'hunter2'; # Do not store any real passwords in plaintext in code!!!!
    };

Can be nested under C<db> or C<server>.

=item C<creds sub { return \%CREDS }>

Allows you to provide a coderef that will return a hashref with all the
necessary database connection fields.

This is mainly useful if you credentials are in an encrypted YAML or JSON file
and you have a method to decrypt and read it returning it as a hash.

    db mydb => sub {
        creds sub { ... };
    };

Can be nested under C<db> or C<server>.

=item C<connect sub { ... }>

=item C<connect \&connect>

Instead of providing all the other fields, you may specify a coderef that
returns a L<DBI> connection.

B<IMPORTANT:> This function must always return a new L<DBI> connection it
B<MUST NOT> cache it!

    sub mydb => sub {
        connect sub { ... };
    };

Can be nested under C<db> or C<server>.

=item C<dsn $DSN>

Specify the DSN used to connect to the database. If not provided then an
attempt will be made to construct a DSN from other parameters, if they are
available.

    db mydb => sub {
        dsn "dbi:Pg:dbname=foo";
    };

Can be nested under C<db> or C<server>.

=item C<< server $NAME => sub { ... } >>

Used to define a server with multiple databases. This is a way to avoid
re-specifying credentials for each database you connect to.

You can use C<< db('server_name.db_name') >> to fetch the database.

Basically this allows you to specify any database fields once in the server, then
define any number of databases that inherit them.

Example:

    server pg => sub {
        host 'pg.myapp.com';
        user $USER;
        pass $PASS;
        attributes { work_well => 1 }

        db 'myapp';       # Points at the 'myapp' database on this db server
        db 'otherapp';    # Points at the 'otherapp' database on this db server

        # You can also override any if a special db needs slight modifications.
        db special => sub {
            attributes { work_well => 0, work_wrong => 1 };
        };
    };

    orm myapp => sub {
        db 'pg.myapp';
        ...;
    };

    orm otherapp => sub {
        db 'pg.otherapp';
        ...;
    };

Used at the top level. Can contain C<db> plus the same connection settings a
C<db> can contain (C<driver>, C<dialect>, C<connect>, C<attributes>, C<creds>,
C<dsn>, C<host>, C<port>, C<socket>, C<user>, C<pass>).

=item C<< schema $NAME => sub { ... } >>

=item C<< $schema = schema($NAME) >>

=item C<< $schema = schema($NAME => sub { ... }) >>

Used to either fetch or define a schema.

When called with only 1 argument it will fetch the schema with the given name.

When used inside an ORM builder it will set the schema for the ORM (all ORMs
have exactly one schema).

When called with 2 arguments it will define the schema using the coderef as a
builder.

When called in a non-void context it will return the compiled schema, otherwise
it adds it to the ORM class.

    # Define the 'foo' schema:
    schema foo => sub {
        table a => sub { ... };
        table b => sub { ... };