* Factor 'database knowledge' out of 'setup.pl'

ledgersmb · Jul 1, 2018 · 37e7c25 · 37e7c25
1 parent 9a8ab16
commit 37e7c25
Show file tree

Hide file tree

Showing 4 changed files with 217 additions and 61 deletions.
diff --git a/lib/LedgerSMB/Database/Config.pm b/lib/LedgerSMB/Database/Config.pm
@@ -0,0 +1,142 @@
+
+package LedgerSMB::Database::Config;
+
+=head1 NAME
+
+LedgerSMB::Database::Config - Database setup data (CoA, GIFI, SIC & templates)
+
+=head1 DESCRIPTION
+
+
+=cut
+
+use strict;
+use warnings;
+
+use Moose;
+
+use File::Find::Rule;
+use File::Spec;
+use Locale::Country;
+
+use LedgerSMB::Sysconfig;
+
+=head1 SYNOPSIS
+
+my $dbconfig = LedgerSMB::Database::Config->new;
+
+=cut
+
+
+###############################
+#
+#
+# Private functions
+#
+##############################
+
+sub _list_directory {
+    my $dir = shift;
+
+    return [] if ! -d $dir;
+
+    opendir(DIR, $dir);
+    my @files =
+        sort(grep !/^(\.|[Ss]ample.*)/,
+             readdir(DIR));
+    closedir(DIR);
+
+    return \@files;
+}
+
+
+
+=head1 METHODS
+
+=head2 templates
+
+Returns a hash where the keys are the "names" of the template sets and
+the values are refs to arrays holding the list of files in the template
+set.
+
+=cut
+
+sub templates {
+    my $basedir = LedgerSMB::Sysconfig::templates();
+    my $templates = _list_directory($basedir);
+
+    return {
+        map {
+            $_ => [ File::Find::Rule->new->file
+                    ->in(File::Spec->catfile($basedir, $_)) ]
+        }
+        grep { -d File::Spec->catfile($basedir, $_) }
+        @$templates
+    };
+}
+
+=head2 charts_of_accounts
+
+Returns a hash where the keys are the alpha-2 codes of the countries
+(locales) to which the chart data applies. The values are refs to
+hashes with the following keys -- the values of the hashes being the
+files holding the specified data:
+
+=over
+
+=item code
+
+'alpha-2' code of the country/locale
+
+=item name
+
+Full name or description of the country/locale
+
+=item chart
+
+List of available files defining a chart of accounts
+
+=item gifi
+
+List of available files defining an alternative (legally required) set
+of accounts such as required per Canadian GIFI regulations
+
+=item sic
+
+List of available files defining a Standard of Industry Codes
+
+=back
+
+=cut
+
+sub charts_of_accounts {
+    ###TODO: Define a parameter to the SQL directory!!
+    my $basedir = File::Spec->catfile('.', 'sql', 'coa');
+    my $countries = _list_directory($basedir);
+
+    return {
+        map {
+            my $dir = File::Spec->catfile($basedir, $_);
+            $_ => {
+                code => $_,
+                name => code2country($_, 'alpha-2'),
+                chart => _list_directory(File::Spec->catfile($dir, 'chart')),
+                gifi => _list_directory(File::Spec->catfile($dir, 'gifi')),
+                sic => _list_directory(File::Spec->catfile($dir, 'sic')),
+              }
+        } @$countries
+    };
+}
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (C) 2018 The LedgerSMB Core Team
+
+This file may be used under the GNU General Public License version 2 or at your
+option any later version.  As part of the database framework of LedgerSMB it
+may also be moved out to the PGObject distribution on CPAN and relicensed under
+the same BSD license as the rest of that framework.
+
+=cut
+
+1;
diff --git a/lib/LedgerSMB/Scripts/setup.pm b/lib/LedgerSMB/Scripts/setup.pm
@@ -37,6 +37,7 @@ use Version::Compare;
 
 use LedgerSMB::App_State;
 use LedgerSMB::Database;
+use LedgerSMB::Database::Config;
 use LedgerSMB::DBObject::Admin;
 use LedgerSMB::DBObject::User;
 use LedgerSMB::Magic qw( EC_EMPLOYEE HTTP_454 PERL_TIME_EPOCH );
@@ -518,27 +519,6 @@ sub revert_migration {
     return $template->render($request);
 }
 
-=item _get_template_directories
-
-Returns set of template directories available.
-
-=cut
-
-sub _get_template_directories {
-    my $subdircount = 0;
-    my @dirarray;
-    my $locale = $LedgerSMB::App_State::Locale;
-    opendir ( DIR, $LedgerSMB::Sysconfig::templates) || die $locale->text('Error while opening directory: [_1]',  "./$LedgerSMB::Sysconfig::templates");
-    while( my $name = readdir(DIR)){
-        next if ($name =~ /\./);
-        if (-d "$LedgerSMB::Sysconfig::templates/$name" ) {
-            push @dirarray, {text => $name, value => $name};
-        }
-    }
-    closedir(DIR);
-    return \@dirarray;
-}
-
 =item template_screen
 
 Shows the screen for loading templates.  This should appear before loading
@@ -549,7 +529,9 @@ so that further workflow can be aborted.
 
 sub template_screen {
     my ($request) = @_;
-    $request->{template_dirs} = _get_template_directories();
+    $request->{template_dirs} =
+        [ map { +{ text => $_, value => $_ } }
+          keys %{ LedgerSMB::Database::Config->new->templates } ];
     return LedgerSMB::Template->new_UI(
         $request,
         template => 'setup/template_info',
@@ -566,13 +548,15 @@ and not the user creation screen.
 
 sub load_templates {
     my ($request) = @_;
-    my $dir = $LedgerSMB::Sysconfig::templates . '/' . $request->{template_dir};
+    my $templates = LedgerSMB::Database::Config->new->templates;
+
+    die "Invalid request" if not exists $templates->{$request->{template_dir}};
+
     _init_db($request);
     my $dbh = $request->{dbh};
-    opendir(DIR, $dir);
-    while (my $fname = readdir(DIR)){
-       next unless -f "$dir/$fname";
-       my $dbtemp = LedgerSMB::Template::DB->get_from_file("$dir/$fname");
+
+    for my $template (@{$templates->{$request->{template_dir}}}) {
+       my $dbtemp = LedgerSMB::Template::DB->get_from_file($template);
        $dbtemp->save;
     }
     return _render_new_user($request) unless $request->{only_templates};
@@ -1018,9 +1002,22 @@ sub select_coa {
     use LedgerSMB::Sysconfig;
 
     my ($request) = @_;
+    my $coa_data = LedgerSMB::Database::Config->new->charts_of_accounts;
+
+    if ($request->{coa_lc}) {
+        my $coa_lc = $request->{coa_lc};
+        if (not exists $coa_data->{$coa_lc}) {
+            die $request->{_locale}->text('Invalid request');
+        }
 
-    if ($request->{coa_lc} and $request->{coa_lc} =~ /\.\./ ){
-        die $request->{_locale}->text('Access Denied');
+        for my $coa_type (qw( chart gifi sic )) {
+            if ($request->{$coa_type}) {
+                if (! grep { $_ eq $request->{$coa_type} }
+                    @{$coa_data->{$coa_lc}->{$coa_type}}) {
+                    die $request->{_locale}->text('Invalid request');
+                }
+            }
+        }
     }
 
     if ($request->{coa_lc}){
@@ -1038,40 +1035,14 @@ sub select_coa {
 
            return template_screen($request);
         } else {
-            opendir(CHART, "sql/coa/$request->{coa_lc}/chart");
-            @{$request->{charts}} =
-                map +{ name => $_ },
-                sort(grep !/^(\.|[Ss]ample.*)/,
-                      readdir(CHART));
-            closedir(CHART);
-
-            opendir(GIFI, "sql/coa/$request->{coa_lc}/gifi");
-            @{$request->{gifis}} =
-                map +{ name => $_ },
-                sort(grep !/^(\.|[Ss]ample.*)/,
-                      readdir(GIFI));
-            closedir(GIFI);
-
-            if (-e "sql/coa/$request->{coa_lc}/sic") {
-                opendir(SIC, "sql/coa/$request->{coa_lc}/sic");
-                @{$request->{sics}} =
-                    map +{ name => $_ },
-                    sort(grep !/^(\.|[Ss]ample.*)/,
-                         readdir(SIC));
-                closedir(SIC);
-            }
-            else {
-                @{$request->{sics}} = ();
+            for my $select (qw(chart gifi sic)) {
+                $request->{"${select}s"} =
+                    [ map { +{ name => $_ } }
+                      @{$coa_data->{$request->{coa_lc}}->{$select}} ];
             }
        }
     } else {
-        #COA Directories
-        opendir(COA, 'sql/coa');
-        @{$request->{coa_lcs}} =
-            map +{ code => $_ },
-            sort(grep !/^(\.|[Ss]ample.*)/,
-                 readdir(COA));
-        closedir(COA);
+        $request->{coa_lcs} = [ values %$coa_data ];
     }
 
     my $template = LedgerSMB::Template->new_UI(

diff --git a/t/01-load.t b/t/01-load.t
@@ -59,7 +59,7 @@ my @modules =
           'LedgerSMB::File', 'LedgerSMB::Report',
           'LedgerSMB::Template', 'LedgerSMB::Legacy_Util',
           'LedgerSMB::Company_Config', 'LedgerSMB::Database',
-          'LedgerSMB::Database::ChangeChecks',
+          'LedgerSMB::Database::ChangeChecks', 'LedgerSMB::Database::Config',
           'LedgerSMB::PGObject', 'LedgerSMB::Auth',
           'LedgerSMB::AA', 'LedgerSMB::AM', 'LedgerSMB::Batch',
           'LedgerSMB::IC', 'LedgerSMB::IR', 'LedgerSMB::PGDate',

diff --git a/t/12-dbconfig.t b/t/12-dbconfig.t
@@ -0,0 +1,43 @@
+#!perl
+
+use File::Spec;
+use Test::More;
+
+
+use LedgerSMB::Database::Config;
+use LedgerSMB::Sysconfig;
+
+my $coa = LedgerSMB::Database::Config->new->charts_of_accounts;
+
+ok( m/^[[:alnum:]]{2,2}(_[[:alnum:]]{2,2})?$/,
+    "Returned coa key '$_' follows the xx or xx_xx pattern" )
+    for (keys %$coa);
+ok( -d File::Spec->catfile('sql', 'coa', $_),
+    "Returned coa key '$_' exist as directory")
+    for (keys %$coa);
+for my $coa_data (values %$coa) {
+    is_deeply [ sort keys %$coa_data ], [ qw( chart code gifi name sic ) ],
+       'CoA data contains keys as per API declaration';
+}
+ok( scalar(@{$coa->{$_}->{chart}}) > 0,
+    "There is at least one chart in coa data for '$_'")
+    for (keys %$coa);
+for my $type (qw( chart gifi sic )) {
+    for my $locale (keys %$coa) {
+        ok( -f File::Spec->catfile('sql', 'coa', $locale, $type, $_),
+            "Returned coa item (sql/coa/$locale/$type/$_) is a file")
+            for (@{$coa->{$locale}->{$type}});
+    }
+}
+
+my $templates = LedgerSMB::Database::Config->new->templates;
+
+is_deeply [ sort keys %$templates ], [ qw( demo demo_with_images xedemo ) ],
+    'Returned template sets are the example templates';
+for my $template (keys %$templates) {
+    ok( -f $_, "Returned template item ($_) is a file" )
+        for (@{$templates->{$template}});
+}
+
+
+done_testing;