/usr/share/perl5/DBIx/Class/CDBICompat/ColumnGroups.pm is in libdbix-class-perl 0.08196-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | package # hide from PAUSE
DBIx::Class::CDBICompat::ColumnGroups;
use strict;
use warnings;
use Sub::Name ();
use Storable 'dclone';
use List::Util ();
use base qw/DBIx::Class::Row/;
__PACKAGE__->mk_classdata('_column_groups' => { });
sub columns {
my $proto = shift;
my $class = ref $proto || $proto;
my $group = shift || "All";
$class->_init_result_source_instance();
$class->_add_column_group($group => @_) if @_;
return $class->all_columns if $group eq "All";
return $class->primary_column if $group eq "Primary";
my $grp = $class->_column_groups->{$group};
my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp);
return @grp_cols;
}
sub _add_column_group {
my ($class, $group, @cols) = @_;
$class->mk_group_accessors(column => @cols);
$class->add_columns(@cols);
$class->_register_column_group($group => @cols);
}
sub add_columns {
my ($class, @cols) = @_;
$class->result_source_instance->add_columns(@cols);
}
sub _register_column_group {
my ($class, $group, @cols) = @_;
# Must do a complete deep copy else column groups
# might accidentally be shared.
my $groups = dclone $class->_column_groups;
if ($group eq 'Primary') {
$class->set_primary_key(@cols);
delete $groups->{'Essential'}{$_} for @cols;
my $first = List::Util::max(values %{$groups->{'Essential'}});
$groups->{'Essential'}{$_} = ++$first for reverse @cols;
}
if ($group eq 'All') {
unless (exists $class->_column_groups->{'Primary'}) {
$groups->{'Primary'}{$cols[0]} = 1;
$class->set_primary_key($cols[0]);
}
unless (exists $class->_column_groups->{'Essential'}) {
$groups->{'Essential'}{$cols[0]} = 1;
}
}
delete $groups->{$group}{$_} for @cols;
my $first = List::Util::max(values %{$groups->{$group}});
$groups->{$group}{$_} = ++$first for reverse @cols;
$class->_column_groups($groups);
}
# CDBI will never overwrite an accessor, but it only uses one
# accessor for all column types. DBIC uses many different
# accessor types so, for example, if you declare a column()
# and then a has_a() for that same column it must overwrite.
#
# To make this work CDBICompat has decide if an accessor
# method was put there by itself and only then overwrite.
{
my %our_accessors;
sub _has_custom_accessor {
my($class, $name) = @_;
no strict 'refs';
my $existing_accessor = *{$class .'::'. $name}{CODE};
return $existing_accessor && !$our_accessors{$existing_accessor};
}
sub _deploy_accessor {
my($class, $name, $accessor) = @_;
return if $class->_has_custom_accessor($name);
{
no strict 'refs';
no warnings 'redefine';
my $fullname = join '::', $class, $name;
*$fullname = Sub::Name::subname $fullname, $accessor;
}
$our_accessors{$accessor}++;
return 1;
}
}
sub _mk_group_accessors {
my ($class, $type, $group, @fields) = @_;
# So we don't have to do lots of lookups inside the loop.
my $maker = $class->can($type) unless ref $type;
# warn "$class $type $group\n";
foreach my $field (@fields) {
if( $field eq 'DESTROY' ) {
carp("Having a data accessor named DESTROY in ".
"'$class' is unwise.");
}
my $name = $field;
($name, $field) = @$field if ref $field;
my $accessor = $class->$maker($group, $field);
my $alias = "_${name}_accessor";
# warn " $field $alias\n";
{
no strict 'refs';
$class->_deploy_accessor($name, $accessor);
$class->_deploy_accessor($alias, $accessor);
}
}
}
sub all_columns { return shift->result_source_instance->columns; }
sub primary_column {
my ($class) = @_;
my @pri = $class->primary_columns;
return wantarray ? @pri : $pri[0];
}
sub _essential {
return shift->columns("Essential");
}
sub find_column {
my ($class, $col) = @_;
return $col if $class->has_column($col);
}
sub __grouper {
my ($class) = @_;
my $grouper = { class => $class };
return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
}
sub _find_columns {
my ($class, @col) = @_;
return map { $class->find_column($_) } @col;
}
package # hide from PAUSE (should be harmless, no POD no Version)
DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
sub groups_for {
my ($self, @cols) = @_;
my %groups;
foreach my $col (@cols) {
foreach my $group (keys %{$self->{class}->_column_groups}) {
$groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};
}
}
return keys %groups;
}
1;
|