Revision 8d24868f
Von Sven Schöling vor fast 9 Jahren hinzugefügt
| SL/Helper/UserPreferences.pm | ||
|---|---|---|
|
package SL::Helper::UserPreferences;
|
||
|
|
||
|
use strict;
|
||
|
use parent qw(Rose::Object);
|
||
|
use version;
|
||
|
|
||
|
use SL::DBUtils qw(selectall_hashref_query selectfirst_hashref_query do_query selectall_ids);
|
||
|
|
||
|
use Rose::Object::MakeMethods::Generic (
|
||
|
'scalar --get_set_init' => [ qw(login namespace upgrade_callbacks current_version auto_store_back) ],
|
||
|
);
|
||
|
|
||
|
sub store {
|
||
|
my ($self, $key, $value) = @_;
|
||
|
|
||
|
my $tuple = $self->get_tuple($key);
|
||
|
|
||
|
if ($tuple) {
|
||
|
$tuple->{value} = $value;
|
||
|
$self->_update($tuple);
|
||
|
} else {
|
||
|
my $query = 'INSERT INTO user_preferences (login, namespace, version, key, value) VALUES (?, ?, ?, ?, ?)';
|
||
|
do_query($::form, $::form->get_standard_dbh, $query, $self->login, $self->namespace, $self->current_version, $key, $value);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub get {
|
||
|
my ($self, $key) = @_;
|
||
|
|
||
|
my $tuple = $self->get_tuple($key);
|
||
|
|
||
|
$tuple ? $tuple->{value} : undef;
|
||
|
}
|
||
|
|
||
|
sub get_tuple {
|
||
|
my ($self, $key) = @_;
|
||
|
|
||
|
my $tuple = selectfirst_hashref_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace, $key);
|
||
|
SELECT * FROM user_preferences WHERE login = ? AND namespace = ? AND key = ?
|
||
|
|
||
|
if ($tuple && $tuple->{version} < $self->current_version) {
|
||
|
$self->_upgrade($tuple);
|
||
|
}
|
||
|
|
||
|
if ($tuple && $tuple->{version} > $self->current_version) {
|
||
|
die "Future version $tuple->{version} for user preference @{ $self->namespace }/$key. Expected @{ $self->current_version } or less.";
|
||
|
}
|
||
|
|
||
|
return $tuple;
|
||
|
}
|
||
|
|
||
|
sub get_all {
|
||
|
my ($self) = @_;
|
||
|
|
||
|
my $data = selectall_hashref_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace);
|
||
|
SELECT * FROM user_preferences WHERE login = ? AND namespace = ?
|
||
|
|
||
|
for my $tuple (@$data) {
|
||
|
if ($tuple->{version} < $self->current_version) {
|
||
|
$self->_upgrade($tuple);
|
||
|
}
|
||
|
|
||
|
if ($tuple->{version} > $self->current_version) {
|
||
|
die "Future version $tuple->{version} for user preference @{ $self->namespace }/$tuple->{key}. Expected @{ $self->current_version } or less.";
|
||
|
}
|
||
|
}
|
||
|
|
||
|
return $data;
|
||
|
}
|
||
|
|
||
|
sub get_keys {
|
||
|
my ($self) = @_;
|
||
|
|
||
|
my @keys = selectall_ids($::form, $::form->get_standard_dbh, <<"", 0, $self->login, $self->namespace);
|
||
|
SELECT key FROM user_preferences WHERE login = ? AND namespace = ?
|
||
|
|
||
|
return @keys;
|
||
|
}
|
||
|
|
||
|
sub delete {
|
||
|
my ($self, $key) = @_;
|
||
|
|
||
|
die 'delete without key is not allowed, use delete_all instead' unless $key;
|
||
|
|
||
|
my @keys = do_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace, $key);
|
||
|
DELETE FROM user_preferences WHERE login = ? AND namespace = ? AND key = ?
|
||
|
|
||
|
}
|
||
|
|
||
|
sub delete_all {
|
||
|
my ($self, $key) = @_;
|
||
|
|
||
|
my @keys = do_query($::form, $::form->get_standard_dbh, <<"", $self->login, $self->namespace);
|
||
|
DELETE FROM user_preferences WHERE login = ? AND namespace = ?
|
||
|
|
||
|
}
|
||
|
|
||
|
### internal stuff
|
||
|
|
||
|
sub _upgrade {
|
||
|
my ($self, $tuple) = @_;
|
||
|
|
||
|
for my $to_version (sort { $a <=> $b } grep { $_ > $tuple->{version} } keys %{ $self->upgrade_callbacks }) {
|
||
|
$tuple->{value} = $self->upgrade_callbacks->{$to_version}->($tuple->{value});
|
||
|
$tuple->{version} = $to_version;
|
||
|
}
|
||
|
|
||
|
if ($self->auto_store_back) {
|
||
|
$self->_update($tuple);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub _update {
|
||
|
my ($self, $tuple) = @_;
|
||
|
|
||
|
my $query = 'UPDATE user_preferences SET version = ?, value = ? WHERE id = ?';
|
||
|
do_query($::form, $::form->get_standard_dbh, $query, $tuple->{version}, $tuple->{value}, $tuple->{id});
|
||
|
}
|
||
|
|
||
|
### defaults stuff
|
||
|
|
||
|
sub init_login { SL::DB::Manager::Employee->current->login }
|
||
|
sub init_namespace { ref $_[0] }
|
||
|
sub init_upgrade_callbacks { +{} }
|
||
|
sub init_current_version { version->parse((ref $_[0])->VERSION)->numify }
|
||
|
sub init_auto_store_back { 1 }
|
||
|
|
||
|
1;
|
||
|
|
||
|
__END__
|
||
|
|
||
|
=encoding utf-8
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
SL::Helper::UserPreferences - user based preferences store
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
use SL::Helper::UserPreferences;
|
||
|
my $user_pref = SL::Helper::UserPreferences->new(
|
||
|
login => $login, # defaults to current user
|
||
|
namespace => $namespace, # defaults to current package
|
||
|
upgrade_callbacks => $upgrade_callbacks,
|
||
|
current_version => $version, # defaults to __PACKAGE__->VERSION->numify
|
||
|
auto_store_back => 0, # default 1
|
||
|
);
|
||
|
|
||
|
$user_pref->store($key, $value);
|
||
|
my $val = $user_pref->get($key);
|
||
|
my $tuple = $user_pref->get_tuple($key);
|
||
|
my $tuples = $user_pref->get_all;
|
||
|
my $keys = $user_pref->get_keys;
|
||
|
$user_pref->delete($key);
|
||
|
$user_pref->delete_all;
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
This module provides a generic storage for information that needs to be stored
|
||
|
between sessions per user and per client and between versions of the program.
|
||
|
|
||
|
The storage can be accessed as a generic key/value dictionary, but also
|
||
|
requires a namespace to avoid clashes and a version of the information.
|
||
|
Additionally you must provide means to upgrade or invalidate stored information
|
||
|
that is out of date, i.e. after a program upgrade.
|
||
|
|
||
|
=head1 FUNCTIONS
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item C<new PARAMS>
|
||
|
|
||
|
Creates a new instance. Available C<PARAMS>:
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item C<login>
|
||
|
|
||
|
The user for this storage. Defaults to current user login.
|
||
|
|
||
|
=item C<namespace>
|
||
|
|
||
|
A unique namespace. Defaults to the calling package.
|
||
|
|
||
|
=item C<upgrade_callbacks>
|
||
|
|
||
|
A hashref with version numbers as keys and subs as values. These subs are
|
||
|
expected to take a value and return an upgraded value for the version of their
|
||
|
key.
|
||
|
|
||
|
No default. Mandatory.
|
||
|
|
||
|
=item C<current_version>
|
||
|
|
||
|
The version object that is considered current for stored information. Defaults
|
||
|
to the version of the calling package. MUST be a number, and not a version
|
||
|
object, so that versions can be used as hash keys in the ugrade_callbacks.
|
||
|
|
||
|
=item C<auto_store_back>
|
||
|
|
||
|
An otional flag indicating whether values from the database that were upgraded to a
|
||
|
newer version should be stored back automatically. Defaults to
|
||
|
C<$::lx_office_conf{debug}{auto_store_back_upgraded_user_preferences}> which in
|
||
|
turn defaults to true.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=item C<store KEY VALUE>
|
||
|
|
||
|
Stores a key-value tuple. If there exists already a value for this key, it will
|
||
|
be overwritten.
|
||
|
|
||
|
=item C<get KEY>
|
||
|
|
||
|
Retrieves a value.
|
||
|
|
||
|
Returns the value. If no such value exists returns undef instead.
|
||
|
|
||
|
This is for easy of use, and does no distinction between non-existing values
|
||
|
and valid undefined values. Use C<get_tuple> if you need this.
|
||
|
|
||
|
=item C<get_tuple KEY>
|
||
|
|
||
|
Retrieves a key-value tuple.
|
||
|
|
||
|
Returns a hashref with C<key> and C<value> entries. If no such value
|
||
|
exists returns undef instead.
|
||
|
|
||
|
=item C<get_all>
|
||
|
|
||
|
Retrieve all key-value tuples in this namespace and user.
|
||
|
|
||
|
Returns an arrayref of hashrefs.
|
||
|
|
||
|
=item C<get_keys>
|
||
|
|
||
|
Retrieve all keys for this namespace. Note: Unless you store vast amount of
|
||
|
data, it's most likely easier to just C<get_all>.
|
||
|
|
||
|
Returns an arrayref of keys.
|
||
|
|
||
|
=item C<delete KEY>
|
||
|
|
||
|
Deletes a tuple.
|
||
|
|
||
|
=item C<delete_all>
|
||
|
|
||
|
Delete all tuples for this namespace and user.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 VERSIONING
|
||
|
|
||
|
Every entry in the user prefs must have a version to be compatible in case of
|
||
|
code upgrades.
|
||
|
|
||
|
Code reading user prefs must check if the version is the expected one, and must
|
||
|
have upgrade code to upgrade out of date preferences to the current version.
|
||
|
|
||
|
Code SHOULD write the upgraded version back to the store at the earliest time
|
||
|
to keep preferences up to date. This should be able to be disabled to have
|
||
|
developer versions not overwrite preferences with unsupported versions.
|
||
|
|
||
|
Example:
|
||
|
|
||
|
Initial code dealing with prefs:
|
||
|
|
||
|
our $VERSION = v1;
|
||
|
|
||
|
$user_prefs->store("selected tab", $::form->{selected_tab});
|
||
|
|
||
|
And the someone edits the code and removes the tab "Webdav". To ensure
|
||
|
favorites with webdav selected are upgraded:
|
||
|
|
||
|
our $VERSION = v2;
|
||
|
|
||
|
my $upgrade_callbacks = {
|
||
|
2 => sub { $_[0] eq 'WebDav' ? 'MasterData' : $_[0]; },
|
||
|
};
|
||
|
|
||
|
my $val = $user_prefs->get("selected tab");
|
||
|
|
||
|
=head1 LACK OF TYPING
|
||
|
|
||
|
This controller will not attempt to preserve types. All data will be
|
||
|
stringified. If your code needs to preserve numbers, you MUST encode the data
|
||
|
to JSON or YAML before storing.
|
||
|
|
||
|
=head1 PLANNED BEST PRACTICE
|
||
|
|
||
|
To be able to decouple controllers and the schema upgrading required for this,
|
||
|
there should be exactly one module responsible for managing user preferences for
|
||
|
each namespace. You should find the corresponding preferences owners in the
|
||
|
class namespace C<SL::Helper::UserPreferences>.
|
||
|
|
||
|
For example the namespace C<PartsSearchFavorites> should only be managed by
|
||
|
C<SL::Helper::UserPreferences::PartsSearchFavorites>. This way, it's possible
|
||
|
to keep the upgrades in one place, and to migrate upgrades out of there into
|
||
|
database upgrades during major releases. They also don't clutter up
|
||
|
controllers.
|
||
|
|
||
|
It is planned to strip all modules located there of their upgrade for a release
|
||
|
and do automatic database upgrades.
|
||
|
|
||
|
To avoid version clashes when developing customer branches, please only use
|
||
|
stable version bumps in the unstable branch, and use dev versions in customer
|
||
|
branches.
|
||
|
|
||
|
=head1 BEHAVIOUR
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item *
|
||
|
|
||
|
If a (namepace, key) tuple exists, a store will overwrite the last version
|
||
|
|
||
|
=item *
|
||
|
|
||
|
If the value retrieved from the database is newer than the code version, an
|
||
|
error must be thrown.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
get will check the version against the current version and apply all upgrade
|
||
|
steps.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
If the final step is not the current version, behaviour is undefined
|
||
|
|
||
|
=item *
|
||
|
|
||
|
get_all will always return scalar context.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 TODO AND SPECIAL CASES
|
||
|
|
||
|
* not defined whether it should be possible to retrieve the version of a tuple
|
||
|
|
||
|
* it's not specified how to return invalidation from upgrade, nor how to handle
|
||
|
that
|
||
|
|
||
|
* it's not specified whether admin is a user. for now it dies.
|
||
|
|
||
|
* We're missing user agnostic methods for database upgrades
|
||
|
|
||
|
=head1 BUGS
|
||
|
|
||
|
None yet :)
|
||
|
|
||
|
=head1 AUTHOR
|
||
|
|
||
|
Sven Schöling <s.schoeling@linet-services.de>
|
||
|
|
||
|
=cut
|
||
| sql/Pg-upgrade2/user_preferences.sql | ||
|---|---|---|
|
-- @tag: user_preferences
|
||
|
-- @description: Benutzereinstellungen
|
||
|
-- @depends: release_3_4_1
|
||
|
-- @encoding: utf-8
|
||
|
|
||
|
CREATE TABLE user_preferences (
|
||
|
id SERIAL PRIMARY KEY,
|
||
|
login TEXT NOT NULL,
|
||
|
namespace TEXT NOT NULL,
|
||
|
version NUMERIC(15,5),
|
||
|
key TEXT NOT NULL,
|
||
|
value TEXT,
|
||
|
UNIQUE (login, namespace, version, key)
|
||
|
);
|
||
| t/helper/user_preferencess.t | ||
|---|---|---|
|
use Test::More;
|
||
|
use Test::Exception;
|
||
|
use Test::Deep qw(bag cmp_deeply);
|
||
|
|
||
|
use strict;
|
||
|
use lib 't';
|
||
|
|
||
|
use Support::TestSetup;
|
||
|
use_ok 'SL::Helper::UserPreferences';
|
||
|
|
||
|
Support::TestSetup::login();
|
||
|
|
||
|
my $prefs;
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1 ];
|
||
|
|
||
|
|
||
|
$prefs->store('test1', "val");
|
||
|
$prefs->store('test2', "val2");
|
||
|
|
||
|
cmp_deeply [ $prefs->get_keys ], bag('test1', 'test2'), 'get_keys works';
|
||
|
|
||
|
is $prefs->get('test1'), 'val', 'get works';
|
||
|
is $prefs->get_tuple('test2')->{value}, 'val2', 'get tuple works';
|
||
|
is $prefs->get_all->[1]{value}, 'val2', 'get all works';
|
||
|
is scalar @{ $prefs->get_all }, 2, 'get all works 2';
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [
|
||
|
current_version => 2,
|
||
|
upgrade_callbacks => {
|
||
|
2 => sub { my ($val) = @_; $val . ' in space!'; }
|
||
|
}
|
||
|
];
|
||
|
|
||
|
is $prefs->get('test1'), 'val in space!', 'upgrading works';
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
|
||
|
is $prefs->get('test1'), 'val in space!', 'auto store back works';
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1, namespace => 'namespace2' ];
|
||
|
is $prefs->get('test1'), undef, 'other namespace does not find prior data';
|
||
|
|
||
|
$prefs->store('test1', "namespace2 test");
|
||
|
is $prefs->get('test1'), 'namespace2 test', 'other namespace finds data with same key';
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
|
||
|
is $prefs->get('test1'), 'val in space!', 'original namepsace is not affected';
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1, login => 'demo2' ];
|
||
|
$prefs->store('test1', "login test");
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
|
||
|
is $prefs->get('test1'), 'val in space!', 'original login is not affected';
|
||
|
|
||
|
$prefs->store('test1', 'new value');
|
||
|
is scalar @{ $prefs->get_all }, 2, 'storing an existing value overwrites';
|
||
|
|
||
|
my @array = $prefs->get_all;
|
||
|
is scalar @array, 1, 'get_all in list context returns 1 element';
|
||
|
isa_ok $array[0], 'ARRAY', 'get_all in list context returns 1 arrayref';
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 1 ];
|
||
|
dies_ok { $prefs->get('test1') } 'reading newer version dies';
|
||
|
|
||
|
$prefs = new_ok 'SL::Helper::UserPreferences', [ current_version => 2 ];
|
||
|
$prefs->delete('test1');
|
||
|
is $prefs->get('test1'), undef, 'deleting works';
|
||
|
|
||
|
$prefs->delete_all;
|
||
|
is $prefs->get('test2'), undef, 'delete_all works';
|
||
|
|
||
|
done_testing;
|
||
Auch abrufbar als: Unified diff
UserPreferences: erste version