Sponsoring The Perl Toolchain Summit 2025: Help make this important event another success Learn more

RIBASUSHI / DBIx-Class-0.082810 / lib / DBIx / Class / CDBICompat / ColumnsAsHash.pm 

            

              
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

              
package
    DBIx::Class::CDBICompat::ColumnsAsHash;
use strict;
use warnings;
=head1 NAME
DBIx::Class::CDBICompat::ColumnsAsHash - Emulates the behavior of Class::DBI where the object can be accessed as a hash of columns.
=head1 SYNOPSIS
See DBIx::Class::CDBICompat for usage directions.
=head1 DESCRIPTION
Emulates the I<undocumented> behavior of Class::DBI where the object can be accessed as a hash of columns.  This is often used as a performance hack.
    my $column = $result->{column};
=head2 Differences from Class::DBI
If C<DBIC_CDBICOMPAT_HASH_WARN> is true it will warn when a column is accessed as a hash key.
=cut
sub new {
    my $class = shift;
    my $new = $class->next::method(@_);
    $new->_make_columns_as_hash;
    return $new;
}
sub inflate_result {
    my $class = shift;
    my $new = $class->next::method(@_);
    $new->_make_columns_as_hash;
    return $new;
}
sub _make_columns_as_hash {
    my $self = shift;
    for my $col ($self->columns) {
        if( exists $self->{$col} ) {
            warn "Skipping mapping $col to a hash key because it exists";
        }
        tie $self->{$col}, 'DBIx::Class::CDBICompat::Tied::ColumnValue',
            $self, $col;
    }
}
package DBIx::Class::CDBICompat::Tied::ColumnValue;
use Carp;
use Scalar::Util qw(weaken isweak);
sub TIESCALAR {
    my($class, $obj, $col) = @_;
    my $self = [$obj, $col];
    weaken $self->[0];
    return bless $self, $_[0];
}
sub FETCH {
    my $self = shift;
    my($obj, $col) = @$self;
    my $class = ref $obj;
    my $id    = $obj->id;
    carp "Column '$col' of '$class/$id' was fetched as a hash"
        if $ENV{DBIC_CDBICOMPAT_HASH_WARN};
    return $obj->column_info($col)->{_inflate_info}
                ? $obj->get_inflated_column($col)
                : $obj->get_column($col);
}
sub STORE {
    my $self = shift;
    my($obj, $col) = @$self;
    my $class = ref $obj;
    my $id    = $obj->id;
    carp "Column '$col' of '$class/$id' was stored as a hash"
        if $ENV{DBIC_CDBICOMPAT_HASH_WARN};
    return $obj->column_info($col)->{_inflate_info}
                ? $obj->set_inflated_column($col => shift)
                : $obj->set_column($col => shift);
}
=head1 FURTHER QUESTIONS?
Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
=head1 COPYRIGHT AND LICENSE
This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
redistribute it and/or modify it under the same terms as the
L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut
1;