view release on metacpan or  search on metacpan

lib/DBIx/Migration/Directories.pm  view on Meta::CPAN

    my($migration_map, $versions) =
        $self->migration_map(@$self{'dir', 'common_dir'});
        
    $self->{migrations} = $migration_map;
    $self->{versions} = $versions;
    
    return $self->{migrations};
}

sub migration_path {
    my($self, $from_ver, $to_ver) = @_;
    my @rv = ();
    $from_ver = $self->version_as_number($from_ver);
    $to_ver = $self->version_as_number($to_ver);
    
    if($from_ver == $to_ver) {
        return @rv;
    }
    
    if(!$self->{migrations}{$from_ver}) {
        croak qq{No migrations available for $from_ver};
    }
    
    if($self->{migrations}{$from_ver}{$to_ver}) {
        return($self->{migrations}{$from_ver}{$to_ver});
    }
    
    my $direction = $self->direction($from_ver, $to_ver);
    
    my @candidates = sort { ($b * $direction) <=> ($a * $direction) } grep(
        $self->direction($from_ver, $_) == $direction,
        keys(%{$self->{migrations}{$from_ver}})
    );
    
    # never allow a schema to be dropped and re-created to switch versions
    # as this could destroy data!
    if($to_ver) {
        @candidates = grep($_, @candidates);
    }
        
    if(!@candidates) {
        croak qq{No migrations in direction $direction for $from_ver};
    }
    
    while((!@rv) && (@candidates)) {
        my $candidate = shift @candidates;
        my @path = eval { $self->migration_path($candidate, $to_ver) };
        
        if(@path) {
            @rv = ($self->{migrations}{$from_ver}{$candidate}, @path);
        }
    }
    
    if(!@rv) {
        croak qq{Failed to find a migration path from $from_ver to $to_ver};
    }
    
    return(@rv);
}

sub ls_overlay {
    my($self, $dir, $overlay) = @_;
    my %dir = map { $_->basename => $_ } $self->ls($dir);
    $dir{$_->basename} = $_
        foreach grep { !$dir{$_->basename} } $self->ls($overlay);
    return map { $dir{$_} } sort keys %dir;
}

sub ls {
    my($self, $dn) = @_;
    map { File::Basename::Object->new($_) }
        sort map { "$dn/$_" } grep { !/^\./ && !/\~$/ && -f "$dn/$_" } readdir do {
            my $d; opendir($d, $dn) ? $d : croak qq{opendir("$dn") failed: $!};
        };
}

sub read_sql_file {
    my($self, $file) = @_;
    \"$file", grep { m{\S}s } split(m{;\s*\n}s, $self->read_file($file));
}

sub dir_flat_sql {
    my($self, $dir) = @_;
    map { $self->read_sql_file($_) } $self->ls($dir);
}

sub dir_overlay_sql {
    my($self, $dir, $overlay) = @_;
    map { $self->read_sql_file($_) } $self->ls_overlay($dir, $overlay);
}

sub dir_sql {
    my($self, $dir) = @_;
    my $d1 = "$self->{dir}/$dir";
    if($self->{common_dir} && $dir ne $self->{common_dir}) {
        my $d2 = "$self->{common_dir}/$dir";
        if(-d $d1 && -d $d2) {
            $self->dir_overlay_sql($d1, $d2);
        } elsif (-d $d2) {
            $self->dir_flat_sql($d2);
        } else {
            $self->dir_flat_sql($d1);
        }
    } else {
        $self->dir_flat_sql($d1);
    }
}

sub version_update_sql {
    my($self, $from, $to) = @_;
    my $dbh = $self->{dbh};
    my $ver =
        exists($self->{_current_version}) ? '_current_version' :
        'current_version';
        
    my $ins = defined($self->{$ver}) ? 0 : 1;
    my @sql;
    
    if($ins) {
        push(@sql,
            $self->db->sql_insert_migration_schema_version($self->{schema}, $to)
        );
    } else {
        push(@sql,
            $self->db->sql_update_migration_schema_version($self->{schema}, $to)
        );
    }
    
    push(@sql,
        $self->db->sql_insert_migration_schema_log($self->{schema}, $from, $to)
    );
        
    return @sql;
}

sub dir_migration_sql {
    my($self, $dir) = @_;
    my($from, $to) = ($self->versions($dir));
    
    my @sql = ($self->dir_sql($dir));
    
    if(
        !$self->{schema} ||
        $self->{schema} ne $schema ||
        $self->version_as_number($to)
    ) {
        push(@sql, $self->version_update_sql($from, $to));
        $self->{_current_version} = $self->version_as_number($to);
    }
            
    return @sql;
}

sub migration_path_sql {
    my($self, @path) = @_;
    my @sql;
    
    $self->{_current_version} = $self->{current_version};