kalipso/racalmas
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove cache

Browse Source 
* remove cache, cache setup is not easy, todays servers do not really
* need it anymore
* add prototypes and fix parameter issues
* suppress redefinition
This commit is contained in:
Milan
2019-04-13 20:31:25 +02:00
parent e90ea3929d
commit d3fc5f998a
81 changed files with 3190 additions and 20267 deletions
Download Patch File Download Diff File Expand all files Collapse all files

74
lib/calcms/aggregator.pm
View File

@@ -1,18 +1,18 @@
package aggregator;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use events();
use comments();
use calendar();
use project();
use cache();
use base 'Exporter';
our @EXPORT_OK = qw(get_cache configure_cache put_cache get_list check_params);
our @EXPORT_OK = qw(get_cache configure_cache put_cache get_list check_params);
sub get_list {
sub get_list($$) {
my $config = shift;
my $request = shift;
@@ -54,8 +54,6 @@ sub get_list {
my @used_projects = reverse sort { $used_projects->{$a} <=> $used_projects->{$b} } ( keys %$used_projects );
my $most_used_project = $used_projects[0];
#use Data::Dumper;print STDERR Dumper(\@used_projects);
return {
day => $results->[0]->{day},
start_datetime => $results->[0]->{start_datetime},
@@ -70,7 +68,7 @@ sub get_list {
};
}
sub get_menu {
sub get_menu($$$$) {
my $config = shift;
my $request = shift;
my $date = shift;
@@ -86,7 +84,7 @@ sub get_menu {
$request->{params}->{checked} = events::check_params( $config, $request->{params}->{original} );
$results = events::get( $config, $request );
} else {
$request->{params}->{checked}->{template} = template::check($config, 'event_menu.html');
$request->{params}->{checked}->{template} = template::check( $config, 'event_menu.html' );
}
#events menu
@@ -96,7 +94,7 @@ sub get_menu {
return { content => $output };
}
sub get_calendar {
sub get_calendar($$$) {
my $config = shift;
my $request = shift;
my $date = shift;
@@ -122,7 +120,7 @@ sub get_calendar {
return { content => $content };
}
sub get_newest_comments {
sub get_newest_comments($$) {
my $config = shift;
my $request = shift;
@@ -146,49 +144,7 @@ sub get_newest_comments {
return { content => $content };
}
sub get_cache {
my $config = shift;
my $request = shift;
my $params = $request->{params}->{checked};
my $debug = $config->{system}->{debug};
if ( $config->{cache}->{use_cache} == 1 ) {
configure_cache($config);
my $cache = cache::load( $config, $params );
return $cache;
}
return {};
}
sub configure_cache {
my $config = shift;
cache::init();
my $controllers = $config->{controllers};
my $date_pattern = cache::get_date_pattern();
# cache::add_map('' ,'programm/index.html');
cache::add_map( 'date=today', 'programm/' . $controllers->{events} . '/today.html' );
cache::add_map( 'date=' . $date_pattern, 'programm/' . $controllers->{events} . '/$1-$2-$3.html' );
cache::add_map( 'from_date=' . $date_pattern . '&till_date=' . $date_pattern,
'programm/' . $controllers->{events} . '/$1-$2-$3_$4-$5-$6.html' );
cache::add_map( 'event_id=(\d+)', 'programm/' . $controllers->{event} . '/$1.html' );
}
sub put_cache {
my $config = shift;
my $request = shift;
my $cache = shift;
#write to cache
if ( $config->{cache}->{use_cache} == 1 ) {
cache::save($cache);
}
}
sub check_params {
sub check_params($$) {
my $config = shift;
my $params = shift;
@@ -200,14 +156,8 @@ sub check_params {
#filter for date
my $date = time::check_date( $params->{date} );
#print STDERR $date."\n";
if ( $date eq '' ) {
$date = time::time_to_date( time() );
}
#
if ( $date eq 'today' ) {
$date = time::get_event_date($config);
}
$date = time::time_to_date( time() ) if $date eq '';
$date = time::get_event_date($config) if $date eq 'today';
# $date =$config->{date}->{start_date} if ($date lt $config->{date}->{start_date});
# $date =$config->{date}->{end_date} if ($date gt $config->{date}->{end_date});
@@ -279,8 +229,6 @@ sub check_params {
from_date => $from_date,
till_date => $till_date,
event_id => $event_id,
# project => $project,
debug => $debug,
};
}

20
lib/calcms/audio_recordings.pm
View File

@@ -1,13 +1,14 @@
package audio_recordings;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use db();
use base 'Exporter';
our @EXPORT_OK = qw(get_columns get);
our @EXPORT_OK = qw(get_columns get);
# columns:
# id, project_id, studio_id, event_id
@@ -17,7 +18,7 @@ our @EXPORT_OK = qw(get_columns get);
sub debug;
sub get_columns {
sub get_columns($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -30,7 +31,7 @@ sub get_columns {
}
# get playout entries
sub get {
sub get($$) {
my $config = shift;
my $condition = shift;
@@ -38,7 +39,8 @@ sub get {
return undef unless defined $condition->{studio_id};
my $date_range_include = 0;
$date_range_include = 1 if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
$date_range_include = 1
if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
my $dbh = db::connect($config);
@@ -105,7 +107,7 @@ sub get {
}
# update playout entry if differs to old values
sub update {
sub update($$$) {
my $config = shift;
my $dbh = shift;
my $entry = shift;
@@ -144,7 +146,7 @@ sub update {
}
# insert playout entry
sub insert {
sub insert ($$$) {
my $config = shift;
my $dbh = shift;
my $entry = shift;
@@ -177,7 +179,7 @@ sub insert {
}
# delete playout entry
sub delete {
sub delete ($$$) {
my $config = shift;
my $dbh = shift;
my $entry = shift;
@@ -196,7 +198,7 @@ sub delete {
return db::put( $dbh, $query, $bind_values );
}
sub error {
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

36
lib/calcms/auth.pm
View File

@@ -1,7 +1,8 @@
package auth;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use CGI::Simple();
use CGI::Session qw(-ip-match);
@@ -22,7 +23,7 @@ my $debug = 0;
sub debug;
#TODO: remove CGI
sub get_user {
sub get_user($$$) {
my $config = shift;
my $params = shift;
my $cgi = shift;
@@ -61,7 +62,7 @@ sub get_user {
return $session->{user}, $session->{expires};
}
sub crypt_password {
sub crypt_password($) {
my $password = shift;
my $ppr = Authen::Passphrase::BlowfishCrypt->new(
@@ -75,7 +76,7 @@ sub crypt_password {
};
}
sub login {
sub login($$$) {
my $config = shift;
my $user = shift;
my $password = shift;
@@ -98,8 +99,9 @@ sub login {
}
#TODO: remove cgi
sub logout {
my $cgi = shift;
sub logout($) {
my $cgi = shift;
my $session_id = read_cookie();
debug("logout") if $debug;
unless ( delete_session($session_id) ) {
@@ -115,7 +117,7 @@ sub logout {
}
#read and write data from browser, http://perldoc.perl.org/CGI/Cookie.html
sub create_cookie {
sub create_cookie($$) {
my $session_id = shift;
my $timeout = shift;
@@ -131,7 +133,7 @@ sub create_cookie {
return 1;
}
sub read_cookie {
sub read_cookie() {
debug("read_cookie") if $debug;
my %cookie = CGI::Cookie->fetch;
debug( "cookies: " . Dumper( \%cookie ) ) if $debug;
@@ -144,7 +146,7 @@ sub read_cookie {
}
#TODO: remove CGI
sub delete_cookie {
sub delete_cookie($) {
my $cgi = shift;
debug("delete_cookie") if $debug;
@@ -157,9 +159,9 @@ sub delete_cookie {
return 1;
}
#read and write server-side session data
# read and write server-side session data
# expiration is in seconds
sub create_session {
sub create_session ($$$) {
my $user = shift;
my $password = shift;
my $expiration = shift;
@@ -174,7 +176,7 @@ sub create_session {
return $session->id();
}
sub read_session {
sub read_session($) {
my $session_id = shift;
debug("read_session") if $debug;
@@ -194,7 +196,7 @@ sub read_session {
};
}
sub delete_session {
sub delete_session($) {
my $session_id = shift;
debug("delete_session") if $debug;
@@ -205,7 +207,7 @@ sub delete_session {
}
#check user authentication
sub authenticate {
sub authenticate($$$) {
my $config = shift;
my $user = shift;
my $password = shift;
@@ -237,7 +239,7 @@ sub authenticate {
# timeout in seconds
my $timeout = $users->[0]->{session_timeout} || 120;
$timeout = 60 if $timeout < 60;
$timeout = 60 if $timeout < 60;
return {
timeout => $timeout,
@@ -245,7 +247,7 @@ sub authenticate {
};
}
sub show_login_form {
sub show_login_form ($$) {
my $user = shift || '';
my $uri = $ENV{HTTP_REFERER} || '';
my $message = shift || '';
@@ -359,7 +361,7 @@ sub show_login_form {
return undef;
}
sub debug {
sub debug ($) {
my $message = shift;
print STDERR "$message\n" if $debug > 0;
return;

183
lib/calcms/cache.pm
View File

@@ -1,183 +0,0 @@
package cache;
use warnings "all";
use strict;
use config();
use time();
use log();
use markup();
use base 'Exporter';
our @EXPORT_OK = qw(init add_map get_map get_map_keys load save get_filename escape_regexp escape_regexp_line);
my $cache_map = {};
my $cache_map_keys = [];
my $header_printed = 0;
my $date_pattern = '(\d{4})\-(\d{2})\-(\d{2})';
my $datetime_pattern = '(\d{4})\-(\d{2})\-(\d{2})[T\+](\d{2})\:(\d{2})(\:\d{2})?';
sub init {
$cache_map = {};
$cache_map_keys = [];
$header_printed = 0;
}
sub get_date_pattern(){
return $date_pattern;
}
sub get_datetime_pattern(){
return $datetime_pattern;
}
sub add_map {
my $key = $_[0];
my $value = $_[1];
$key = '^' . $key . '$';
push @$cache_map_keys, $key;
$cache_map->{$key} = $value;
}
sub get_map {
return $cache_map;
}
sub get_map_keys {
return $cache_map_keys;
}
#get cache from params
sub load {
my $params = shift;
my $filename = get_filename($params);
my $result = { filename => $filename };
if ( defined $filename ) {
my @file_info = stat($filename);
my $modified = $file_info[9] || '';
if ( $modified ne '' ) {
#file exists
my @now = localtime( time() );
my @modified = localtime($modified);
if ( $now[2] == $modified[2] ) {
#file is elder than a hour
my $content = log::load_file($filename);
if ( defined $content ) {
$result->{content} = $content;
$result->{action} = 'read';
return $result;
}
}
}
}
$result->{action} = 'save';
return $result;
}
#get filename from params
sub get_filename {
my $config = shift;
my $params = shift;
# my $url=$ENV{REQUEST_URI};
my $url = $ENV{QUERY_STRING} || '';
if ( $url ne '' ) {
$url =~ s/(^|\&)update\=\d//gi;
$url =~ s/(^|\&)debug\=.*//gi;
$url =~ s/\?\&/\?/g;
$url =~ s/\&{2,99}/\&/g;
$url =~ s/\&$//g;
$url =~ s/^\/\//\//g;
}
foreach my $pattern (@$cache_map_keys) {
my $filename = $url;
if ( $filename =~ /$pattern/ ) {
my $m1 = $1;
my $m2 = $2;
my $m3 = $3;
my $m4 = $4;
my $m5 = $5;
my $m6 = $6;
my $m7 = $7;
my $m8 = $8;
# my $m9=$9;
my $result = $cache_map->{$pattern};
$filename =~ s/$pattern/$result/;
$filename =~ s/\$1/$m1/ if ( defined $m1 );
$filename =~ s/\$2/$m2/ if ( defined $m2 );
$filename =~ s/\$3/$m3/ if ( defined $m3 );
$filename =~ s/\$4/$m4/ if ( defined $m4 );
$filename =~ s/\$5/$m5/ if ( defined $m5 );
$filename =~ s/\$6/$m6/ if ( defined $m6 );
$filename =~ s/\$7/$m7/ if ( defined $m7 );
$filename =~ s/\$8/$m8/ if ( defined $m8 );
# $filename=~s/\$9/$m9/ if (defined $m9);
$filename = $config->{cache}->{cache_dir} . $filename;
return $filename;
}
}
return undef;
}
#deprecated: set file from params
sub set {
my $params = shift;
my $content = shift;
my $filename = get_filename($params);
my $cache = {
filename => $filename,
content => $content
};
# print $filename.":file\n";
if ( defined $filename ) {
cache::save($cache);
}
}
sub save {
my $cache = shift;
return if $cache->{action} ne 'save';
return if ( !defined $cache->{filename} ) || ( $cache->{filename} eq '' );
log::save_file( $cache->{filename}, $cache->{content} );
chmod 0664, $cache->{filename};
}
sub escape_regexp {
my $reg_exp = shift;
$reg_exp =~ s/([\^\$\\(\)\[\]\{\}\|\/\*\+\.\-\&\:])/\\$1/gi;
return $reg_exp;
}
sub escape_regexp_line {
my $reg_exp = shift;
$reg_exp =~ s/([\^\$\\(\)\[\]\{\}\|\/\*\+\.\-\&\:])/\\$1/gi;
return '^' . $reg_exp . '$';
}
sub configure {
my $file_name = shift;
cache::init();
cache::add_map( '', $file_name );
}
#do not delete last line!
1;

59
lib/calcms/calendar.pm
View File

@@ -1,22 +1,22 @@
package calendar;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Date::Calc();
use template();
use cache();
use events();
use base 'Exporter';
our @EXPORT_OK = qw(init get_cached_or_render get render get_calendar_weeks configure_cache);
sub init {
sub init() {
}
sub get_cached_or_render {
sub get_cached_or_render($$$) {
# my $output = $_[0]
my $config = $_[1];
@@ -25,30 +25,12 @@ sub get_cached_or_render {
my $parms = $request->{params}->{checked};
my $debug = $config->{system}->{debug};
my $cache = {};
if ( $config->{cache}->{use_cache} == 1 ) {
calendar::configure_cache($config);
$cache = cache::load( $config, $parms );
if ( defined $cache->{content} ) {
$_[0] = $cache->{content};
return;
}
}
my $calendar = calendar::get( $config, $request );
calendar::render( $_[0], $config, $request, $calendar );
#write to cache
if ( $config->{cache}->{use_cache} == 1 ) {
#todo:put out reference only
$cache->{content} = $_[0];
cache::save($cache);
}
}
sub get {
sub get($$) {
my $config = shift;
my $request = shift;
@@ -156,7 +138,7 @@ sub get {
$start_year = $1;
$start_month = $2;
}
my $monthNames=time::getMonthNamesShort($language);
my $monthNames = time::getMonthNamesShort($language);
my $start_month_name = $monthNames->[ $start_month - 1 ];
if ( $params->{month_only} eq '1' ) {
@@ -208,7 +190,8 @@ sub get {
my $weekday = 0;
my $day_result = undef;
( $week_of_year, $woy_year ) = Date::Calc::Week_of_Year( $year, $month, $day ) unless defined $week_of_year;
( $week_of_year, $woy_year ) = Date::Calc::Week_of_Year( $year, $month, $day )
unless defined $week_of_year;
$day_result = {
date => $date,
@@ -299,7 +282,7 @@ sub get {
}
sub render {
sub render($$$$) {
# my $out = $_[0];
my $config = $_[1];
@@ -314,12 +297,13 @@ sub render {
$template_parameters->{base_url} = $config->{locations}->{base_url};
$template_parameters->{cache_base_url} = $config->{cache}->{base_url};
$template_parameters->{server_cache} = $config->{cache}->{server_cache} if ( $config->{cache}->{server_cache} );
$template_parameters->{use_client_cache} = $config->{cache}->{use_client_cache} if ( $config->{cache}->{use_client_cache} );
$template_parameters->{use_client_cache} = $config->{cache}->{use_client_cache}
if ( $config->{cache}->{use_client_cache} );
template::process( $config, $_[0], $parms->{template}, $template_parameters );
}
sub get_calendar_weeks {
sub get_calendar_weeks($$$) {
my $config = shift;
my $start = shift;
my $end = shift;
@@ -349,7 +333,7 @@ sub get_calendar_weeks {
return $years;
}
sub getWeeksOfMonth {
sub getWeeksOfMonth($$) {
my $thisYear = shift;
my $thisMonth = shift;
my $thisDay = 1;
@@ -439,22 +423,7 @@ sub getWeeksOfMonth {
return \@weeks;
}
sub configure_cache {
my $config = shift;
my $debug = $config->{system}->{debug};
cache::init();
my $date_pattern = cache::get_date_pattern();
my $controllers = $config->{controllers};
cache::add_map( '', $controllers->{calendar} . '/cal.html' );
cache::add_map( 'date=' . $date_pattern, $controllers->{calendar} . '/$1-$2.html' );
cache::add_map( 'from_date=' . $date_pattern . '&till_date=' . $date_pattern, $controllers->{calendar} . '/$1-$2_$5-$6.html' );
}
sub check_params {
sub check_params($$) {
my $config = shift;
my $params = shift;

142
lib/calcms/comments.pm
View File

@@ -1,7 +1,8 @@
package comments;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use db();
@@ -12,13 +13,12 @@ use time();
use base 'Exporter';
our @EXPORT_OK =
qw(init get_cached_or_render get modify_results render configure_cache get_query get_by_event get_level get_events check insert set_lock_status set_news_status lock update_comment_count sort)
;
qw(init get_cached_or_render get modify_results render configure_cache get_query get_by_event get_level get_events check insert set_lock_status set_news_status lock update_comment_count sort);
sub init {
sub init() {
}
sub get_cached_or_render {
sub get_cached_or_render($$$;$) {
# my $response=$_[0];
my $config = $_[1];
@@ -33,7 +33,6 @@ sub get_cached_or_render {
my $comment = $request->{params}->{checked};
my $filename = '';
my $cache = {};
my $results = comments::get( $config, $request );
@@ -54,15 +53,8 @@ sub get_cached_or_render {
comments::modify_results( $results, $config, $request );
#print STDERR Dumper($results);
$results = comments::sort( $config, $results ) if ( $comment->{type} eq 'tree' );
#print STDERR Dumper($results);
# if ($comment->{sort_order}eq'desc'){
# my @results= reverse(@$results);
# $results=\@results;
# }
if ( ( $params->{show_max} ne '' )
&& ( $params->{limit} ne '' )
&& ( $params->{show_max} < $params->{limit} ) )
@@ -81,7 +73,7 @@ sub get_cached_or_render {
}
sub get {
sub get($$) {
my $config = shift;
my $request = shift;
@@ -99,7 +91,7 @@ sub get {
return $results;
}
sub get_query {
sub get_query($$$) {
my $dbh = shift;
my $config = shift;
my $request = shift;
@@ -150,8 +142,9 @@ sub get_query {
}
my $dbcols = [
'id', 'event_start', 'event_id', 'content', 'ip', 'author', 'email', 'lock_status',
'created_at', 'title', 'parent_id', 'level', 'news_status', 'project'
'id', 'event_start', 'event_id', 'content', 'ip', 'author',
'email', 'lock_status', 'created_at', 'title', 'parent_id', 'level',
'news_status', 'project'
];
my $cols = join( ', ', map { 'c.' . $_ } @$dbcols );
my $query = qq{
@@ -168,7 +161,7 @@ sub get_query {
return ( \$query, $bind_values );
}
sub modify_results {
sub modify_results($$$) {
my $results = $_[0];
my $config = $_[1];
my $request = $_[2];
@@ -204,11 +197,12 @@ sub modify_results {
$result->{content} = markup::html_to_plain( $result->{html_content} );
$result->{short_content} = markup::html_to_plain( $result->{short_content} );
$result->{excerpt} = "lass dich ueberraschen" if ( defined $result->{excerpt} ) && ( $result->{excerpt} eq '' );
$result->{excerpt} = markup::html_to_plain( $result->{excerpt} );
$result->{title} = markup::html_to_plain( $result->{title} );
$result->{series_name} = markup::html_to_plain( $result->{series_name} );
$result->{program} = markup::html_to_plain( $result->{program} );
$result->{excerpt} = "lass dich ueberraschen"
if ( defined $result->{excerpt} ) && ( $result->{excerpt} eq '' );
$result->{excerpt} = markup::html_to_plain( $result->{excerpt} );
$result->{title} = markup::html_to_plain( $result->{title} );
$result->{series_name} = markup::html_to_plain( $result->{series_name} );
$result->{program} = markup::html_to_plain( $result->{program} );
if ( defined $result->{created_at} ) {
$result->{created_at} =~ s/ /T/gi;
@@ -224,7 +218,7 @@ sub modify_results {
return $results;
}
sub render {
sub render($$$$) {
# my $response =$_[0];
my $config = $_[1];
@@ -244,14 +238,15 @@ sub render {
$template_parameters->{event_id} = $params->{event_id};
$template_parameters->{event_start} = $params->{event_start};
$template_parameters->{server_cache} = $config->{cache}->{server_cache} if ( $config->{cache}->{server_cache} );
$template_parameters->{use_client_cache} = $config->{cache}->{use_client_cache} if ( $config->{cache}->{use_client_cache} );
$template_parameters->{controllers} = $config->{controllers};
$template_parameters->{server_cache} = $config->{cache}->{server_cache} if ( $config->{cache}->{server_cache} );
$template_parameters->{use_client_cache} = $config->{cache}->{use_client_cache}
if ( $config->{cache}->{use_client_cache} );
$template_parameters->{controllers} = $config->{controllers};
template::process( $config, $_[0], $params->{template}, $template_parameters );
}
#check if comment exists already
sub check {
sub check ($$$) {
my $dbh = shift;
my $config = shift;
my $comment = shift;
@@ -268,8 +263,10 @@ sub check {
and ip=?
and content=?
};
my $bind_values =
[ $comment->{event_start}, $comment->{event_id}, $comment->{parent_id}, $comment->{author}, $comment->{ip}, $comment->{content} ];
my $bind_values = [
$comment->{event_start}, $comment->{event_id}, $comment->{parent_id},
$comment->{author}, $comment->{ip}, $comment->{content}
];
my $comments = db::get( $dbh, $query, $bind_values );
@@ -279,7 +276,7 @@ sub check {
}
#used for insert
sub get_level {
sub get_level($$$) {
my $dbh = shift;
my $config = shift;
my $comment = shift;
@@ -314,7 +311,7 @@ sub get_level {
return 0;
}
sub get_by_event {
sub get_by_event($$$) {
my $dbh = shift;
my $config = shift;
my $request = $_[0];
@@ -359,7 +356,7 @@ sub get_by_event {
return $comments;
}
sub get_by_time {
sub get_by_time($$$) {
my $dbh = shift;
my $config = shift;
my $comment = shift;
@@ -398,7 +395,7 @@ sub get_by_time {
return $comments;
}
sub get_events {
sub get_events($$$$) {
my $dbh = shift;
my $config = shift;
my $request = shift;
@@ -465,7 +462,7 @@ sub get_events {
return \@sorted_events;
}
sub insert {
sub insert ($$$) {
my $dbh = shift;
my $config = shift;
my $comment = shift;
@@ -488,7 +485,7 @@ sub insert {
return $comment_id;
}
sub set_lock_status {
sub set_lock_status ($$$) {
my $dbh = shift;
my $config = shift;
my $comment = shift;
@@ -516,7 +513,7 @@ sub set_lock_status {
}
}
sub set_news_status {
sub set_news_status($$$) {
my $dbh = shift;
my $config = shift;
my $comment = shift;
@@ -532,7 +529,7 @@ sub set_news_status {
db::put( $dbh, $query, $bind_values );
}
sub update_comment_count {
sub update_comment_count ($$$) {
my $dbh = shift;
my $config = shift;
my $comment = shift;
@@ -557,8 +554,26 @@ sub update_comment_count {
db::put( $dbh, $query, $bind_values );
}
sub sort_childs {
my $node = shift;
my $nodes = shift;
my $sorted_nodes = shift;
#push node into list of sorted nodes
push @{$sorted_nodes}, $node;
#return if node is leaf
return $sorted_nodes unless ( defined $node->{childs} );
#process child nodes
for my $child ( @{ $node->{childs} } ) {
$sorted_nodes = sort_childs( $child, $nodes, $sorted_nodes );
}
return $sorted_nodes;
}
#precondition: results are presorted by creation date (by sql)
sub sort {
sub sort($$) {
my $config = shift;
my $results = shift;
@@ -589,44 +604,15 @@ sub sort {
return $sorted_nodes;
}
sub sort_childs {
my $node = shift;
my $nodes = shift;
my $sorted_nodes = shift;
#push node into list of sorted nodes
push @{$sorted_nodes}, $node;
#return if node is leaf
return $sorted_nodes unless ( defined $node->{childs} );
#process child nodes
for my $child ( @{ $node->{childs} } ) {
$sorted_nodes = sort_childs( $child, $nodes, $sorted_nodes );
}
return $sorted_nodes;
}
sub configure_cache {
my $config = shift;
cache::init();
my $controllers = $config->{controllers};
cache::add_map( 'template=comments_newest&limit=3&type=list', $controllers->{comments} . '/neueste.html' );
cache::add_map( 'template=comments_atom.xml&limit=20', $controllers->{comments} . '/feed.xml' );
cache::add_map( 'template=comments.html&event_id=(\d+)&event_start=' . cache::get_datetime_pattern(),
$controllers->{comments} . '/$1_$2-$3-$4_$5-$6.html' );
}
sub check_params {
my $config = shift;
my $params = shift;
sub check_params ($$) {
my $config = shift;
my $params = shift;
my $comment = {};
$comment->{event_start} = '';
if ( ( defined $params->{event_start} ) && ( $params->{event_start} =~ /(\d\d\d\d\-\d\d\-\d\d[T ]\d\d\:\d\d)(\:\d\d)?/ ) ) {
if ( ( defined $params->{event_start} )
&& ( $params->{event_start} =~ /(\d\d\d\d\-\d\d\-\d\d[T ]\d\d\:\d\d)(\:\d\d)?/ ) )
{
$comment->{event_start} = $1;
}
@@ -665,9 +651,10 @@ sub check_params {
$comment->{debug} = $1;
}
log::error( $config, 'missing parameter a' ) if ( defined $params->{limit} ) && ( $comment->{limit} eq '' );
log::error( $config, 'missing parameter b' ) if ( defined $params->{event_id} ) && ( $comment->{event_id} eq '' );
log::error( $config, 'missing parameter c' ) if ( defined $params->{event_start} ) && ( $comment->{event_start} eq '' );
log::error( $config, 'missing parameter a' ) if ( defined $params->{limit} ) && ( $comment->{limit} eq '' );
log::error( $config, 'missing parameter b' ) if ( defined $params->{event_id} ) && ( $comment->{event_id} eq '' );
log::error( $config, 'missing parameter c' )
if ( defined $params->{event_start} ) && ( $comment->{event_start} eq '' );
my $delta_days = 1;
if ( $comment->{event_start} ne '' ) {
@@ -690,3 +677,4 @@ sub check_params {
#do not delete last line!
1;

7
lib/calcms/config.pm
View File

@@ -1,7 +1,8 @@
package config;
use warnings;
use strict;
use warnings;
no warnings 'redefine';
use FindBin();
use Config::General();
@@ -11,13 +12,13 @@ our @EXPORT_OK = qw(get set);
my $config = undef;
sub set {
sub set($) {
my $value = shift;
$config = $value;
return;
}
sub get {
sub get($) {
my $filename = shift;
return $config if ( defined $config ) && ( $config->{cache}->{cache_config} == 1 );

11
lib/calcms/creole_wiki.pm
View File

@@ -1,7 +1,8 @@
package creole_wiki;
use warnings;
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use markup();
@@ -10,7 +11,7 @@ use base 'Exporter';
our @EXPORT_OK = qw(extractEventFromWikiText removeMeta eventToWikiText extractMeta removeMeta metaToWiki);
#convert creole wiki text to event
sub extractEventFromWikiText {
sub extractEventFromWikiText($;$) {
my $params = shift;
my $event = shift;
$event = {} unless ( defined $event );
@@ -134,7 +135,7 @@ sub extractEventFromWikiText {
return $event;
}
sub eventToWikiText {
sub eventToWikiText($$) {
my $event = shift;
my $local_media_url = $event->{local_media_url} || '';
@@ -195,7 +196,7 @@ sub eventToWikiText {
}
#extrace meta tags from comment text
sub extractMeta {
sub extractMeta ($$){
my $comments = shift;
my $meta = shift;
@@ -236,7 +237,7 @@ sub extractMeta {
}
#remove meta tags from comment text
sub removeMeta {
sub removeMeta($) {
my $comments = shift || '';
my $result = '';

27
lib/calcms/db.pm
View File

@@ -1,7 +1,8 @@
package db;
use warnings 'all';
use strict;
use warnings;
no warnings 'redefine';
use DBD::mysql();
use Data::Dumper;
@@ -26,7 +27,7 @@ our $read = 1;
our $write = 1;
# connect to database
sub connect {
sub connect($;$) {
my $options = shift;
my $request = shift;
@@ -62,7 +63,7 @@ sub connect {
return $dbh;
}
sub disconnect {
sub disconnect ($){
my $request = shift;
my $dbh = $request->{connection};
$dbh->disconnect;
@@ -71,7 +72,7 @@ sub disconnect {
}
# get all database entries of an sql query (as list of hashs)
sub get {
sub get($$;$) {
my $dbh = shift;
my $sql = shift;
my $bind_values = shift;
@@ -105,7 +106,7 @@ sub get {
}
# get list of table columns
sub get_columns {
sub get_columns($$) {
my $dbh = shift;
my $table = shift;
@@ -115,7 +116,7 @@ sub get_columns {
}
# get hash with table columns as keys
sub get_columns_hash {
sub get_columns_hash($$) {
my $dbh = shift;
my $table = shift;
@@ -128,7 +129,7 @@ sub get_columns_hash {
}
#returns last inserted id
sub insert {
sub insert ($$$){
my $dbh = shift;
my $tablename = shift;
my $entry = shift;
@@ -151,7 +152,7 @@ sub insert {
}
# execute a modifying database command (update,insert,...)
sub put {
sub put($$$) {
my $dbh = shift;
my $sql = shift;
my $bind_values = shift;
@@ -177,7 +178,7 @@ sub put {
return undef;
}
sub quote {
sub quote($$) {
my $dbh = shift;
my $sql = shift;
@@ -186,7 +187,7 @@ sub quote {
}
#subtract hours, deprecated(!)
sub shift_date_by_hours {
sub shift_date_by_hours($$$) {
my $dbh = shift;
my $date = shift;
my $offset = shift;
@@ -198,7 +199,7 @@ sub shift_date_by_hours {
}
#add minutes, deprecated(!)
sub shift_datetime_by_minutes {
sub shift_datetime_by_minutes($$$) {
my $dbh = shift;
my $datetime = shift;
my $offset = shift;
@@ -210,7 +211,7 @@ sub shift_datetime_by_minutes {
}
# get next free id of a database table
sub next_id {
sub next_id ($$){
my $dbh = shift;
my $table = shift;
@@ -224,7 +225,7 @@ sub next_id {
}
# get max id from table
sub get_max_id {
sub get_max_id($$) {
my $dbh = shift;
my $table = shift;

18
lib/calcms/eventOps.pm
View File

@@ -1,6 +1,8 @@
package eventOps;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use uac();
use events();
@@ -21,7 +23,7 @@ our @EXPORT_OK = qw(
);
# functions: to be separated
sub setAttributesFromSeriesTemplate {
sub setAttributesFromSeriesTemplate($$$) {
my $config = shift;
my $params = shift;
my $event = shift;
@@ -54,7 +56,7 @@ sub setAttributesFromSeriesTemplate {
return $serie;
}
sub setAttributesFromSchedule {
sub setAttributesFromSchedule ($$$){
my $config = shift;
my $params = shift;
my $event = shift;
@@ -87,7 +89,7 @@ sub setAttributesFromSchedule {
return $event;
}
sub setAttributesFromOtherEvent {
sub setAttributesFromOtherEvent ($$$){
my $config = shift;
my $params = shift;
my $event = shift;
@@ -119,7 +121,7 @@ sub setAttributesFromOtherEvent {
return $event;
}
sub setAttributesForCurrentTime {
sub setAttributesForCurrentTime ($$){
my $serie = shift;
my $event = shift;
@@ -138,14 +140,14 @@ sub setAttributesForCurrentTime {
}
# get recurrence base id
sub getRecurrenceBaseId {
sub getRecurrenceBaseId ($){
my $event = shift;
return $event->{recurrence} if ( defined $event->{recurrence} ) && ( $event->{recurrence} ne '' ) && ( $event->{recurrence} ne '0' );
return $event->{event_id};
}
# get a new event for given series
sub getNewEvent {
sub getNewEvent($$$) {
my $config = shift;
my $params = shift;
my $action = shift;
@@ -205,7 +207,7 @@ sub getNewEvent {
}
# add user, action
sub createEvent {
sub createEvent($$$) {
my $request = shift;
my $event = shift;
my $action = shift;

17
lib/calcms/event_history.pm
View File

@@ -1,7 +1,8 @@
package event_history;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
@@ -10,7 +11,7 @@ our @EXPORT_OK = qw(get_columns get get_by_id insert insert_by_event_id delete
sub debug;
sub get_columns {
sub get_columns ($){
my $config = shift;
my $dbh = db::connect($config);
@@ -22,7 +23,7 @@ sub get_columns {
return $columns;
}
sub get {
sub get ($$){
my $config = shift;
my $condition = shift;
@@ -85,7 +86,7 @@ sub get {
return $changes;
}
sub get_by_id {
sub get_by_id($$) {
my $config = shift;
my $id = shift;
@@ -102,7 +103,7 @@ sub get_by_id {
return $studios->[0];
}
sub insert {
sub insert($$) {
my $config = shift;
my $entry = shift;
@@ -124,7 +125,7 @@ sub insert {
}
# insert event
sub insert_by_event_id {
sub insert_by_event_id ($$){
my $config = shift;
my $options = shift;
@@ -157,7 +158,7 @@ sub insert_by_event_id {
event_history::insert( $config, $event );
}
sub delete {
sub delete ($$){
my $config = shift;
my $entry = shift;
@@ -165,7 +166,7 @@ sub delete {
db::put( $dbh, 'delete from calcms_event_history where event_id=?', [ $entry->{id} ] );
}
sub error {
sub error ($){
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

140
lib/calcms/events.pm
View File

@@ -1,7 +1,8 @@
package events;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use DBI();
@@ -10,7 +11,7 @@ use template();
use config();
use time();
use db();
use cache();
use markup();
use log();
use project();
@@ -37,7 +38,7 @@ our @EXPORT_OK = qw(
sub init {
}
sub get_cached_or_render {
sub get_cached_or_render($$$) {
# my $response=$_[0];
my $config = $_[1];
@@ -46,31 +47,13 @@ sub get_cached_or_render {
my $params = $request->{params}->{checked};
my $debug = $config->{system}->{debug};
my $cache = {};
if ( $config->{cache}->{use_cache} == 1 ) {
events::configure_cache($config);
$cache = cache::load( $config, $params );
if ( defined $cache->{content} ) {
$_[0] = $cache->{content};
return;
}
}
my $results = events::get( $config, $request );
events::render( $_[0], $config, $request, $results );
#write to cache
if ( $config->{cache}->{use_cache} == 1 ) {
#todo:put out reference only
$cache->{content} = $_[0];
cache::save($cache);
}
return $_[0];
}
sub get {
sub get($$) {
my $config = shift;
my $request = shift;
@@ -92,7 +75,7 @@ sub get {
return $results;
}
sub modify_results {
sub modify_results ($$$$) {
my $dbh = shift;
my $config = shift;
my $request = shift;
@@ -242,14 +225,14 @@ sub modify_results {
$result->{one_comment} = 1 if ( $result->{comment_count} == 1 );
$result->{no_comment} = 1 if ( $result->{comment_count} == 0 );
#fix image url
#$params->{exclude_event_images}=0 unless defined $params->{exclude_event_images};
#if ($params->{exclude_event_images}==1){
# if ( (defined $config->{permissions}->{hide_event_images}) && ($config->{permissions}->{hide_event_images} eq '1') ){
# $result->{image} = $result->{series_image};
# $result->{image_label} = $result->{series_image_label};
# }
#}
#fix image url
#$params->{exclude_event_images}=0 unless defined $params->{exclude_event_images};
#if ($params->{exclude_event_images}==1){
# if ( (defined $config->{permissions}->{hide_event_images}) && ($config->{permissions}->{hide_event_images} eq '1') ){
# $result->{image} = $result->{series_image};
# $result->{image_label} = $result->{series_image_label};
# }
#}
if ( defined $result->{image} ) {
my $url = $config->{locations}->{local_media_url} || '';
@@ -504,7 +487,8 @@ sub calc_dates {
if ( ( defined $params->{template} )
&& ( $params->{template} =~ /(\.xml)/ ) )
{
$result->{start_datetime_utc} = time::datetime_to_utc_datetime( $result->{start_datetime}, $config->{date}->{time_zone} );
$result->{start_datetime_utc} =
time::datetime_to_utc_datetime( $result->{start_datetime}, $config->{date}->{time_zone} );
}
$result->{end_datetime} = $result->{end};
@@ -521,7 +505,8 @@ sub calc_dates {
if ( ( defined $params->{template} )
&& ( $params->{template} =~ /(\.xml)/ ) )
{
$result->{end_datetime_utc} = time::datetime_to_utc_datetime( $result->{end_datetime}, $config->{date}->{time_zone} );
$result->{end_datetime_utc} =
time::datetime_to_utc_datetime( $result->{end_datetime}, $config->{date}->{time_zone} );
}
if ( ( defined $previous_result )
@@ -550,15 +535,15 @@ sub calc_dates {
if ( defined $result->{weekday} ) {
my $language = $config->{date}->{language} || 'en';
my $weekdayIndex = time::getWeekdayIndex($result->{weekday}) || 0;
$result->{weekday_name} = time::getWeekdayNames($language)->[$weekdayIndex];
my $weekdayIndex = time::getWeekdayIndex( $result->{weekday} ) || 0;
$result->{weekday_name} = time::getWeekdayNames($language)->[$weekdayIndex];
$result->{weekday_short_name} = time::getWeekdayNamesShort($language)->[$weekdayIndex];
}
return $result;
}
sub add_recordings {
sub add_recordings($$$$) {
my $dbh = shift;
my $config = shift;
my $request = shift;
@@ -606,7 +591,7 @@ sub add_recordings {
return $events;
}
sub getDateQueryConditions {
sub getDateQueryConditions ($$$) {
my $config = shift;
my $params = shift;
my $bind_values = shift;
@@ -770,7 +755,7 @@ sub getDateQueryConditions {
}
# if recordings is set in params, recordings date and path will be included
sub get_query {
sub get_query($$$) {
my $dbh = shift;
my $config = shift;
my $request = shift;
@@ -1130,7 +1115,7 @@ sub get_query {
return ( \$query, $bind_values );
}
sub render {
sub render($$$$;$) {
# my $response = $_[0];
my $config = $_[1];
@@ -1220,7 +1205,8 @@ sub render {
$template_parameters->{controllers} = $config->{controllers};
$template_parameters->{hide_event_images} = 1
if ( defined $config->{permissions}->{hide_event_images} ) && ( $config->{permissions}->{hide_event_images} == 1 );
if ( defined $config->{permissions}->{hide_event_images} )
&& ( $config->{permissions}->{hide_event_images} == 1 );
# use Data::Dumper;print STDERR Dumper($template_parameters)."\n";
template::process( $config, $_[0], $params->{template}, $template_parameters );
@@ -1228,7 +1214,7 @@ sub render {
return $_[0];
}
sub get_running_event_id {
sub get_running_event_id($) {
my $dbh = shift;
my $query = qq{
@@ -1255,7 +1241,7 @@ sub get_running_event_id {
}
# add filters to query
sub setDefaultEventConditions {
sub setDefaultEventConditions ($$$$) {
my $config = shift;
my $conditions = $_[0];
my $bind_values = $_[1];
@@ -1293,7 +1279,7 @@ sub setDefaultEventConditions {
}
# for local use only or add support for exclude_projects and exclude_locations
sub getEventById {
sub getEventById ($$$$) {
my $dbh = shift;
my $config = shift;
my $event_id = shift;
@@ -1320,7 +1306,7 @@ sub getEventById {
return $events;
}
sub get_next_event_of_series {
sub get_next_event_of_series ($$$) {
my $dbh = shift;
my $config = shift;
my $options = shift;
@@ -1360,7 +1346,7 @@ sub get_next_event_of_series {
return $events->[0]->{id};
}
sub get_previous_event_of_series {
sub get_previous_event_of_series($$$) {
my $dbh = shift;
my $config = shift;
my $options = shift;
@@ -1398,7 +1384,7 @@ sub get_previous_event_of_series {
}
# used by calendar
sub get_by_date_range {
sub get_by_date_range ($$$$$) {
my $dbh = shift;
my $config = shift;
my $start_date = shift;
@@ -1423,7 +1409,8 @@ sub get_by_date_range {
$conditions = join( ' and ', @$conditions );
my $select = qq{distinct date(start) 'start_date'};
$select = qq{distinct date(DATE_SUB(start, INTERVAL $day_starting_hour HOUR)) 'start_date'} if defined $day_starting_hour;
$select = qq{distinct date(DATE_SUB(start, INTERVAL $day_starting_hour HOUR)) 'start_date'}
if defined $day_starting_hour;
my $query = qq{
select $select
@@ -1438,7 +1425,7 @@ sub get_by_date_range {
return $events;
}
sub get_by_image {
sub get_by_image ($$$) {
my $dbh = shift;
my $config = shift;
my $filename = shift;
@@ -1462,7 +1449,7 @@ sub get_by_image {
}
# deleting an event is currently disabled
sub delete {
sub delete ($$$) {
return;
my $request = shift;
my $config = shift;
@@ -1487,51 +1474,7 @@ sub delete {
}
#TODO: add location to cache map
sub configure_cache {
my $config = shift;
my $debug = $config->{system}->{debug};
my $date_pattern = cache::get_date_pattern();
my $controllers = $config->{controllers};
cache::init();
cache::add_map( '', 'index.html' );
my $name = '';
my $extension = '';
my $templates = $config->{templates}->{events};
for my $template (@$templates) {
if ( $template =~ /^(.+)\.([^\.]+)$/ ) {
$name = $1;
$extension = $2;
}
cache::add_map( 'template=' . $template, $controllers->{events} . '/' . $name . '.' . $extension );
cache::add_map( 'template=' . $template . '&date=today', $controllers->{events} . '/' . $template . '_today.' . $extension );
cache::add_map( 'template=' . $template . '&date=' . $date_pattern,
$controllers->{events} . '/' . $name . '_date_$1-$2-$3.' . $extension );
cache::add_map( 'template=' . $template . '&time=now', $controllers->{events} . '/' . $template . '_now.html' );
cache::add_map( 'template=' . $template . '&time=now&limit=(\d+)',
$controllers->{events} . '/' . $name . '_now_limit_$1.' . $extension );
cache::add_map(
'template=' . $template . '&from_date=' . $date_pattern . '&till_date=' . $date_pattern,
$controllers->{events} . '/' . $name . '_from_$1-$2-$3_till_$4_$5_$6.' . $extension
);
cache::add_map(
'template=' . $template . '&from_date=' . $date_pattern . '&till_date=' . $date_pattern . '&weekday=(\d)',
$controllers->{events} . '/' . $template . '_from_$1-$2-$3_till_$4_$5_$6_weekday_$7.' . $extension
);
cache::add_map(
'template=' . $template . '&from_date=' . $date_pattern . '&till_date=' . $date_pattern . '&limit=(\d)',
$controllers->{events} . '/' . $template . '_from_$1-$2-$3_till_$4_$5_$6_limit_$7.' . $extension
);
cache::add_map( 'template=' . $template . '&weekday=(\d)', $controllers->{events} . '/' . $name . '_weekday_$1.' . $extension );
cache::add_map( 'template=' . $template . '&event_id=(\d+)', $controllers->{event} . '/' . $name . '_page_$1.' . $extension );
}
}
sub get_duration {
sub get_duration ($$) {
my $config = shift;
my $event = shift;
my $timezone = $config->{date}->{time_zone};
@@ -1548,7 +1491,7 @@ sub get_duration {
return $duration / 60;
}
sub check_params {
sub check_params ($$) {
my $config = shift;
my $params = shift;
@@ -1679,7 +1622,8 @@ sub check_params {
$exclude_projects = 1 if ( defined $params->{exclude_projects} ) && ( $params->{exclude_projects} eq '1' );
my $exclude_event_images = 0;
$exclude_event_images = 1 if ( defined $params->{exclude_event_images} ) && ( $params->{exclude_event_images} eq '1' );
$exclude_event_images = 1
if ( defined $params->{exclude_event_images} ) && ( $params->{exclude_event_images} eq '1' );
#show future events by default
my $archive = 'future';
@@ -1826,7 +1770,7 @@ sub check_params {
return $checked;
}
sub get_keys {
sub get_keys($) {
my $event = shift;
my $program = $event->{program} || '';

760
lib/calcms/images.pm
View File

@@ -1,7 +1,8 @@
package images;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use config();
use template();
@@ -12,74 +13,77 @@ our @EXPORT_OK = qw(get insert update insert_or_update delete delete_files);
#column 'created_at' will be set at insert
#column 'modified_at' will be set by default (do not update)
my $sql_columns =
[ 'filename', 'name', 'description', 'created_by', 'modified_by', 'modified_at', 'studio_id', 'project_id', 'public', 'licence' ];
my $sql_columns = [
'filename', 'name', 'description', 'created_by', 'modified_by', 'modified_at',
'studio_id', 'project_id', 'public', 'licence'
];
sub get {
my $config = shift;
my $options = shift;
sub get($$) {
my $config = shift;
my $options = shift;
my @cond = ();
my $bind_values = [];
if ( ( defined $options->{project_id} ) && ( $options->{project_id} ne '' ) ) {
push @cond, 'project_id = ?';
push @$bind_values, $options->{project_id};
}
if ( ( defined $options->{studio_id} ) && ( $options->{studio_id} ne '' ) ) {
push @cond, 'studio_id = ?';
push @$bind_values, $options->{studio_id};
}
if ( ( defined $options->{filename} ) && ( $options->{filename} ne '' ) ) {
push @cond, 'filename = ?';
push @$bind_values, $options->{filename};
}
if ( ( defined $options->{from} ) && ( $options->{from} ne '' ) ) {
push @cond, 'date(created_at) >= ?';
push @$bind_values, $options->{from};
}
if ( ( defined $options->{till} ) && ( $options->{till} ne '' ) ) {
push @cond, 'date(created_at) <= ?';
push @$bind_values, $options->{till};
}
if ( ( defined $options->{created_by} ) && ( $options->{created_by} ne '' ) ) {
push @cond, 'created_by = ?';
push @$bind_values, $options->{created_by};
}
if ( ( defined $options->{modified_by} ) && ( $options->{modified_by} ne '' ) ) {
push @cond, 'modified_by = ?';
push @$bind_values, $options->{modified_by};
}
if ( ( defined $options->{licence} ) && ( $options->{licence} ne '' ) ) {
push @cond, 'licence = ?';
push @$bind_values, $options->{licence};
}
if ( ( defined $options->{public} ) && ( $options->{public} ne '' ) ) {
push @cond, 'public = ?';
push @$bind_values, $options->{public};
}
my @cond = ();
my $bind_values = [];
if ( ( defined $options->{project_id} ) && ( $options->{project_id} ne '' ) ) {
push @cond, 'project_id = ?';
push @$bind_values, $options->{project_id};
}
if ( ( defined $options->{studio_id} ) && ( $options->{studio_id} ne '' ) ) {
push @cond, 'studio_id = ?';
push @$bind_values, $options->{studio_id};
}
if ( ( defined $options->{filename} ) && ( $options->{filename} ne '' ) ) {
push @cond, 'filename = ?';
push @$bind_values, $options->{filename};
}
if ( ( defined $options->{from} ) && ( $options->{from} ne '' ) ) {
push @cond, 'date(created_at) >= ?';
push @$bind_values, $options->{from};
}
if ( ( defined $options->{till} ) && ( $options->{till} ne '' ) ) {
push @cond, 'date(created_at) <= ?';
push @$bind_values, $options->{till};
}
if ( ( defined $options->{created_by} ) && ( $options->{created_by} ne '' ) ) {
push @cond, 'created_by = ?';
push @$bind_values, $options->{created_by};
}
if ( ( defined $options->{modified_by} ) && ( $options->{modified_by} ne '' ) ) {
push @cond, 'modified_by = ?';
push @$bind_values, $options->{modified_by};
}
if ( ( defined $options->{licence} ) && ( $options->{licence} ne '' ) ) {
push @cond, 'licence = ?';
push @$bind_values, $options->{licence};
}
if ( ( defined $options->{public} ) && ( $options->{public} ne '' ) ) {
push @cond, 'public = ?';
push @$bind_values, $options->{public};
}
if ( ( defined $options->{search} ) && ( $options->{search} ne '' ) ) {
push @cond, '(filename like ?' . ' or name like ?' . ' or description like ?' . ' or created_by like ?' . ')';
my $search = '%' . $options->{search} . '%';
push @$bind_values, $search;
push @$bind_values, $search;
push @$bind_values, $search;
push @$bind_values, $search;
if ( ( defined $options->{search} ) && ( $options->{search} ne '' ) ) {
push @cond,
'(filename like ?' . ' or name like ?' . ' or description like ?' . ' or created_by like ?' . ')';
my $search = '%' . $options->{search} . '%';
push @$bind_values, $search;
push @$bind_values, $search;
push @$bind_values, $search;
push @$bind_values, $search;
# push @$bind_values,$search;
}
# push @$bind_values,$search;
}
my $where = '';
if ( @cond > 0 ) {
$where = 'where ' . join( ' and ', @cond );
}
my $where = '';
if ( @cond > 0 ) {
$where = 'where ' . join( ' and ', @cond );
}
my $limit = '';
if ( ( defined $options->{limit} ) && ( $options->{limit} =~ /(\d+)/ ) ) {
$limit = ' limit ' . $1;
}
my $limit = '';
if ( ( defined $options->{limit} ) && ( $options->{limit} =~ /(\d+)/ ) ) {
$limit = ' limit ' . $1;
}
my $query = qq{
my $query = qq{
select *
from calcms_images
$where
@@ -87,445 +91,453 @@ sub get {
$limit
};
#print STDERR Dumper($query).Dumper($bind_values);
#print STDERR Dumper($query).Dumper($bind_values);
my $dbh = db::connect($config);
my $results = db::get( $dbh, $query, $bind_values );
my $dbh = db::connect($config);
my $results = db::get( $dbh, $query, $bind_values );
#print STDERR @$results."\n";
return $results;
#print STDERR @$results."\n";
return $results;
}
sub insert_or_update {
my $dbh = shift;
my $image = shift;
sub insert_or_update($$) {
my $dbh = shift;
my $image = shift;
$image->{name} = 'new' if $image->{name} eq '';
my $entry = get_by_filename( $dbh, $image->{filename} );
if ( defined $entry ) {
update( $dbh, $image );
} else {
insert( $dbh, $image );
}
$image->{name} = 'new' if $image->{name} eq '';
my $entry = get_by_filename( $dbh, $image->{filename} );
if ( defined $entry ) {
update( $dbh, $image );
} else {
insert( $dbh, $image );
}
}
sub insert {
my $dbh = shift;
my $image = shift;
sub insert ($$) {
my $dbh = shift;
my $image = shift;
my @sql_columns = @$sql_columns;
my @sql_columns = @$sql_columns;
#set created at timestamp
push @sql_columns, 'created_at';
$image->{created_at} = time::time_to_datetime();
#set created at timestamp
push @sql_columns, 'created_at';
$image->{created_at} = time::time_to_datetime();
unless ( defined $image->{created_by} ) {
print STDERR "missing created_by at image::insert\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at image::insert\n";
return undef;
}
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at image::insert\n";
return undef;
}
unless ( defined $image->{created_by} ) {
print STDERR "missing created_by at image::insert\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at image::insert\n";
return undef;
}
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at image::insert\n";
return undef;
}
for my $attr ('public') {
$image->{$attr} = 0 unless ( defined $image->{$attr} ) && ( $image->{$attr} eq '1' );
}
for my $attr ('public') {
$image->{$attr} = 0 unless ( defined $image->{$attr} ) && ( $image->{$attr} eq '1' );
}
my $query = q{
my $query = q{
insert into calcms_images(
} . join( ',', @sql_columns ) . qq{
)
values( } . join( ', ', ( map { '?' } @sql_columns ) ) . q{ )
};
my @bind_values = map { $image->{$_} } @sql_columns;
my @bind_values = map { $image->{$_} } @sql_columns;
#print STDERR Dumper($query).Dumper(\@bind_values);
my $result = db::put( $dbh, $query, \@bind_values );
#print STDERR Dumper($query).Dumper(\@bind_values);
my $result = db::put( $dbh, $query, \@bind_values );
images::setSeriesLabels( $dbh, $image );
images::setEventLabels( $dbh, $image );
images::setSeriesLabels( $dbh, $image );
images::setEventLabels( $dbh, $image );
return $result;
return $result;
}
sub update {
my $dbh = shift;
my $image = shift;
sub update($$) {
my $dbh = shift;
my $image = shift;
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::update\n";
return undef;
}
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at image::update\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at image::update\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::update\n";
return undef;
}
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at image::update\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at image::update\n";
return undef;
}
$image->{modified_at} = time::time_to_datetime();
$image->{modified_at} = time::time_to_datetime();
for my $attr ('public') {
$image->{$attr} = 0 unless ( defined $image->{$attr} ) && ( $image->{$attr} eq '1' );
}
for my $attr ('public') {
$image->{$attr} = 0 unless ( defined $image->{$attr} ) && ( $image->{$attr} eq '1' );
}
my @set = ();
my $bind_values = [];
for my $column (@$sql_columns) {
if ( defined $image->{$column} ) {
push @set, $column . ' = ?';
push @$bind_values, $image->{$column};
}
}
my @set = ();
my $bind_values = [];
for my $column (@$sql_columns) {
if ( defined $image->{$column} ) {
push @set, $column . ' = ?';
push @$bind_values, $image->{$column};
}
}
#conditions
my $conditions = ['filename=?'];
push @$bind_values, $image->{filename};
#conditions
my $conditions = ['filename=?'];
push @$bind_values, $image->{filename};
push @$conditions, 'project_id=?';
push @$bind_values, $image->{project_id} || 0;
push @$conditions, 'project_id=?';
push @$bind_values, $image->{project_id} || 0;
push @$conditions, 'studio_id=?';
push @$bind_values, $image->{studio_id} || 0;
push @$conditions, 'studio_id=?';
push @$bind_values, $image->{studio_id} || 0;
return if ( @set == 0 );
return if ( @set == 0 );
my $set = join( ",", @set );
$conditions = join( ' and ', @$conditions );
my $query = qq{
my $set = join( ",", @set );
$conditions = join( ' and ', @$conditions );
my $query = qq{
update calcms_images
set $set
where $conditions
};
#print STDERR Dumper($query) . Dumper($bind_values);
my $result = db::put( $dbh, $query, $bind_values );
images::setSeriesLabels( $dbh, $image );
images::setEventLabels( $dbh, $image );
#print STDERR Dumper($query) . Dumper($bind_values);
my $result = db::put( $dbh, $query, $bind_values );
return $result;
images::setSeriesLabels( $dbh, $image );
images::setEventLabels( $dbh, $image );
return $result;
}
sub delete {
my $dbh = shift;
my $image = shift;
sub delete($$) {
my $dbh = shift;
my $image = shift;
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at images::delete\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::delete\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at images::delete\n";
return undef;
}
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at images::delete\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::delete\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at images::delete\n";
return undef;
}
my $project_id = $image->{project_id};
my $studio_id = $image->{studio_id};
my $filename = $image->{filename};
my $project_id = $image->{project_id};
my $studio_id = $image->{studio_id};
my $filename = $image->{filename};
my $conditions = ['filename=?'];
my $bind_values = [$filename];
my $conditions = ['filename=?'];
my $bind_values = [$filename];
push @$conditions, 'project_id=?';
push @$bind_values, $studio_id;
push @$conditions, 'project_id=?';
push @$bind_values, $studio_id;
push @$conditions, 'studio_id=?';
push @$bind_values, $project_id;
push @$conditions, 'studio_id=?';
push @$bind_values, $project_id;
$conditions = join( ' and ', @$conditions );
my $query = qq{
$conditions = join( ' and ', @$conditions );
my $query = qq{
delete from calcms_images
where $conditions
};
#print STDERR Dumper($query).Dumper($bind_values);
return db::put( $dbh, $query, $bind_values );
#print STDERR Dumper($query).Dumper($bind_values);
return db::put( $dbh, $query, $bind_values );
}
# deactivated
sub delete_files {
my $config = $_[0];
my $local_media_dir = $_[1];
my $filename = $_[2];
my $action_result = $_[3];
my $errors = $_[4];
sub delete_files($$$$$) {
my $config = $_[0];
my $local_media_dir = $_[1];
my $filename = $_[2];
my $action_result = $_[3];
my $errors = $_[4];
return undef;
return undef;
print log::error( $config, 'missing permissions on writing into local media dir' ) unless ( -w $local_media_dir );
print log::error( $config, 'missing permissions on writing into local media dir' ) unless ( -w $local_media_dir );
if ( $filename =~ /[^a-zA-Z0-9\.\_\-]/ ) {
log::error( $config, "invalid filename: '$filename'" );
return;
}
if ( $filename =~ /\.\./ || $filename =~ /^\// || $filename =~ /\// ) {
log::error( $config, "invalid filename: '$filename'" );
return;
}
if ( $filename =~ /[^a-zA-Z0-9\.\_\-]/ ) {
log::error( $config, "invalid filename: '$filename'" );
return;
}
if ( $filename =~ /\.\./ || $filename =~ /^\// || $filename =~ /\// ) {
log::error( $config, "invalid filename: '$filename'" );
return;
}
log::error( $config, 'missing permissions on writing into local_media_dir/images/' ) unless ( -w $local_media_dir . 'images/' );
log::error( $config, 'missing permissions on writing into local_media_dir/thumbs/' ) unless ( -w $local_media_dir . 'thumbs/' );
log::error( $config, 'missing permissions on writing into local_media_dir/icons/' ) unless ( -w $local_media_dir . 'icons/' );
log::error( $config, 'missing permissions on writing into local_media_dir/images/' )
unless ( -w $local_media_dir . 'images/' );
log::error( $config, 'missing permissions on writing into local_media_dir/thumbs/' )
unless ( -w $local_media_dir . 'thumbs/' );
log::error( $config, 'missing permissions on writing into local_media_dir/icons/' )
unless ( -w $local_media_dir . 'icons/' );
my $path = $local_media_dir . '/upload/' . $filename;
my $path = $local_media_dir . '/upload/' . $filename;
#delete_file($path,"Upload $filename",$action_result,$errors);
#delete_file($path,"Upload $filename",$action_result,$errors);
$path = $local_media_dir . '/images/' . $filename;
delete_file( $path, "Image $filename", $action_result, $errors );
$path = $local_media_dir . '/images/' . $filename;
delete_file( $path, "Image $filename", $action_result, $errors );
$path = $local_media_dir . '/thumbs/' . $filename;
delete_file( $path, "Thumb $filename", $action_result, $errors );
$path = $local_media_dir . '/thumbs/' . $filename;
delete_file( $path, "Thumb $filename", $action_result, $errors );
$path = $local_media_dir . '/icons/' . $filename;
delete_file( $path, "Icon $filename", $action_result, $errors );
$path = $local_media_dir . '/icons/' . $filename;
delete_file( $path, "Icon $filename", $action_result, $errors );
}
# deactivated
sub delete_file {
my $path = $_[0];
my $type = $_[1];
my $action_result = $_[2];
my $errors = $_[3];
sub delete_file ($$$$) {
my $path = $_[0];
my $type = $_[1];
my $action_result = $_[2];
my $errors = $_[3];
return undef;
return undef;
unless ( -e $path ) {
$errors .= qq{Error: File does not exist!<br>};
return;
}
unless ( -e $path ) {
$errors .= qq{Error: File does not exist!<br>};
return;
}
unless ( -w $path ) {
$errors .= qq{Error: Cannot write $type<br>};
return;
}
unless ( -w $path ) {
$errors .= qq{Error: Cannot write $type<br>};
return;
}
unlink($path);
if ( $? == 0 ) {
$action_result .= qq{$type deleted<br>};
} else {
$errors .= qq{Error on deleting $type<br>};
}
unlink($path);
if ( $? == 0 ) {
$action_result .= qq{$type deleted<br>};
} else {
$errors .= qq{Error on deleting $type<br>};
}
}
sub getPath {
my $config = shift;
my $options = shift;
my $config = shift;
my $options = shift;
my $dir = $config->{locations}->{local_media_dir};
return undef unless defined $dir;
return undef unless -e $dir;
my $dir = $config->{locations}->{local_media_dir};
return undef unless defined $dir;
return undef unless -e $dir;
my $filename = $options->{filename};
return undef unless defined $filename;
$filename =~ s/^.*\///g;
my $filename = $options->{filename};
return undef unless defined $filename;
$filename =~ s/^.*\///g;
my $type = 'thumbs';
$type = $options->{type} if ( defined $options->{type} ) && ( $options->{type} =~ /^(images|thumbs|icons)$/ );
my $type = 'thumbs';
$type = $options->{type} if ( defined $options->{type} ) && ( $options->{type} =~ /^(images|thumbs|icons)$/ );
my $path = $dir . '/' . $type . '/' . $filename;
$path =~ s/\/+/\//g;
return $path;
my $path = $dir . '/' . $type . '/' . $filename;
$path =~ s/\/+/\//g;
return $path;
}
sub getInternalPath {
my $config = shift;
my $options = shift;
sub getInternalPath ($$) {
my $config = shift;
my $options = shift;
my $dir = $config->{locations}->{local_media_dir};
return undef unless defined $dir;
return undef unless -e $dir;
my $dir = $config->{locations}->{local_media_dir};
return undef unless defined $dir;
return undef unless -e $dir;
my $filename = $options->{filename};
return undef unless defined $filename;
$filename =~ s/^.*\///g;
my $filename = $options->{filename};
return undef unless defined $filename;
$filename =~ s/^.*\///g;
my $type = 'thumbs';
$type = $options->{type} if ( defined $options->{type} ) && ( $options->{type} =~ /^(images|thumbs|icons)$/ );
my $type = 'thumbs';
$type = $options->{type} if ( defined $options->{type} ) && ( $options->{type} =~ /^(images|thumbs|icons)$/ );
my $path = $dir . '/internal/' . $type . '/' . $filename;
$path =~ s/\/+/\//g;
return $path;
my $path = $dir . '/internal/' . $type . '/' . $filename;
$path =~ s/\/+/\//g;
return $path;
}
sub normalizeName {
my $name = shift;
return undef unless defined $name;
$name =~ s/.*\///g;
return $name;
sub normalizeName (;$) {
my $name = shift;
return undef unless defined $name;
$name =~ s/.*\///g;
return $name;
}
sub readFile {
my $path = shift;
my $content = '';
sub readFile($) {
my $path = shift;
my $content = '';
print STDERR "read '$path'\n";
return { error => "source '$path' does not exist" } unless -e $path;
return { error => "cannot read source '$path'" } unless -r $path;
print STDERR "read '$path'\n";
return { error => "source '$path' does not exist" } unless -e $path;
return { error => "cannot read source '$path'" } unless -r $path;
open my $file, '< :raw', $path or return { error => 'could not open image file. ' . $! . " $path" };
binmode $file;
$content = join( "", <$file> );
close $file;
return { content => $content };
open my $file, '< :raw', $path or return { error => 'could not open image file. ' . $! . " $path" };
binmode $file;
$content = join( "", <$file> );
close $file;
return { content => $content };
}
sub writeFile {
my $path = shift;
my $content = shift;
sub writeFile ($$) {
my $path = shift;
my $content = shift;
print STDERR "save '$path'\n";
open my $fh, '> :raw', $path or return { error => 'could not save image. ' . $! . " $path" };
binmode $fh;
print $fh $content;
close $fh;
return {};
print STDERR "save '$path'\n";
open my $fh, '> :raw', $path or return { error => 'could not save image. ' . $! . " $path" };
binmode $fh;
print $fh $content;
close $fh;
return {};
}
sub deleteFile {
my $path = shift;
return { error => "source '$path' does not exist" } unless -e $path;
sub deleteFile($) {
my $path = shift;
return { error => "source '$path' does not exist" } unless -e $path;
#unlink $path;
return {};
#unlink $path;
return {};
}
sub copyFile {
my $source = shift;
my $target = shift;
my $errors = shift;
sub copyFile ($$$) {
my $source = shift;
my $target = shift;
my $errors = shift;
my $read = images::readFile($source);
return $read if defined $read->{error};
my $read = images::readFile($source);
return $read if defined $read->{error};
my $write = images::writeFile( $target, $read->{content} );
return $write;
my $write = images::writeFile( $target, $read->{content} );
return $write;
}
sub publish {
my $config = shift;
my $filename = shift;
sub publish($$) {
my $config = shift;
my $filename = shift;
print STDERR "publish\n";
return undef unless defined $config;
return undef unless defined $filename;
my $errors = [];
for my $type ( 'images', 'thumbs', 'icons' ) {
my $source = getInternalPath( $config, { filename => $filename, type => $type } );
my $target = getPath( $config, { filename => $filename, type => $type } );
my $result = copyFile( $source, $target, $errors );
if ( defined $result->{error} ) {
push @$errors, $result->{error};
print STDERR "error on copy '$source' to '$target': $result->{error}\n";
}
}
return $errors;
print STDERR "publish\n";
return undef unless defined $config;
return undef unless defined $filename;
my $errors = [];
for my $type ( 'images', 'thumbs', 'icons' ) {
my $source = getInternalPath( $config, { filename => $filename, type => $type } );
my $target = getPath( $config, { filename => $filename, type => $type } );
my $result = copyFile( $source, $target, $errors );
if ( defined $result->{error} ) {
push @$errors, $result->{error};
print STDERR "error on copy '$source' to '$target': $result->{error}\n";
}
}
return $errors;
}
sub depublish {
my $config = shift;
my $filename = shift;
sub depublish ($$) {
my $config = shift;
my $filename = shift;
print STDERR "depublish\n";
return undef unless defined $config;
return undef unless defined $filename;
my $errors = [];
for my $type ( 'images', 'thumbs', 'icons' ) {
my $path = getPath( $config, { filename => $filename, type => $type } );
next unless defined $path;
print STDERR "remove '$path'\n";
unlink $path;
print STDERR "depublish\n";
return undef unless defined $config;
return undef unless defined $filename;
my $errors = [];
for my $type ( 'images', 'thumbs', 'icons' ) {
my $path = getPath( $config, { filename => $filename, type => $type } );
next unless defined $path;
print STDERR "remove '$path'\n";
unlink $path;
#push @$errors, $result->{error} if defined $result->{error};
}
return $errors;
#push @$errors, $result->{error} if defined $result->{error};
}
return $errors;
}
sub checkLicence {
my $config = shift;
my $result = shift;
sub checkLicence ($$) {
my $config = shift;
my $result = shift;
print STDERR "depublish\n";
return undef unless defined $config;
return undef unless defined $result;
print STDERR "depublish\n";
return undef unless defined $config;
return undef unless defined $result;
return if $result->{licence} =~ /\S/;
if ( ( defined $result->{public} ) && ( $result->{public} eq '1' ) ) {
depublish( $config, $result->{filename} );
$result->{public} = 0;
}
return if $result->{licence} =~ /\S/;
if ( ( defined $result->{public} ) && ( $result->{public} eq '1' ) ) {
depublish( $config, $result->{filename} );
$result->{public} = 0;
}
}
sub setEventLabels {
my $dbh = shift;
my $image = shift;
sub setEventLabels($$) {
my $dbh = shift;
my $image = shift;
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at images::setEventLabels\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::setEventLabels\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at images::setEventLabels\n";
return undef;
}
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at images::setEventLabels\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::setEventLabels\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at images::setEventLabels\n";
return undef;
}
my $query = qq{
my $query = qq{
update calcms_events
set image_label=?
where image=?
};
my $bind_values = [ $image->{licence}, $image->{filename} ];
#print STDERR Dumper($query) . Dumper($bind_values);
my $bind_values = [ $image->{licence}, $image->{filename} ];
my $results = db::put( $dbh, $query, $bind_values );
#print STDERR Dumper($results) . " changes\n";
return $results;
#print STDERR Dumper($query) . Dumper($bind_values);
my $results = db::put( $dbh, $query, $bind_values );
#print STDERR Dumper($results) . " changes\n";
return $results;
}
sub setSeriesLabels {
my $dbh = shift;
my $image = shift;
sub setSeriesLabels($$) {
my $dbh = shift;
my $image = shift;
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at images::setSeriesLabels\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::setSeriesLabels\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at images::setSeriesLabels\n";
return undef;
}
unless ( defined $image->{project_id} ) {
print STDERR "missing project_id at images::setSeriesLabels\n";
return undef;
}
unless ( defined $image->{studio_id} ) {
print STDERR "missing studio_id at images::setSeriesLabels\n";
return undef;
}
unless ( defined $image->{filename} ) {
print STDERR "missing filename at images::setSeriesLabels\n";
return undef;
}
my $query = qq{
my $query = qq{
update calcms_events
set series_image_label=?
where series_image=?
};
my $bind_values = [ $image->{licence}, $image->{filename} ];
#print STDERR Dumper($query) . Dumper($bind_values);
my $bind_values = [ $image->{licence}, $image->{filename} ];
my $results = db::put( $dbh, $query, $bind_values );
#print STDERR Dumper($results) . " changes\n";
return $results;
#print STDERR Dumper($query) . Dumper($bind_values);
my $results = db::put( $dbh, $query, $bind_values );
#print STDERR Dumper($results) . " changes\n";
return $results;
}
#do not delete last line!

155
lib/calcms/localization.pm
View File

@@ -1,14 +1,15 @@
package localization;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use uac();
use user_settings();
use base 'Exporter';
our @EXPORT_OK = qw(get getJavascript);
our @EXPORT_OK = qw(get getJavascript);
sub debug;
@@ -17,100 +18,100 @@ sub debug;
# language : get for selected language
# user : get from user settings
# loc : add to existing localization, optional
sub get {
my $config = shift;
my $options = shift;
sub get($$) {
my $config = shift;
my $options = shift;
#print STDERR Dumper($options);
#print STDERR Dumper($options);
#get pot file
unless ( defined $options->{file} ) {
print STDERR "missing po file\n";
return $options->{loc} || {};
}
#get pot file
unless ( defined $options->{file} ) {
print STDERR "missing po file\n";
return $options->{loc} || {};
}
my $language = undef;
my $language = undef;
#get language from options
$language = $options->{language} if ( defined $options->{language} );
#get language from options
$language = $options->{language} if ( defined $options->{language} );
#get language from user
if ( ( !( defined $language ) ) && ( defined $options->{user} ) ) {
my $user_settings = user_settings::get( $config, { user => $options->{user} } );
$language = $user_settings->{language};
}
$language = 'en' unless defined $language;
$language = 'en' unless $language eq 'de';
#get language from user
if ( ( !( defined $language ) ) && ( defined $options->{user} ) ) {
my $user_settings = user_settings::get( $config, { user => $options->{user} } );
$language = $user_settings->{language};
}
$language = 'en' unless defined $language;
$language = 'en' unless $language eq 'de';
my $loc = {};
$loc = $options->{loc} if defined $options->{loc};
my $loc = {};
$loc = $options->{loc} if defined $options->{loc};
my $files = $options->{file};
$files =~ s/[^a-zA-Z\,\_\-]//g;
my $files = $options->{file};
$files =~ s/[^a-zA-Z\,\_\-]//g;
#get all comma separated po files
for my $file ( split /\,/, $files ) {
#get all comma separated po files
for my $file ( split /\,/, $files ) {
#read default language
#my $po_file=$config->{locations}->{admin_pot_dir}.'/en/'.$file.'.po';
#$loc=read_po_file($po_file, $loc);
#read default language
#my $po_file=$config->{locations}->{admin_pot_dir}.'/en/'.$file.'.po';
#$loc=read_po_file($po_file, $loc);
#read selected language
#if($language ne 'en'){
my $po_file = $config->{locations}->{admin_pot_dir} . '/' . $language . '/' . $file . '.po';
$loc = read_po_file( $po_file, $loc );
#read selected language
#if($language ne 'en'){
my $po_file = $config->{locations}->{admin_pot_dir} . '/' . $language . '/' . $file . '.po';
$loc = read_po_file( $po_file, $loc );
#}
}
return $loc;
#}
}
return $loc;
}
sub read_po_file {
my $po_file = shift;
my $loc = shift;
sub read_po_file($$) {
my $po_file = shift;
my $loc = shift;
unless ( -e $po_file ) {
print STDERR "po file $po_file does not exist\n";
return $loc;
}
unless ( -r $po_file ) {
print STDERR "cannot read po file $po_file\n";
return $loc;
}
unless ( -e $po_file ) {
print STDERR "po file $po_file does not exist\n";
return $loc;
}
unless ( -r $po_file ) {
print STDERR "cannot read po file $po_file\n";
return $loc;
}
my $key = '';
open my $file, '<:encoding(UTF-8)', $po_file;
return $loc unless defined $file;
while (<$file>) {
my $line = $_;
my $key = '';
open my $file, '<:encoding(UTF-8)', $po_file;
return $loc unless defined $file;
while (<$file>) {
my $line = $_;
#print STDERR $line;
if ( $line =~ /^msgid\s*\"(.*)\"\s*$/ ) {
$key = $1;
$key =~ s/\'//g;
$key =~ s/\"//g;
}
if ( $line =~ /^msgstr\s*\"(.*)\"\s*$/ ) {
my $val = $1;
$val =~ s/\'//g;
$val =~ s/\"//g;
$loc->{$key} = $val;
}
}
close $file;
return $loc;
#print STDERR $line;
if ( $line =~ /^msgid\s*\"(.*)\"\s*$/ ) {
$key = $1;
$key =~ s/\'//g;
$key =~ s/\"//g;
}
if ( $line =~ /^msgstr\s*\"(.*)\"\s*$/ ) {
my $val = $1;
$val =~ s/\'//g;
$val =~ s/\"//g;
$loc->{$key} = $val;
}
}
close $file;
return $loc;
}
sub getJavascript {
my $loc = shift;
sub getJavascript ($){
my $loc = shift;
my $out = '<script>';
$out .= "var loc={};\n";
for my $key ( sort keys %$loc ) {
$out .= qq{loc['$key']='$loc->{$key}';} . "\n";
}
$out .= "</script>\n";
return $out;
my $out = '<script>';
$out .= "var loc={};\n";
for my $key ( sort keys %$loc ) {
$out .= qq{loc['$key']='$loc->{$key}';} . "\n";
}
$out .= "</script>\n";
return $out;
}
1;

19
lib/calcms/log.pm
View File

@@ -1,7 +1,8 @@
package log;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use base 'Exporter';
our @EXPORT_OK = qw(error load_file save_file append_file);
@@ -9,7 +10,7 @@ our @EXPORT_OK = qw(error load_file save_file append_file);
use config();
#TODO: check if config is given
sub error {
sub error($$) {
my $config = $_[0];
my $message = "Error: $_[1]\n";
@@ -22,8 +23,8 @@ sub error {
#do not call template::check to avoid deep recursion!
if ( $config->{system}->{debug} ) {
template::process($config,
'print',
template::process(
$config, 'print',
'templates/default.html',
{
static_files_url => $config->{locations}->{static_files_url},
@@ -35,20 +36,20 @@ sub error {
die();
}
sub load_file {
sub load_file($) {
my $filename = shift;
my $content = '';
if ( -e $filename ) {
my $FILE = undef;
open ($FILE, "<:utf8", $filename) || warn "cant read file '$filename'";
open( $FILE, "<:utf8", $filename ) || warn "cant read file '$filename'";
$content = join "", (<$FILE>);
close $FILE;
return $content;
}
}
sub save_file {
sub save_file($$) {
my $filename = shift;
my $content = shift;
@@ -69,7 +70,7 @@ sub save_file {
}
sub append_file {
sub append_file($$) {
my $filename = shift;
my $content = shift;
@@ -86,4 +87,4 @@ sub append_file {
}
#do not delete last line!
1;
1;

28
lib/calcms/mail.pm
View File

@@ -1,23 +1,25 @@
package mail;
use warnings;
use strict;
use warnings;
no warnings 'redefine';
use MIME::Lite();
sub send {
my $mail = shift;
sub send($) {
my $mail = shift;
my $msg = MIME::Lite->new(
'From' => $mail->{'From'},
'To' => $mail->{'To'},
'Cc' => $mail->{'Cc'},
'Reply-To' => $mail->{'Reply-To'},
'Subject' => $mail->{'Subject'},
'Data' => $mail->{'Data'},
);
my $msg = MIME::Lite->new(
'From' => $mail->{'From'},
'To' => $mail->{'To'},
'Cc' => $mail->{'Cc'},
'Reply-To' => $mail->{'Reply-To'},
'Subject' => $mail->{'Subject'},
'Data' => $mail->{'Data'},
);
$msg->print( \*STDERR );
$msg->send;
$msg->print( \*STDERR );
$msg->send;
}
# do not delete next line

758
lib/calcms/markup.pm
View File

@@ -1,7 +1,9 @@
package markup;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Text::WikiCreole();
use HTML::Parse();
@@ -15,493 +17,493 @@ use base 'Exporter';
our @EXPORT_OK =
qw(fix_line_ends html_to_creole creole_to_html creole_to_plain plain_to_ical ical_to_plain ical_to_xml html_to_plain fix_utf8 uri_encode compress base26);
sub fix_line_ends {
my $s = shift;
$s =~ s/\r?\n|\r/\n/g;
return $s;
sub fix_line_ends ($) {
my $s = shift;
$s =~ s/\r?\n|\r/\n/g;
return $s;
}
# convert 1..26 to a..z, 27 to aa, inspired by ConvertAA
sub base26 {
my $num = shift;
return '' if $num <= 0;
sub base26($) {
my $num = shift;
return '' if $num <= 0;
my $s = "";
while ($num) {
$s = chr( --$num % 26 + ord "a" ) . $s;
$num = int $num / 26;
}
my $s = "";
while ($num) {
$s = chr( --$num % 26 + ord "a" ) . $s;
$num = int $num / 26;
}
return $s;
return $s;
}
sub html_to_creole {
my $s = shift;
sub html_to_creole($) {
my $s = shift;
#remove elements
# $s=~s/[\r\f\n]+/\n/gi;
# $s=~s/<\/p.*?>//gi;
# $s=~s/<\/br.*?>//gi;
$s =~ s/\<\!\-\-[\s\S]*?\-\-\>//gi;
$s =~ s/<script.*?>.*?<\/script.*?>//gi;
#remove elements
# $s=~s/[\r\f\n]+/\n/gi;
# $s=~s/<\/p.*?>//gi;
# $s=~s/<\/br.*?>//gi;
$s =~ s/\<\!\-\-[\s\S]*?\-\-\>//gi;
$s =~ s/<script.*?>.*?<\/script.*?>//gi;
# $s=~s/<\/?span.*?>//gi;
# $s=~s/<\/?font.*?>//gi;
# $s=~s/<\/?meta.*?>//gi;
# $s=~s/<\/?title.*?>//gi;
# $s=~s/<\/?style.*?>//gi;
# $s=~s/<\/?col.*?>//gi;
# $s=~s/<\/?thead.*?>//gi;
# $s=~s/<\/?tbody.*?>//gi;
$s =~ s/<\/?form.*?>//gi;
$s =~ s/<\/?select.*?>//gi;
$s =~ s/<\/?option.*?//gi;
$s =~ s/<\/?input.*?>//gi;
# $s=~s/<\/?span.*?>//gi;
# $s=~s/<\/?font.*?>//gi;
# $s=~s/<\/?meta.*?>//gi;
# $s=~s/<\/?title.*?>//gi;
# $s=~s/<\/?style.*?>//gi;
# $s=~s/<\/?col.*?>//gi;
# $s=~s/<\/?thead.*?>//gi;
# $s=~s/<\/?tbody.*?>//gi;
$s =~ s/<\/?form.*?>//gi;
$s =~ s/<\/?select.*?>//gi;
$s =~ s/<\/?option.*?//gi;
$s =~ s/<\/?input.*?>//gi;
# $s=~s/<\/?button.*?>//gi;
# $s=~s/<\/?textarea.*?>//gi;
$s =~ s/<\/?script.*?>//gi;
# $s=~s/<\/?button.*?>//gi;
# $s=~s/<\/?textarea.*?>//gi;
$s =~ s/<\/?script.*?>//gi;
#table elements
# $s=~s/\s*<\/?td.*?>//gi;
# $s=~s/\s*<\/?th.*?>//gi;
#table elements
# $s=~s/\s*<\/?td.*?>//gi;
# $s=~s/\s*<\/?th.*?>//gi;
#remove line breaks
$s =~ s/[\r\n]+/ /gi;
#remove line breaks
$s =~ s/[\r\n]+/ /gi;
#formats
$s =~ s/<img.*?src="(.*?)".*?>/{{$1\|}}/gi;
$s =~ s/<img.*?title="(.*?)".*?>/{{$2\|$1}}/gi;
$s =~ s/<img.*?src="(.*?)"[^>]*?title="(.*?)".*?>/{{$1\|$2}}/gi;
$s =~ s/<img.*?title="(.*?)"[^>]*?src="(.*?)".*?>/{{$2\|$1}}/gi;
$s =~ s/<\/?img.*?>//gi;
#formats
$s =~ s/<img.*?src="(.*?)".*?>/{{$1\|}}/gi;
$s =~ s/<img.*?title="(.*?)".*?>/{{$2\|$1}}/gi;
$s =~ s/<img.*?src="(.*?)"[^>]*?title="(.*?)".*?>/{{$1\|$2}}/gi;
$s =~ s/<img.*?title="(.*?)"[^>]*?src="(.*?)".*?>/{{$2\|$1}}/gi;
$s =~ s/<\/?img.*?>//gi;
#replace line breaks from images
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
#replace line breaks from images
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/<i.*?>(.*?)<\/i>/\/\/$1\/\//gi;
$s =~ s/<\/?i.*?>//gi;
$s =~ s/<b.*?>(.*?)<\/b>/\*\*$1\*\*/gi;
$s =~ s/<i.*?>(.*?)<\/i>/\/\/$1\/\//gi;
$s =~ s/<\/?i.*?>//gi;
$s =~ s/<b.*?>(.*?)<\/b>/\*\*$1\*\*/gi;
# $s=~s/<\/?b.*?>//gi;
# $s=~s/<\/?b.*?>//gi;
$s =~ s/<strong.*?>(.*?)<\/strong>/\*\*$1\*\*/gi;
$s =~ s/<em.*?>(.*?)<\/em>/\/\/$1\/\//gi;
$s =~ s/<blockquote.*?>((\W+|\w+)*?)<\/blockquote>/{{{$1}}}/gi;
$s =~ s/<strong.*?>(.*?)<\/strong>/\*\*$1\*\*/gi;
$s =~ s/<em.*?>(.*?)<\/em>/\/\/$1\/\//gi;
$s =~ s/<blockquote.*?>((\W+|\w+)*?)<\/blockquote>/{{{$1}}}/gi;
# $s=~s/<a\s+.*?href="(.*?)".*?>((\W+|\w+)*?)<\/a>/\[\[$1\|$2\]\]$3/gi;
$s =~ s/<a\s+.*?href="(.*?)".*?>(.*?)(\s*)<\/a>/\[\[$1\|$2\]\]$3/gi;
$s =~ s/<a.*?>//gi;
# $s=~s/<a\s+.*?href="(.*?)".*?>((\W+|\w+)*?)<\/a>/\[\[$1\|$2\]\]$3/gi;
$s =~ s/<a\s+.*?href="(.*?)".*?>(.*?)(\s*)<\/a>/\[\[$1\|$2\]\]$3/gi;
$s =~ s/<a.*?>//gi;
#replace line breaks from links
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
#replace line breaks from links
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
# print STDERR Dumper($s) if ($s=~/</);
# print STDERR Dumper($s) if ($s=~/</);
$s =~ s/[\s]+/ /gi;
$s =~ s/[\s]+/ /gi;
# $s=~s/\n[ \t\r\n]+\n/\n\n/gi;
# $s=~s/\n[ ]+/\n /gi;
# $s=~s/\n+/\n/gi;
# $s=~s/\n+/\\\n/gi;
# $s=~s/\n[ \t\r\n]+\n/\n\n/gi;
# $s=~s/\n[ ]+/\n /gi;
# $s=~s/\n+/\n/gi;
# $s=~s/\n+/\\\n/gi;
#line elements, increase head line level to avoid breaking single = chars
$s =~ s/\s*<h1.*?>/== /gi;
$s =~ s/\s*<h2.*?>/=== /gi;
$s =~ s/\s*<h3.*?>/==== /gi;
$s =~ s/\s*<h\d.*?>/===== /gi;
#line elements, increase head line level to avoid breaking single = chars
$s =~ s/\s*<h1.*?>/== /gi;
$s =~ s/\s*<h2.*?>/=== /gi;
$s =~ s/\s*<h3.*?>/==== /gi;
$s =~ s/\s*<h\d.*?>/===== /gi;
# $s=~s/\s*<\/h\d.*?>/\n/gi;
# $s=~s/\s*<\/h\d.*?>/\n/gi;
# $s=~s/<br.*?>/\\\\<br>/gi;
# $s=~s/\s*<div.*?>//gi;
# $s=~s/\s*<\/div>/\n/gi;
# $s=~s/<br.*?>/\\\\<br>/gi;
# $s=~s/\s*<div.*?>//gi;
# $s=~s/\s*<\/div>/\n/gi;
# $s=~s/<table.*?>/\n/gi;
# $s=~s/<\/table>/\n/gi;
# $s=~s/\s*<tr.*?>//gi;
# $s=~s/\s*<\/tr>//gi;
# $s=~s/<table.*?>/\n/gi;
# $s=~s/<\/table>/\n/gi;
# $s=~s/\s*<tr.*?>//gi;
# $s=~s/\s*<\/tr>//gi;
# $s=~s/\s*<ol.*?>/\n/gi;
# $s=~s/\s*<\/ol>/\n/gi;
# $s=~s/\s*<ul.*?>/\n/gi;
# $s=~s/\s*<\/ul>/\n/gi;
# $s=~s/\s*<li.*?>/\n\* /gi;
# $s=~s/\s*<\/li>//gi;
# $s=~s/\s*<ol.*?>/\n/gi;
# $s=~s/\s*<\/ol>/\n/gi;
# $s=~s/\s*<ul.*?>/\n/gi;
# $s=~s/\s*<\/ul>/\n/gi;
# $s=~s/\s*<li.*?>/\n\* /gi;
# $s=~s/\s*<\/li>//gi;
# $s=~s/\s*<p.*?>\s*/\n\n/gi;
# $s=~s/\s*<br.*?>\s*/\n /gi;
# $s=~s/\s*<p.*?>\s*/\n\n/gi;
# $s=~s/\s*<br.*?>\s*/\n /gi;
my $tree = HTML::Parse::parse_html( '<body>' . $s . '</body>' );
my $formatter = HTML::FormatText->new( leftmargin => 0, rightmargin => 2000 );
$s = $formatter->format($tree);
my $tree = HTML::Parse::parse_html( '<body>' . $s . '</body>' );
my $formatter = HTML::FormatText->new( leftmargin => 0, rightmargin => 2000 );
$s = $formatter->format($tree);
#use Data::Dumper; print "asd:<textarea cols=100 rows=5>".Dumper($s);print "</textarea>";
$s =~ s/\</\&lt;/g;
#use Data::Dumper; print "asd:<textarea cols=100 rows=5>".Dumper($s);print "</textarea>";
$s =~ s/\</\&lt;/g;
#fix line endings
$s =~ s/\n[ \t]+/\n/gi;
#fix line endings
$s =~ s/\n[ \t]+/\n/gi;
#$s=~s/\n[\t\r ]+\n/\n\n/g;
$s =~ s/\n{3,99}/\n\n/g;
$s =~ s/\n*\*[\s]+/\n\* /g;
#$s=~s/\n[\t\r ]+\n/\n\n/g;
$s =~ s/\n{3,99}/\n\n/g;
$s =~ s/\n*\*[\s]+/\n\* /g;
#$s=~s/(\n\*.*?\n)([^\*])/$1\n\n$2/g;
#$s=~s/(\n\*.*?\n)([^\*])/$1\n\n$2/g;
#enter line break before headlines
$s =~ s/(={2,99})/\n$1/g;
#enter line break before headlines
$s =~ s/(={2,99})/\n$1/g;
#reduce head line level
$s =~ s/=(=+)/$1/g;
#reduce head line level
$s =~ s/=(=+)/$1/g;
$s =~ s/^\s+//gi;
$s =~ s/\s+$//gi;
$s =~ s/\n{3,99}/\n\n/g;
$s =~ s/^\s+//gi;
$s =~ s/\s+$//gi;
$s =~ s/\n{3,99}/\n\n/g;
# $s=~s/\n\n+/ \\\\\n/g;
$s =~ s/\n/\\\\\n/g;
$s =~ s/\\\\\n\=/\n\=/g;
# $s=~s/\n\n+/ \\\\\n/g;
$s =~ s/\n/\\\\\n/g;
$s =~ s/\\\\\n\=/\n\=/g;
#$s=~s/\n\n/ \\\\\n/g;
# $s=~s/(\\\\\n){3,99}/\\\\\n\\\\\n/g;
#$s=~s/\\\\[ \t]+/\\\\\n/g;
#$s=~s/\n\n/ \\\\\n/g;
# $s=~s/(\\\\\n){3,99}/\\\\\n\\\\\n/g;
#$s=~s/\\\\[ \t]+/\\\\\n/g;
# $s=~s/<\/a>//gi;
# $s=~s/<\/a>//gi;
return $s;
return $s;
}
sub creole_to_html {
my $s = $_[0] || '';
sub creole_to_html ($) {
my $s = $_[0] || '';
#$s=~s/\n\#\n/\n/g;
#fix_line_ends($s);
$s =~ s/<a\s+.*?href="(.*?)".*?>(.*?)(\s*)<\/a>/\[\[$1\|$2\]\]$3/gi;
$s =~ s/<a.*?>//gi;
#$s=~s/\n\#\n/\n/g;
#fix_line_ends($s);
$s =~ s/<a\s+.*?href="(.*?)".*?>(.*?)(\s*)<\/a>/\[\[$1\|$2\]\]$3/gi;
$s =~ s/<a.*?>//gi;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/^\s+//g;
$s =~ s/\s+$//g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/(\[\[[^\]\n]*?)\n([^\]]*?\]\])/$1$2/g;
$s =~ s/^\s+//g;
$s =~ s/\s+$//g;
$s = Text::WikiCreole::creole_parse($s) || '';
$s = Text::WikiCreole::creole_parse($s) || '';
# $s=~s/<p>/\n/gi;
# $s=~s/\{\{\{((\W+|\w+)+?)\}\}\}/<blockquote>$1<\/blockquote>/g;
# $s=~s/\{\{(.+?)\|(.*?)\}\}/<img src="$1" title="$2" \/>/g;
# $s=~s/\[\[(.+?)\|(.*?)\]\]/<a href="$1">$2<\/a>/g;
# $s=~s/([^\:])\/\/(.*?[^\:])\/\//$1<em>$2<\/em> /g;
# $s=~s/\n=== (.*?)\n/<h3>$1<\/h3>\n/g;
# $s=~s/\n== (.*?)\n/<h2>$1<\/h2>\n/g;
#replace line breaks from images
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
# $s=~s/<p>/\n/gi;
# $s=~s/\{\{\{((\W+|\w+)+?)\}\}\}/<blockquote>$1<\/blockquote>/g;
# $s=~s/\{\{(.+?)\|(.*?)\}\}/<img src="$1" title="$2" \/>/g;
# $s=~s/\[\[(.+?)\|(.*?)\]\]/<a href="$1">$2<\/a>/g;
# $s=~s/([^\:])\/\/(.*?[^\:])\/\//$1<em>$2<\/em> /g;
# $s=~s/\n=== (.*?)\n/<h3>$1<\/h3>\n/g;
# $s=~s/\n== (.*?)\n/<h2>$1<\/h2>\n/g;
#replace line breaks from images
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
$s =~ s/(\{\{[^\}\n]*?)\n([^\}\n]*?\}\})/$1$2/g;
#replace line breaks from links
# $s=~s/\n= (.*?)\n/<h1>$1<\/h1>\n/g;
# $s=~s/\*\*(.*?)\*\*/<strong>$1<\/strong> /g;
# $s=~s/^== (.*?)\n/<h2>$1<\/h2>\n/g;
# $s=~s/\n\* (.*?)([\r\n]+)/<li>$1<\/li>\n/g;
# $s=~s/\n\- (.*?)\n/<lo>$1<\/lo>\n/g;
# $s=~s/\n\n/<p>/gi;
# $s=~s/\n+/<br \/>/gi;
# $s=~s/\</\&lt;/g;
#replace line breaks from links
# $s=~s/\n= (.*?)\n/<h1>$1<\/h1>\n/g;
# $s=~s/\*\*(.*?)\*\*/<strong>$1<\/strong> /g;
# $s=~s/^== (.*?)\n/<h2>$1<\/h2>\n/g;
# $s=~s/\n\* (.*?)([\r\n]+)/<li>$1<\/li>\n/g;
# $s=~s/\n\- (.*?)\n/<lo>$1<\/lo>\n/g;
# $s=~s/\n\n/<p>/gi;
# $s=~s/\n+/<br \/>/gi;
# $s=~s/\</\&lt;/g;
#remove whitespaces and break lines at start or end of elements
for my $elem ( 'p', 'li' ) {
$s =~ s|<$elem>\s*<br/><br/>|<$elem>|g;
$s =~ s|<br/><br/>\s*</$elem>|</$elem>|g;
}
#remove whitespaces and break lines at start or end of elements
for my $elem ( 'p', 'li' ) {
$s =~ s|<$elem>\s*<br/><br/>|<$elem>|g;
$s =~ s|<br/><br/>\s*</$elem>|</$elem>|g;
}
return $s;
return $s;
}
sub creole_to_plain {
my $s = shift;
sub creole_to_plain($) {
my $s = shift;
$s =~ s/\<p\>/\n/gi;
$s =~ s/\{\{\{((\W+|\w+)+?)\}\}\}/<blockquote>$1<\/blockquote>/g;
$s =~ s/\{\{(.+?)\|(.*?)\}\}//g;
$s =~ s/\[\[(.+?)\|(.*?)\]\]/$2/g;
$s =~ s/\/\/([^\/\/]*?)\/\//<em>$1<\/em> /g;
$s =~ s/\n=== (.*?)\n/\n<h3>$1<\/h3>\n/g;
$s =~ s/\n== (.*?)\n/\n<h2>$1<\/h2>\n/g;
$s =~ s/\*\*(.*?)\*\*/<strong>$1<\/strong> /g;
$s =~ s/^== (.*?)\n/<h2>$1<\/h2>\n/g;
$s =~ s/\n\* (.*?)\n/\n<li>$1<\/li>\n/g;
$s =~ s/\n\* (.*?)\n/\n<li>$1<\/li>\n/g;
$s =~ s/\n\- (.*?)\n/\n<lo>$1<\/lo>\n/g;
$s =~ s/\n\- (.*?)\n/\n<lo>$1<\/lo>\n/g;
$s =~ s/\n\n/\n<p>/gi;
$s =~ s/\n/\n<br\/>/gi;
return $s;
$s =~ s/\<p\>/\n/gi;
$s =~ s/\{\{\{((\W+|\w+)+?)\}\}\}/<blockquote>$1<\/blockquote>/g;
$s =~ s/\{\{(.+?)\|(.*?)\}\}//g;
$s =~ s/\[\[(.+?)\|(.*?)\]\]/$2/g;
$s =~ s/\/\/([^\/\/]*?)\/\//<em>$1<\/em> /g;
$s =~ s/\n=== (.*?)\n/\n<h3>$1<\/h3>\n/g;
$s =~ s/\n== (.*?)\n/\n<h2>$1<\/h2>\n/g;
$s =~ s/\*\*(.*?)\*\*/<strong>$1<\/strong> /g;
$s =~ s/^== (.*?)\n/<h2>$1<\/h2>\n/g;
$s =~ s/\n\* (.*?)\n/\n<li>$1<\/li>\n/g;
$s =~ s/\n\* (.*?)\n/\n<li>$1<\/li>\n/g;
$s =~ s/\n\- (.*?)\n/\n<lo>$1<\/lo>\n/g;
$s =~ s/\n\- (.*?)\n/\n<lo>$1<\/lo>\n/g;
$s =~ s/\n\n/\n<p>/gi;
$s =~ s/\n/\n<br\/>/gi;
return $s;
}
sub html_to_plain {
my $s = shift;
return '' unless ( defined $s );
my $tree = HTML::Parse::parse_html( '<body>' . $s . '</body>' );
my $formatter = HTML::FormatText->new( leftmargin => 0, rightmargin => 2000 );
$s = $formatter->format($tree);
return $s;
sub html_to_plain ($) {
my $s = shift;
return '' unless ( defined $s );
my $tree = HTML::Parse::parse_html( '<body>' . $s . '</body>' );
my $formatter = HTML::FormatText->new( leftmargin => 0, rightmargin => 2000 );
$s = $formatter->format($tree);
return $s;
}
sub ical_to_plain {
return '' unless defined( $_[0] );
$_[0] =~ s/\\n/\n/gi;
$_[0] =~ s/ /\t/gi;
$_[0] =~ s/\\\./\./gi;
$_[0] =~ s/\\\,/\,/gi;
$_[0] =~ s/\\\\/\\/gi;
return $_[0];
sub ical_to_plain ($) {
return '' unless defined( $_[0] );
$_[0] =~ s/\\n/\n/gi;
$_[0] =~ s/ /\t/gi;
$_[0] =~ s/\\\./\./gi;
$_[0] =~ s/\\\,/\,/gi;
$_[0] =~ s/\\\\/\\/gi;
return $_[0];
}
sub plain_to_ical {
return '' unless defined( $_[0] );
sub plain_to_ical ($) {
return '' unless defined( $_[0] );
#remove images + links
$_[0] =~ s/\[\[.+?\|(.+?)\]\]/$1/g;
$_[0] =~ s/\{\{.+?\}\}//g;
$_[0] =~ s/^\s+//g;
$_[0] =~ s/\\/\\\\/gi;
$_[0] =~ s/\,/\\\,/gi;
#remove images + links
$_[0] =~ s/\[\[.+?\|(.+?)\]\]/$1/g;
$_[0] =~ s/\{\{.+?\}\}//g;
$_[0] =~ s/^\s+//g;
$_[0] =~ s/\\/\\\\/gi;
$_[0] =~ s/\,/\\\,/gi;
# $_[0]=~s/\./\\\./gi;
$_[0] =~ s/[\r\n]/\\n/gi;
$_[0] =~ s/\t/ /gi;
return $_[0];
# $_[0]=~s/\./\\\./gi;
$_[0] =~ s/[\r\n]/\\n/gi;
$_[0] =~ s/\t/ /gi;
return $_[0];
}
sub plain_to_xml {
return '' unless defined( $_[0] );
$_[0] =~ s/\n\={1,6} (.*?)\s+/\n\[\[$1\]\]\n/gi;
sub plain_to_xml($) {
return '' unless defined( $_[0] );
$_[0] =~ s/\n\={1,6} (.*?)\s+/\n\[\[$1\]\]\n/gi;
#remove images + links
$_[0] =~ s/\[\[.+?\|(.+?)\]\]/$1/g;
$_[0] =~ s/\{\{.+?\}\}//g;
return encode_xml_element( $_[0] );
#remove images + links
$_[0] =~ s/\[\[.+?\|(.+?)\]\]/$1/g;
$_[0] =~ s/\{\{.+?\}\}//g;
return encode_xml_element( $_[0] );
# $_[0]=~s/\&auml;/ä/gi;
# $_[0]=~s/\&ouml;/ö/gi;
# $_[0]=~s/\&uuml;/ü/gi;
# $_[0]=~s/\&Auml;/Ä/gi;
# $_[0]=~s/\&Ouml;/Ö/gi;
# $_[0]=~s/\&Uuml;/Ü/gi;
# $_[0]=~s/\&szlig;/ß/gi;
# $_[0]=~s/\&/\&amp;/gi;
# $_[0]=~s/\</\&lt;/gi;
# $_[0]=~s/\>/\&gt;/gi;
# $_[0]=~s/\"/\&quot;/gi;
# $_[0]=~s/\&auml;/ä/gi;
# $_[0]=~s/\&ouml;/ö/gi;
# $_[0]=~s/\&uuml;/ü/gi;
# $_[0]=~s/\&Auml;/Ä/gi;
# $_[0]=~s/\&Ouml;/Ö/gi;
# $_[0]=~s/\&Uuml;/Ü/gi;
# $_[0]=~s/\&szlig;/ß/gi;
# $_[0]=~s/\&/\&amp;/gi;
# $_[0]=~s/\</\&lt;/gi;
# $_[0]=~s/\>/\&gt;/gi;
# $_[0]=~s/\"/\&quot;/gi;
## $_[0]=~s/\n/<br\/>/gi;
## $_[0]=~s/\&amp;amp;/\&amp;/gi;
## $_[0]=~s/\&amp;amp;/+/gi;
## $_[0]=~s/\&amp;/+/gi;
## $_[0]=~s/\&/+/gi;
# return $_[0];
# return $_[0];
}
sub fix_utf8 {
$_[0] = Encode::decode( 'cp1252', $_[0] );
return $_[0];
sub fix_utf8($) {
$_[0] = Encode::decode( 'cp1252', $_[0] );
return $_[0];
}
sub uri_encode {
$_[0] =~ s/([^a-zA-Z0-9_\.\-])/sprintf("%%%02lx",ord($1))/esg;
return $_[0];
sub uri_encode ($) {
$_[0] =~ s/([^a-zA-Z0-9_\.\-])/sprintf("%%%02lx",ord($1))/esg;
return $_[0];
}
sub compress {
my $header = '';
sub compress ($) {
my $header = '';
if ( $_[0] =~ /(Content\-type\:[^\n]+[\n]+)/ ) {
$header = $1;
} else {
if ( $_[0] =~ /(Content\-type\:[^\n]+[\n]+)/ ) {
$header = $1;
} else {
#return;
}
#return;
}
my $start = index( $_[0], $header );
return if ( $start < 0 );
my $start = index( $_[0], $header );
return if ( $start < 0 );
my $header_length = length($header);
$header = substr( $_[0], 0, $start + $header_length );
my $header_length = length($header);
$header = substr( $_[0], 0, $start + $header_length );
# print $header."\n";
# print $header."\n";
my $content = substr( $_[0], $start + $header_length );
my $content = substr( $_[0], $start + $header_length );
# #remove multiple line breaks
$content =~ s/[\r\n]+[\s]*[\r\n]+/\n/g;
# #remove multiple line breaks
$content =~ s/[\r\n]+[\s]*[\r\n]+/\n/g;
#remove leading whitespaces
$content =~ s/[\r\n]+[\s]+/\n/g;
#remove leading whitespaces
$content =~ s/[\r\n]+[\s]+/\n/g;
#remove tailing whitespaces
$content =~ s/[\t ]*[\r\n]+/\n/g;
#remove tailing whitespaces
$content =~ s/[\t ]*[\r\n]+/\n/g;
#remove whitespaces inside tags
$content =~ s/([\n]\<[^\n]+)[\r\n]+/$1 /g;
$content =~ s/\"\s+\>/\"\>/g;
#remove whitespaces inside tags
$content =~ s/([\n]\<[^\n]+)[\r\n]+/$1 /g;
$content =~ s/\"\s+\>/\"\>/g;
#get closing tags closer
$content =~ s/[\r\n]+(\<[\/\!])/$1/g;
$content =~ s/(\>)[\r\n]+([^\<])/$1$2/g;
#get closing tags closer
$content =~ s/[\r\n]+(\<[\/\!])/$1/g;
$content =~ s/(\>)[\r\n]+([^\<])/$1$2/g;
#remove leading whitespaces
#$content=~s/[\r\n]+([\d\S])/$1/g;
#remove leading whitespaces
#$content=~s/[\r\n]+([\d\S])/$1/g;
#remove empty lines
$content =~ s/[\n\r]+/\n/g;
#remove empty lines
$content =~ s/[\n\r]+/\n/g;
#remove whitespaces between tags
$content =~ s/\>[\t ]+\<(^\/T)/\>\<$1/g;
#remove whitespaces between tags
$content =~ s/\>[\t ]+\<(^\/T)/\>\<$1/g;
#multiple whitespaces
$content =~ s/[\t ]+/ /g;
#multiple whitespaces
$content =~ s/[\t ]+/ /g;
#restore content-type line break
$_[0] = $header . $content;
#restore content-type line break
$_[0] = $header . $content;
#$_[0]=~s/HTTP_CONTENT_TYPE/\n\n/;
# return $_[0];
#$_[0]=~s/HTTP_CONTENT_TYPE/\n\n/;
# return $_[0];
}
#from XML::RSS.pm
my %entity = (
nbsp => "&#160;",
iexcl => "&#161;",
cent => "&#162;",
pound => "&#163;",
curren => "&#164;",
yen => "&#165;",
brvbar => "&#166;",
sect => "&#167;",
uml => "&#168;",
copy => "&#169;",
ordf => "&#170;",
laquo => "&#171;",
not => "&#172;",
shy => "&#173;",
reg => "&#174;",
macr => "&#175;",
deg => "&#176;",
plusmn => "&#177;",
sup2 => "&#178;",
sup3 => "&#179;",
acute => "&#180;",
micro => "&#181;",
para => "&#182;",
middot => "&#183;",
cedil => "&#184;",
sup1 => "&#185;",
ordm => "&#186;",
raquo => "&#187;",
frac14 => "&#188;",
frac12 => "&#189;",
frac34 => "&#190;",
iquest => "&#191;",
Agrave => "&#192;",
Aacute => "&#193;",
Acirc => "&#194;",
Atilde => "&#195;",
Auml => "&#196;",
Aring => "&#197;",
AElig => "&#198;",
Ccedil => "&#199;",
Egrave => "&#200;",
Eacute => "&#201;",
Ecirc => "&#202;",
Euml => "&#203;",
Igrave => "&#204;",
Iacute => "&#205;",
Icirc => "&#206;",
Iuml => "&#207;",
ETH => "&#208;",
Ntilde => "&#209;",
Ograve => "&#210;",
Oacute => "&#211;",
Ocirc => "&#212;",
Otilde => "&#213;",
Ouml => "&#214;",
times => "&#215;",
Oslash => "&#216;",
Ugrave => "&#217;",
Uacute => "&#218;",
Ucirc => "&#219;",
Uuml => "&#220;",
Yacute => "&#221;",
THORN => "&#222;",
szlig => "&#223;",
agrave => "&#224;",
aacute => "&#225;",
acirc => "&#226;",
atilde => "&#227;",
auml => "&#228;",
aring => "&#229;",
aelig => "&#230;",
ccedil => "&#231;",
egrave => "&#232;",
eacute => "&#233;",
ecirc => "&#234;",
euml => "&#235;",
igrave => "&#236;",
iacute => "&#237;",
icirc => "&#238;",
iuml => "&#239;",
eth => "&#240;",
ntilde => "&#241;",
ograve => "&#242;",
oacute => "&#243;",
ocirc => "&#244;",
otilde => "&#245;",
ouml => "&#246;",
divide => "&#247;",
oslash => "&#248;",
ugrave => "&#249;",
uacute => "&#250;",
ucirc => "&#251;",
uuml => "&#252;",
yacute => "&#253;",
thorn => "&#254;",
yuml => "&#255;",
nbsp => "&#160;",
iexcl => "&#161;",
cent => "&#162;",
pound => "&#163;",
curren => "&#164;",
yen => "&#165;",
brvbar => "&#166;",
sect => "&#167;",
uml => "&#168;",
copy => "&#169;",
ordf => "&#170;",
laquo => "&#171;",
not => "&#172;",
shy => "&#173;",
reg => "&#174;",
macr => "&#175;",
deg => "&#176;",
plusmn => "&#177;",
sup2 => "&#178;",
sup3 => "&#179;",
acute => "&#180;",
micro => "&#181;",
para => "&#182;",
middot => "&#183;",
cedil => "&#184;",
sup1 => "&#185;",
ordm => "&#186;",
raquo => "&#187;",
frac14 => "&#188;",
frac12 => "&#189;",
frac34 => "&#190;",
iquest => "&#191;",
Agrave => "&#192;",
Aacute => "&#193;",
Acirc => "&#194;",
Atilde => "&#195;",
Auml => "&#196;",
Aring => "&#197;",
AElig => "&#198;",
Ccedil => "&#199;",
Egrave => "&#200;",
Eacute => "&#201;",
Ecirc => "&#202;",
Euml => "&#203;",
Igrave => "&#204;",
Iacute => "&#205;",
Icirc => "&#206;",
Iuml => "&#207;",
ETH => "&#208;",
Ntilde => "&#209;",
Ograve => "&#210;",
Oacute => "&#211;",
Ocirc => "&#212;",
Otilde => "&#213;",
Ouml => "&#214;",
times => "&#215;",
Oslash => "&#216;",
Ugrave => "&#217;",
Uacute => "&#218;",
Ucirc => "&#219;",
Uuml => "&#220;",
Yacute => "&#221;",
THORN => "&#222;",
szlig => "&#223;",
agrave => "&#224;",
aacute => "&#225;",
acirc => "&#226;",
atilde => "&#227;",
auml => "&#228;",
aring => "&#229;",
aelig => "&#230;",
ccedil => "&#231;",
egrave => "&#232;",
eacute => "&#233;",
ecirc => "&#234;",
euml => "&#235;",
igrave => "&#236;",
iacute => "&#237;",
icirc => "&#238;",
iuml => "&#239;",
eth => "&#240;",
ntilde => "&#241;",
ograve => "&#242;",
oacute => "&#243;",
ocirc => "&#244;",
otilde => "&#245;",
ouml => "&#246;",
divide => "&#247;",
oslash => "&#248;",
ugrave => "&#249;",
uacute => "&#250;",
ucirc => "&#251;",
uuml => "&#252;",
yacute => "&#253;",
thorn => "&#254;",
yuml => "&#255;",
);
my $entities = join( '|', keys %entity );
sub encode_xml_element {
my $text = shift;
sub encode_xml_element($) {
my $text = shift;
my $encoded_text = '';
my $encoded_text = '';
while ( $text =~ s/(.*?)(\<\!\[CDATA\[.*?\]\]\>)//s ) {
$encoded_text .= encode_xml_element_text($1) . $2;
}
$encoded_text .= encode_xml_element_text($text);
while ( $text =~ s/(.*?)(\<\!\[CDATA\[.*?\]\]\>)//s ) {
$encoded_text .= encode_xml_element_text($1) . $2;
}
$encoded_text .= encode_xml_element_text($text);
return $encoded_text;
return $encoded_text;
}
sub encode_xml_element_text {
my $text = shift;
sub encode_xml_element_text ($) {
my $text = shift;
$text =~ s/&(?!(#[0-9]+|#x[0-9a-fA-F]+|\w+);)/&amp;/g;
$text =~ s/&($entities);/$entity{$1}/g;
$text =~ s/\</\&lt\;/g;
$text =~ s/\>/\&gt\;/g;
$text =~ s/&(?!(#[0-9]+|#x[0-9a-fA-F]+|\w+);)/&amp;/g;
$text =~ s/&($entities);/$entity{$1}/g;
$text =~ s/\</\&lt\;/g;
$text =~ s/\>/\&gt\;/g;
return $text;
return $text;
}
sub escapeHtml{
my $s=shift;
return HTML::Entities::encode_entities($s,q{&<>"'});
sub escapeHtml($) {
my $s = shift;
return HTML::Entities::encode_entities( $s, q{&<>"'} );
}
#do not delete last line!

19
lib/calcms/params.pm
View File

@@ -1,7 +1,8 @@
package params;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Apache2::Request();
@@ -12,11 +13,11 @@ our @EXPORT_OK = qw(get isJson);
sub debug;
my $isJson = 0;
sub isJson {
sub isJson () {
return $isJson;
}
sub get {
sub get ($) {
my $r = shift;
my $tmp_dir = '/var/tmp/';
@@ -50,18 +51,18 @@ sub get {
$isJson = 1 if ( defined $params->{json} ) && ( $params->{json} eq '1' );
if ( defined $status ) {
$status = '' if $status eq 'Success' ;
$status = '' if $status eq 'Missing input data' ;
if ($status ne ''){
$cgi=new CGI::Simple() unless defined $cgi;
$status = '' if $status eq 'Success';
$status = '' if $status eq 'Missing input data';
if ( $status ne '' ) {
$cgi = new CGI::Simple() unless defined $cgi;
print $cgi->header . $status . "\n";
} ;
}
}
return ( $cgi, $params, $status );
}
sub debug {
sub debug ($) {
my $message = shift;
}

333
lib/calcms/password_requests.pm
View File

@@ -1,14 +1,15 @@
package password_requests;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Session::Token();
# table: calcms_password_requests
use base 'Exporter';
our @EXPORT_OK = qw(get insert delete get_columns);
our @EXPORT_OK = qw(get insert delete get_columns);
use mail;
use uac;
@@ -17,235 +18,235 @@ use auth;
sub debug;
sub get_columns {
my $config = shift;
sub get_columns ($) {
my $config = shift;
my $dbh = db::connect($config);
my $cols = db::get_columns( $dbh, 'calcms_password_requests' );
my $columns = {};
for my $col (@$cols) {
$columns->{$col} = 1;
}
return $columns;
my $dbh = db::connect($config);
my $cols = db::get_columns( $dbh, 'calcms_password_requests' );
my $columns = {};
for my $col (@$cols) {
$columns->{$col} = 1;
}
return $columns;
}
sub get {
my $config = shift;
my $condition = shift;
sub get ($$) {
my $config = shift;
my $condition = shift;
my $dbh = db::connect($config);
my $dbh = db::connect($config);
my @conditions = ();
my @bind_values = ();
my @conditions = ();
my @bind_values = ();
if ( defined $condition->{user} ) {
push @conditions, 'user=?';
push @bind_values, $condition->{user};
}
if ( defined $condition->{user} ) {
push @conditions, 'user=?';
push @bind_values, $condition->{user};
}
if ( defined $condition->{token} ) {
push @conditions, 'token=?';
push @bind_values, $condition->{token};
}
if ( defined $condition->{token} ) {
push @conditions, 'token=?';
push @bind_values, $condition->{token};
}
return undef if ( scalar @conditions ) == 0;
return undef if ( scalar @conditions ) == 0;
my $conditions = " where " . join( " and ", @conditions );
my $query = qq{
my $conditions = " where " . join( " and ", @conditions );
my $query = qq{
select *
from calcms_password_requests
$conditions
};
#print $query."\n".Dumper(\@bind_values);
#print $query."\n".Dumper(\@bind_values);
my $entries = db::get( $dbh, $query, \@bind_values );
return $entries->[0] || undef;
my $entries = db::get( $dbh, $query, \@bind_values );
return $entries->[0] || undef;
}
sub update {
my $config = shift;
my $entry = shift;
sub update($$) {
my $config = shift;
my $entry = shift;
return unless defined $entry->{user};
return unless defined $entry->{user};
my $dbh = db::connect($config);
my $values = join( ",", map { $_ . '=?' } ( keys %$entry ) );
my @bind_values = map { $entry->{$_} } ( keys %$entry );
push @bind_values, $entry->{token};
my $dbh = db::connect($config);
my $values = join( ",", map { $_ . '=?' } ( keys %$entry ) );
my @bind_values = map { $entry->{$_} } ( keys %$entry );
push @bind_values, $entry->{token};
my $query = qq{
my $query = qq{
update calcms_password_requests
set $values
where token=?
};
print STDERR $query . Dumper( \@bind_values );
db::put( $dbh, $query, \@bind_values );
print STDERR $query . Dumper( \@bind_values );
db::put( $dbh, $query, \@bind_values );
}
sub insert {
my $config = shift;
my $entry = shift;
sub insert ($$) {
my $config = shift;
my $entry = shift;
return undef unless defined $entry->{user};
return undef unless defined $entry->{user};
my $dbh = db::connect($config);
print STDERR 'insert ' . Dumper($entry);
return db::insert( $dbh, 'calcms_password_requests', $entry );
my $dbh = db::connect($config);
print STDERR 'insert ' . Dumper($entry);
return db::insert( $dbh, 'calcms_password_requests', $entry );
}
sub delete {
my $config = shift;
my $condition = shift;
sub delete ($$) {
my $config = shift;
my $condition = shift;
my @conditions = ();
my @bind_values = ();
my @conditions = ();
my @bind_values = ();
if ( ( defined $condition->{user} ) && ( $condition->{user} ne '' ) ) {
push @conditions, 'user=?';
push @bind_values, $condition->{user};
}
if ( ( defined $condition->{user} ) && ( $condition->{user} ne '' ) ) {
push @conditions, 'user=?';
push @bind_values, $condition->{user};
}
if ( ( defined $condition->{token} ) && ( $condition->{token} ne '' ) ) {
push @conditions, 'token=?';
push @bind_values, $condition->{token};
}
if ( ( defined $condition->{token} ) && ( $condition->{token} ne '' ) ) {
push @conditions, 'token=?';
push @bind_values, $condition->{token};
}
return if ( scalar @conditions ) == 0;
my $conditions = " where " . join( " and ", @conditions );
return if ( scalar @conditions ) == 0;
my $conditions = " where " . join( " and ", @conditions );
my $dbh = db::connect($config);
my $dbh = db::connect($config);
my $query = qq{
my $query = qq{
delete
from calcms_password_requests
$conditions
};
print STDERR "$query " . Dumper( \@bind_values );
db::put( $dbh, $query, \@bind_values );
print STDERR "$query " . Dumper( \@bind_values );
db::put( $dbh, $query, \@bind_values );
}
sub sendToken {
my $config = shift;
my $entry = shift;
sub sendToken ($$) {
my $config = shift;
my $entry = shift;
return undef unless defined $entry->{user};
return undef unless defined $entry->{user};
my $user = uac::get_user( $config, $entry->{user} );
return undef unless defined $user;
my $user = uac::get_user( $config, $entry->{user} );
return undef unless defined $user;
# check age of existing entry
my $oldEntry = password_requests::get( $config, { user => $entry->{user} } );
if ( defined $oldEntry ) {
my $createdAt = $oldEntry->{created_at};
print STDERR Dumper($oldEntry);
print STDERR "createdAt=$createdAt\n";
my $age = time() - time::datetime_to_time($createdAt);
if ( $age < 60 ) {
print STDERR "too many requests";
return undef;
}
print STDERR "age=$age\n";
}
password_requests::delete( $config, $entry );
# check age of existing entry
my $oldEntry = password_requests::get( $config, { user => $entry->{user} } );
if ( defined $oldEntry ) {
my $createdAt = $oldEntry->{created_at};
print STDERR Dumper($oldEntry);
print STDERR "createdAt=$createdAt\n";
my $age = time() - time::datetime_to_time($createdAt);
if ( $age < 60 ) {
print STDERR "too many requests";
return undef;
}
print STDERR "age=$age\n";
}
password_requests::delete( $config, $entry );
$entry->{max_attempts} = 0;
$entry->{token} = Session::Token->new->get;
$entry->{max_attempts} = 0;
$entry->{token} = Session::Token->new->get;
my $baseUrl = $config->{locations}->{source_base_url} . $config->{locations}->{editor_base_url};
my $url = $baseUrl . "/requestPassword.cgi?token=" . $entry->{token};
my $content = "Hi,$user->{full_name}\n\n";
$content .= "Someone just tried to reset your password for $baseUrl.\n\n";
$content .= "If you like to set a new password, please follow the link below\n";
$content .= $url . "\n\n";
$content .= "If you do not like to set a new password, please ignore this mail.\n";
my $baseUrl = $config->{locations}->{source_base_url} . $config->{locations}->{editor_base_url};
my $url = $baseUrl . "/requestPassword.cgi?token=" . $entry->{token};
my $content = "Hi,$user->{full_name}\n\n";
$content .= "Someone just tried to reset your password for $baseUrl.\n\n";
$content .= "If you like to set a new password, please follow the link below\n";
$content .= $url . "\n\n";
$content .= "If you do not like to set a new password, please ignore this mail.\n";
mail::send(
{
"To" => $user->{email},
"Subject" => "request to change password for $baseUrl",
"Data" => $content
}
);
mail::send(
{
"To" => $user->{email},
"Subject" => "request to change password for $baseUrl",
"Data" => $content
}
);
password_requests::insert( $config, $entry );
password_requests::insert( $config, $entry );
}
sub changePassword {
my $config = shift;
my $request = shift;
my $userName = shift;
sub changePassword ($$$) {
my $config = shift;
my $request = shift;
my $userName = shift;
my $params = $request->{params}->{checked};
my $permissions = $request->{permissions};
my $params = $request->{params}->{checked};
my $permissions = $request->{permissions};
unless ( ( defined $userName ) || ( $userName eq '' ) ) {
return { error => 'user not found' };
}
unless ( ( defined $userName ) || ( $userName eq '' ) ) {
return { error => 'user not found' };
}
my $user = uac::get_user( $config, $userName );
my $user = uac::get_user( $config, $userName );
unless ( ( defined $user ) && ( defined $user->{id} ) && ( $user->{id} ne '' ) ) {
return { error => 'user id not found' };
}
unless ( ( defined $user ) && ( defined $user->{id} ) && ( $user->{id} ne '' ) ) {
return { error => 'user id not found' };
}
unless ( password_requests::checkPassword( $params->{user_password} ) ) {
return { error => 'password does not meet requirements' };
}
unless ( password_requests::checkPassword( $params->{user_password} ) ) {
return { error => 'password does not meet requirements' };
}
if ( $params->{user_password} ne $params->{user_password2} ) {
return { error => 'entered passwords do not match' };
}
if ( $params->{user_password} ne $params->{user_password2} ) {
return { error => 'entered passwords do not match' };
}
#print STDERR "error at changing password:" . Dumper($errors);
#print STDERR "error at changing password:" . Dumper($errors);
my $crypt = auth::crypt_password( $params->{user_password} );
$user = { id => $user->{id} };
$user->{salt} = $crypt->{salt};
$user->{pass} = $crypt->{crypt};
my $crypt = auth::crypt_password( $params->{user_password} );
$user = { id => $user->{id} };
$user->{salt} = $crypt->{salt};
$user->{pass} = $crypt->{crypt};
#print '<pre>'.Dumper($user).'</pre>';
$config->{access}->{write} = 1;
print STDERR "update user" . Dumper($user);
my $result = uac::update_user( $config, $user );
print STDERR "result:" . Dumper($result);
$config->{access}->{write} = 0;
return { success => "password changed for $userName" };
#print '<pre>'.Dumper($user).'</pre>';
$config->{access}->{write} = 1;
print STDERR "update user" . Dumper($user);
my $result = uac::update_user( $config, $user );
print STDERR "result:" . Dumper($result);
$config->{access}->{write} = 0;
return { success => "password changed for $userName" };
}
sub checkPassword {
my $password = shift;
unless ( defined $password || $password eq '' ) {
error("password is empty");
return;
}
if ( length($password) < 8 ) {
error("password to short");
return 0;
}
unless ( $password =~ /[a-z]/ ) {
error("password should contains at least one small character");
return 0;
}
unless ( $password =~ /[A-Z]/ ) {
error("password should contains at least one big character");
return 0;
}
unless ( $password =~ /[0-9]/ ) {
error("password should contains at least one number");
return 0;
}
unless ( $password =~ /[^a-zA-Z0-9]/ ) {
error("password should contains at least one special character");
return 0;
}
return 1;
sub checkPassword($) {
my $password = shift;
unless ( defined $password || $password eq '' ) {
error("password is empty");
return;
}
if ( length($password) < 8 ) {
error("password to short");
return 0;
}
unless ( $password =~ /[a-z]/ ) {
error("password should contains at least one small character");
return 0;
}
unless ( $password =~ /[A-Z]/ ) {
error("password should contains at least one big character");
return 0;
}
unless ( $password =~ /[0-9]/ ) {
error("password should contains at least one number");
return 0;
}
unless ( $password =~ /[^a-zA-Z0-9]/ ) {
error("password should contains at least one special character");
return 0;
}
return 1;
}
sub error {
my $msg = shift;
print "ERROR: $msg<br/>\n";
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}
#do not delete last line!

531
lib/calcms/playout.pm
View File

@@ -1,7 +1,8 @@
package playout;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Date::Calc();
@@ -10,84 +11,85 @@ use time();
use series_events();
use base 'Exporter';
our @EXPORT_OK = qw(get_columns get sync);
our @EXPORT_OK = qw(get_columns get sync);
sub debug;
sub get_columns {
my $config = shift;
sub get_columns ($) {
my $config = shift;
my $dbh = db::connect($config);
my $cols = db::get_columns( $dbh, 'calcms_playout' );
my $columns = {};
for my $col (@$cols) {
$columns->{$col} = 1;
}
return $columns;
my $dbh = db::connect($config);
my $cols = db::get_columns( $dbh, 'calcms_playout' );
my $columns = {};
for my $col (@$cols) {
$columns->{$col} = 1;
}
return $columns;
}
# get playout entries
sub get {
my $config = shift;
my $condition = shift;
sub get($$) {
my $config = shift;
my $condition = shift;
return undef unless defined $condition->{studio_id};
return undef unless defined $condition->{studio_id};
my $date_range_include = 0;
$date_range_include = 1 if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
my $date_range_include = 0;
$date_range_include = 1
if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
my $dbh = db::connect($config);
my $dbh = db::connect($config);
my @conditions = ();
my @bind_values = ();
my @conditions = ();
my @bind_values = ();
if ( ( defined $condition->{project_id} ) && ( $condition->{project_id} ne '' ) ) {
push @conditions, 'project_id=?';
push @bind_values, $condition->{project_id};
}
if ( ( defined $condition->{project_id} ) && ( $condition->{project_id} ne '' ) ) {
push @conditions, 'project_id=?';
push @bind_values, $condition->{project_id};
}
if ( ( defined $condition->{studio_id} ) && ( $condition->{studio_id} ne '' ) ) {
push @conditions, 'studio_id=?';
push @bind_values, $condition->{studio_id};
}
if ( ( defined $condition->{studio_id} ) && ( $condition->{studio_id} ne '' ) ) {
push @conditions, 'studio_id=?';
push @bind_values, $condition->{studio_id};
}
if ( ( defined $condition->{start_at} ) && ( $condition->{start_at} ne '' ) ) {
push @conditions, 'start=?';
push @bind_values, $condition->{start_at};
}
if ( ( defined $condition->{start_at} ) && ( $condition->{start_at} ne '' ) ) {
push @conditions, 'start=?';
push @bind_values, $condition->{start_at};
}
if ( ( defined $condition->{from} ) && ( $condition->{from} ne '' ) ) {
if ( $date_range_include == 1 ) {
push @conditions, 'end_date>=?';
push @bind_values, $condition->{from};
} else {
push @conditions, 'start_date>=?';
push @bind_values, $condition->{from};
}
}
if ( ( defined $condition->{from} ) && ( $condition->{from} ne '' ) ) {
if ( $date_range_include == 1 ) {
push @conditions, 'end_date>=?';
push @bind_values, $condition->{from};
} else {
push @conditions, 'start_date>=?';
push @bind_values, $condition->{from};
}
}
if ( ( defined $condition->{till} ) && ( $condition->{till} ne '' ) ) {
if ( $date_range_include == 1 ) {
push @conditions, 'start_date<=?';
push @bind_values, $condition->{till};
} else {
push @conditions, 'end_date<=?';
push @bind_values, $condition->{till};
}
}
if ( ( defined $condition->{till} ) && ( $condition->{till} ne '' ) ) {
if ( $date_range_include == 1 ) {
push @conditions, 'start_date<=?';
push @bind_values, $condition->{till};
} else {
push @conditions, 'end_date<=?';
push @bind_values, $condition->{till};
}
}
my $limit = '';
if ( ( defined $condition->{limit} ) && ( $condition->{limit} ne '' ) ) {
$limit = 'limit ' . $condition->{limit};
}
my $limit = '';
if ( ( defined $condition->{limit} ) && ( $condition->{limit} ne '' ) ) {
$limit = 'limit ' . $condition->{limit};
}
my $conditions = '';
$conditions = " where " . join( " and ", @conditions ) if ( @conditions > 0 );
my $conditions = '';
$conditions = " where " . join( " and ", @conditions ) if ( @conditions > 0 );
my $order = 'start';
$order = $condition->{order} if ( defined $condition->{order} ) && ( $condition->{order} ne '' );
my $order = 'start';
$order = $condition->{order} if ( defined $condition->{order} ) && ( $condition->{order} ne '' );
my $query = qq{
my $query = qq{
select date(start) start_date
,date(end) end_date
,dayname(start) weekday
@@ -120,39 +122,39 @@ sub get {
$limit
};
#print STDERR Dumper($query).Dumper(\@bind_values);
my $entries = db::get( $dbh, $query, \@bind_values );
return $entries;
#print STDERR Dumper($query).Dumper(\@bind_values);
my $entries = db::get( $dbh, $query, \@bind_values );
return $entries;
}
# update playout entries for a given date span
# insert, update and delete entries
sub sync {
my $config = shift;
my $options = shift;
sub sync ($$) {
my $config = shift;
my $options = shift;
#print STDERR Dumper($config);
print STDERR "upload " . Dumper($options);
return undef unless defined $options->{project_id};
return undef unless defined $options->{studio_id};
return undef unless defined $options->{from};
return undef unless defined $options->{till};
return undef unless defined $options->{events};
#print STDERR Dumper($config);
print STDERR "upload " . Dumper($options);
return undef unless defined $options->{project_id};
return undef unless defined $options->{studio_id};
return undef unless defined $options->{from};
return undef unless defined $options->{till};
return undef unless defined $options->{events};
my $project_id = $options->{project_id};
my $studio_id = $options->{studio_id};
my $updates = $options->{events};
my $project_id = $options->{project_id};
my $studio_id = $options->{studio_id};
my $updates = $options->{events};
# get new entries by date
my $update_by_date = {};
for my $entry (@$updates) {
$update_by_date->{ $entry->{start} } = $entry;
}
# get new entries by date
my $update_by_date = {};
for my $entry (@$updates) {
$update_by_date->{ $entry->{start} } = $entry;
}
# get database entries
my $bind_values = [ $options->{project_id}, $options->{studio_id}, $options->{from}, $options->{till} ];
# get database entries
my $bind_values = [ $options->{project_id}, $options->{studio_id}, $options->{from}, $options->{till} ];
my $query = qq{
my $query = qq{
select *
from calcms_playout
where project_id=?
@@ -161,132 +163,135 @@ sub sync {
and end <= ?
order by start
};
print STDERR "from:$options->{from} till:$options->{till}\n";
my $dbh = db::connect($config);
my $entries = db::get( $dbh, $query, $bind_values );
print STDERR "from:$options->{from} till:$options->{till}\n";
my $dbh = db::connect($config);
my $entries = db::get( $dbh, $query, $bind_values );
#print STDERR "entries:".Dumper($entries);
#print STDERR "entries:".Dumper($entries);
# get database entries by date
my $entries_by_date = {};
for my $entry (@$entries) {
# get database entries by date
my $entries_by_date = {};
for my $entry (@$entries) {
# store entry by date
my $start = $entry->{start};
$entries_by_date->{$start} = $entry;
# store entry by date
my $start = $entry->{start};
$entries_by_date->{$start} = $entry;
# remove outdated entries
unless ( defined $update_by_date->{$start} ) {
print STDERR "delete:" . Dumper($entry);
playout::delete( $config, $dbh, $entry );
my $result = series_events::set_playout_status(
$config,
{
project_id => $project_id,
studio_id => $studio_id,
start => $entry->{start},
playout => 0,
}
);
print STDERR "delete playout_status result=" . $result . "\n";
next;
}
# remove outdated entries
unless ( defined $update_by_date->{$start} ) {
print STDERR "delete:" . Dumper($entry);
playout::delete( $config, $dbh, $entry );
my $result = series_events::set_playout_status(
$config,
{
project_id => $project_id,
studio_id => $studio_id,
start => $entry->{start},
playout => 0,
}
);
print STDERR "delete playout_status result=" . $result . "\n";
next;
}
# update existing entries
if ( defined $update_by_date->{$start} ) {
next if has_changed( $entry, $update_by_date->{$start} ) == 0;
print STDERR "update:" . Dumper($entry);
playout::update( $config, $dbh, $entry, $update_by_date->{$start} );
my $result = series_events::set_playout_status(
$config,
{
project_id => $project_id,
studio_id => $studio_id,
start => $entry->{start},
playout => 1,
}
);
print STDERR "update playout_status result=" . $result . "\n";
next;
}
}
# update existing entries
if ( defined $update_by_date->{$start} ) {
next if has_changed( $entry, $update_by_date->{$start} ) == 0;
print STDERR "update:" . Dumper($entry);
playout::update( $config, $dbh, $entry, $update_by_date->{$start} );
my $result = series_events::set_playout_status(
$config,
{
project_id => $project_id,
studio_id => $studio_id,
start => $entry->{start},
playout => 1,
}
);
print STDERR "update playout_status result=" . $result . "\n";
next;
}
}
# insert new entries
for my $entry (@$updates) {
my $start = $entry->{start};
unless ( defined $entries_by_date->{$start} ) {
$entry->{project_id} = $project_id;
$entry->{studio_id} = $studio_id;
print STDERR "insert:" . Dumper($entry);
playout::insert( $config, $dbh, $entry );
my $result = series_events::set_playout_status(
$config,
{
project_id => $project_id,
studio_id => $studio_id,
start => $entry->{start},
playout => 1,
}
);
print STDERR "insert playout_status result=" . $result . "\n";
}
}
return 1;
# insert new entries
for my $entry (@$updates) {
my $start = $entry->{start};
unless ( defined $entries_by_date->{$start} ) {
$entry->{project_id} = $project_id;
$entry->{studio_id} = $studio_id;
print STDERR "insert:" . Dumper($entry);
playout::insert( $config, $dbh, $entry );
my $result = series_events::set_playout_status(
$config,
{
project_id => $project_id,
studio_id => $studio_id,
start => $entry->{start},
playout => 1,
}
);
print STDERR "insert playout_status result=" . $result . "\n";
}
}
return 1;
}
sub has_changed {
my $oldEntry = shift;
my $newEntry = shift;
sub has_changed ($$) {
my $oldEntry = shift;
my $newEntry = shift;
my $update = 0;
for my $key (
'duration', 'errors', 'file', 'channels', 'format', 'format_version',
'format_profile', 'format_settings', 'stream_size', 'bitrate', 'bitrate_mode', 'sampling_rate',
'writing_library', 'modified_at'
)
{
return 1 if ( $oldEntry->{$key} || '' ) ne ( $newEntry->{$key} || '' );
}
return 0;
my $update = 0;
for my $key (
'duration', 'errors', 'file', 'channels',
'format', 'format_version', 'format_profile', 'format_settings',
'stream_size', 'bitrate', 'bitrate_mode', 'sampling_rate',
'writing_library', 'modified_at'
)
{
return 1 if ( $oldEntry->{$key} || '' ) ne ( $newEntry->{$key} || '' );
}
return 0;
}
# update playout entry if differs to old values
sub update {
my $config = shift;
my $dbh = shift;
my $oldEntry = shift;
my $newEntry = shift;
sub update ($$$$) {
my $config = shift;
my $dbh = shift;
my $oldEntry = shift;
my $newEntry = shift;
return if has_changed( $oldEntry, $newEntry ) == 0;
return if has_changed( $oldEntry, $newEntry ) == 0;
for my $key (
'duration', 'errors', 'file', 'channels', 'format', 'format_version',
'format_profile', 'format_settings', 'stream_size', 'bitrate', 'bitrate_mode', 'sampling_rate',
'writing_library', 'rms_left', 'rms_right', 'rms_image', 'replay_gain', 'modified_at'
)
{
if ( ( $oldEntry->{$key} || '' ) ne ( $newEntry->{$key} || '' ) ) {
$oldEntry->{$key} = $newEntry->{$key};
}
}
for my $key (
'duration', 'errors', 'file', 'channels',
'format', 'format_version', 'format_profile', 'format_settings',
'stream_size', 'bitrate', 'bitrate_mode', 'sampling_rate',
'writing_library', 'rms_left', 'rms_right', 'rms_image',
'replay_gain', 'modified_at'
)
{
if ( ( $oldEntry->{$key} || '' ) ne ( $newEntry->{$key} || '' ) ) {
$oldEntry->{$key} = $newEntry->{$key};
}
}
my $entry = $oldEntry;
print STDERR "update:" . Dumper($entry);
my $entry = $oldEntry;
print STDERR "update:" . Dumper($entry);
my $day_start = $config->{date}->{day_starting_hour};
$entry->{end} = playout::getEnd( $entry->{start}, $entry->{duration} );
$entry->{start_date} = time::add_hours_to_datetime( $entry->{start}, -$day_start );
$entry->{end_date} = time::add_hours_to_datetime( $entry->{end}, -$day_start );
my $day_start = $config->{date}->{day_starting_hour};
$entry->{end} = playout::getEnd( $entry->{start}, $entry->{duration} );
$entry->{start_date} = time::add_hours_to_datetime( $entry->{start}, -$day_start );
$entry->{end_date} = time::add_hours_to_datetime( $entry->{end}, -$day_start );
my $bind_values = [
$entry->{end}, $entry->{duration}, $entry->{file}, $entry->{errors},
$entry->{start_date}, $entry->{end_date}, $entry->{channels}, $entry->{'format'},
$entry->{format_version}, $entry->{format_profile}, $entry->{format_settings}, $entry->{stream_size},
$entry->{bitrate}, $entry->{bitrate_mode}, $entry->{sampling_rate}, $entry->{writing_library},
$entry->{rms_left}, $entry->{rms_right}, $entry->{rms_image}, $entry->{replay_gain},
$entry->{modified_at}, $entry->{project_id}, $entry->{studio_id}, $entry->{start}
];
my $query = qq{
my $bind_values = [
$entry->{end}, $entry->{duration}, $entry->{file}, $entry->{errors},
$entry->{start_date}, $entry->{end_date}, $entry->{channels}, $entry->{'format'},
$entry->{format_version}, $entry->{format_profile}, $entry->{format_settings}, $entry->{stream_size},
$entry->{bitrate}, $entry->{bitrate_mode}, $entry->{sampling_rate}, $entry->{writing_library},
$entry->{rms_left}, $entry->{rms_right}, $entry->{rms_image}, $entry->{replay_gain},
$entry->{modified_at}, $entry->{project_id}, $entry->{studio_id}, $entry->{start}
];
my $query = qq{
update calcms_playout
set end=?, duration=?, file=?, errors=?,
start_date=?, end_date=?,
@@ -296,100 +301,100 @@ sub update {
replay_gain=?, modified_at=?
where project_id=? and studio_id=? and start=?
};
return db::put( $dbh, $query, $bind_values );
return db::put( $dbh, $query, $bind_values );
}
# insert playout entry
sub insert {
my $config = shift;
my $dbh = shift;
my $entry = shift;
sub insert ($$$) {
my $config = shift;
my $dbh = shift;
my $entry = shift;
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{start};
return undef unless defined $entry->{duration};
return undef unless defined $entry->{file};
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{start};
return undef unless defined $entry->{duration};
return undef unless defined $entry->{file};
my $day_start = $config->{date}->{day_starting_hour};
$entry->{end} = playout::getEnd( $entry->{start}, $entry->{duration} );
$entry->{start_date} = time::add_hours_to_datetime( $entry->{start}, -$day_start );
$entry->{end_date} = time::add_hours_to_datetime( $entry->{end}, -$day_start );
my $day_start = $config->{date}->{day_starting_hour};
$entry->{end} = playout::getEnd( $entry->{start}, $entry->{duration} );
$entry->{start_date} = time::add_hours_to_datetime( $entry->{start}, -$day_start );
$entry->{end_date} = time::add_hours_to_datetime( $entry->{end}, -$day_start );
return db::insert(
$dbh,
'calcms_playout',
{
project_id => $entry->{project_id},
studio_id => $entry->{studio_id},
start => $entry->{start},
end => $entry->{end},
start_date => $entry->{start_date},
end_date => $entry->{end_date},
duration => $entry->{duration},
rms_left => $entry->{rms_left},
rms_right => $entry->{rms_right},
rms_image => $entry->{rms_image},
replay_gain => $entry->{replay_gain},
file => $entry->{file},
errors => $entry->{errors},
channels => $entry->{channels},
"format" => $entry->{"format"},
format_version => $entry->{format_version},
format_profile => $entry->{format_profile},
format_settings => $entry->{format_settings},
stream_size => $entry->{stream_size},
bitrate => $entry->{bitrate},
bitrate_mode => $entry->{bitrate_mode},
sampling_rate => $entry->{sampling_rate},
writing_library => $entry->{writing_library},
modified_at => $entry->{modified_at}
}
);
return db::insert(
$dbh,
'calcms_playout',
{
project_id => $entry->{project_id},
studio_id => $entry->{studio_id},
start => $entry->{start},
end => $entry->{end},
start_date => $entry->{start_date},
end_date => $entry->{end_date},
duration => $entry->{duration},
rms_left => $entry->{rms_left},
rms_right => $entry->{rms_right},
rms_image => $entry->{rms_image},
replay_gain => $entry->{replay_gain},
file => $entry->{file},
errors => $entry->{errors},
channels => $entry->{channels},
"format" => $entry->{"format"},
format_version => $entry->{format_version},
format_profile => $entry->{format_profile},
format_settings => $entry->{format_settings},
stream_size => $entry->{stream_size},
bitrate => $entry->{bitrate},
bitrate_mode => $entry->{bitrate_mode},
sampling_rate => $entry->{sampling_rate},
writing_library => $entry->{writing_library},
modified_at => $entry->{modified_at}
}
);
}
# delete playout entry
sub delete {
my $config = shift;
my $dbh = shift;
my $entry = shift;
sub delete($$$) {
my $config = shift;
my $dbh = shift;
my $entry = shift;
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{start};
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{start};
my $query = qq{
my $query = qq{
delete
from calcms_playout
where project_id=? and studio_id=? and start=?
};
my $bind_values = [ $entry->{project_id}, $entry->{studio_id}, $entry->{start} ];
return db::put( $dbh, $query, $bind_values );
my $bind_values = [ $entry->{project_id}, $entry->{studio_id}, $entry->{start} ];
return db::put( $dbh, $query, $bind_values );
}
sub getEnd {
my $start = shift;
my $duration = shift;
sub getEnd ($$) {
my $start = shift;
my $duration = shift;
# calculate end from start + duration
my @start = @{ time::datetime_to_array($start) };
next unless @start >= 6;
# calculate end from start + duration
my @start = @{ time::datetime_to_array($start) };
next unless @start >= 6;
#print STDERR Dumper(\@start);
my @end_datetime = Date::Calc::Add_Delta_DHMS(
$start[0], $start[1], $start[2], # start date
$start[3], $start[4], $start[5], # start time
0, 0, 0, int($duration) # delta days, hours, minutes, seconds
);
#print STDERR Dumper(\@start);
my @end_datetime = Date::Calc::Add_Delta_DHMS(
$start[0], $start[1], $start[2], # start date
$start[3], $start[4], $start[5], # start time
0, 0, 0, int($duration) # delta days, hours, minutes, seconds
);
#print STDERR Dumper(\@end_datetime);
return time::array_to_datetime( \@end_datetime );
#print STDERR Dumper(\@end_datetime);
return time::array_to_datetime( \@end_datetime );
}
sub error {
my $msg = shift;
print "ERROR: $msg<br/>\n";
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}
#do not delete last line!

54
lib/calcms/project.pm
View File

@@ -1,7 +1,8 @@
package project;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Date::Calc;
@@ -24,7 +25,7 @@ our @EXPORT_OK = qw(
sub debug;
# get project columns
sub get_columns {
sub get_columns ($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -37,7 +38,7 @@ sub get_columns {
}
# get projects
sub get {
sub get ($;$) {
my $config = shift;
my $condition = shift;
@@ -79,7 +80,7 @@ sub get {
}
# requires at least project_id
sub getImageById {
sub getImageById($$) {
my $config = shift;
my $conditions = shift;
@@ -89,9 +90,10 @@ sub getImageById {
return $projects->[0]->{image};
}
sub get_date_range {
sub get_date_range($) {
my $config = shift;
my $query = qq{
my $query = qq{
select min(start_date) start_date, max(end_date) end_date
from calcms_projects
};
@@ -102,7 +104,7 @@ sub get_date_range {
}
# insert project
sub insert {
sub insert($$) {
my $config = shift;
my $entry = shift;
@@ -120,7 +122,7 @@ sub insert {
}
# update project
sub update {
sub update($$) {
my $config = shift;
my $project = shift;
@@ -148,7 +150,7 @@ sub update {
}
# delete project
sub delete {
sub delete ($$) {
my $config = shift;
my $entry = shift;
@@ -157,7 +159,7 @@ sub delete {
}
# get studios of a project
sub get_studios {
sub get_studios($$) {
my $config = shift;
my $options = shift;
@@ -175,7 +177,7 @@ sub get_studios {
return $project_studios;
}
sub get_studio_assignments {
sub get_studio_assignments($$) {
my $config = shift;
my $options = shift;
@@ -208,7 +210,7 @@ sub get_studio_assignments {
}
# is studio assigned to project
sub is_studio_assigned {
sub is_studio_assigned ($$) {
my $config = shift;
my $entry = shift;
@@ -232,7 +234,7 @@ sub is_studio_assigned {
}
# assign studio to project
sub assign_studio {
sub assign_studio($$) {
my $config = shift;
my $entry = shift;
@@ -241,7 +243,7 @@ sub assign_studio {
my $project_id = $entry->{project_id};
my $studio_id = $entry->{studio_id};
if ( is_studio_assigned($entry) ) {
if ( is_studio_assigned( $config, $entry ) ) {
print STDERR "studio $entry->{studio_id} already assigned to project $entry->{project_id}\n";
return 1;
}
@@ -251,7 +253,7 @@ sub assign_studio {
}
# unassign studio from project
sub unassign_studio {
sub unassign_studio($$) {
my $config = shift;
my $entry = shift;
@@ -267,7 +269,7 @@ sub unassign_studio {
}
# get series by project and studio
sub get_series {
sub get_series ($$) {
my $config = shift;
my $options = shift;
@@ -288,7 +290,7 @@ sub get_series {
return $project_series;
}
sub get_series_assignments {
sub get_series_assignments ($$) {
my $config = shift;
my $options = shift;
@@ -326,7 +328,7 @@ sub get_series_assignments {
}
# is series assigned to project and studio
sub is_series_assigned {
sub is_series_assigned ($$) {
my $config = shift;
my $entry = shift;
@@ -352,7 +354,7 @@ sub is_series_assigned {
}
# assign series to project and studio
sub assign_series {
sub assign_series($$) {
my $config = shift;
my $entry = shift;
@@ -364,7 +366,7 @@ sub assign_series {
my $studio_id = $entry->{studio_id};
my $series_id = $entry->{series_id};
if ( is_series_assigned($entry) ) {
if ( is_series_assigned( $config, $entry ) ) {
print STDERR "series $series_id already assigned to project $project_id and studio $studio_id\n";
return return undef;
}
@@ -376,7 +378,7 @@ sub assign_series {
# unassign series from project
# TODO: remove series _single_ if no event is assigned to
sub unassign_series {
sub unassign_series ($$) {
my $config = shift;
my $entry = shift;
@@ -394,7 +396,7 @@ sub unassign_series {
return db::put( $dbh, $sql, $bind_values );
}
sub get_with_dates {
sub get_with_dates($;$) {
my $config = shift;
my $options = shift;
@@ -411,7 +413,7 @@ sub get_with_dates {
}
#TODO: add config
sub get_sorted {
sub get_sorted($) {
my $config = shift;
my $projects = project::get( $config, {} );
my @projects = reverse sort { $a->{end_date} cmp $b->{end_date} } (@$projects);
@@ -428,7 +430,7 @@ sub get_sorted {
}
# internal
sub get_months {
sub get_months ($$;$) {
my $config = shift;
my $project = shift;
my $language = shift || $config->{date}->{language} || 'en';
@@ -476,7 +478,7 @@ sub get_months {
}
# check project_id
sub check {
sub check ($$) {
my $config = shift;
my $options = shift;
return "missing project_id at checking project" unless defined $options->{project_id};
@@ -487,7 +489,7 @@ sub check {
return 1;
}
sub error {
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

11
lib/calcms/roles.pm
View File

@@ -1,6 +1,8 @@
package roles;
use warnings;
use strict;
use warnings;
no warnings 'redefine';
use Apache2::Reload();
@@ -102,6 +104,7 @@ my $ROLES = {
sub get_user($) {
my $config = shift;
my $user = $ENV{REMOTE_USER};
my $users = $config->{users};
return $user if ( defined $users->{$user} );
@@ -110,6 +113,7 @@ sub get_user($) {
sub get_user_permissions($) {
my $config = shift;
my $user = $ENV{REMOTE_USER} || '';
my $roles = $roles::ROLES;
return $roles->{nobody} unless $user =~ /\S/;
@@ -121,8 +125,9 @@ sub get_user_permissions($) {
return $roles->{nobody};
}
sub get_user_jobs {
sub get_user_jobs ($;$) {
my $config = shift;
my $user = $ENV{REMOTE_USER} || '';
return [] unless ( $user =~ /\S/ );
my $result = [];
@@ -138,12 +143,14 @@ sub get_user_jobs {
sub get_jobs($) {
my $config = shift;
return $config->{jobs}->{job};
}
sub get_template_parameters($$) {
my $config = shift;
my $user_permissions = shift;
$user_permissions = roles::get_user_permissions($config) unless defined $user_permissions;
my @user_permissions = ();
for my $usecase ( keys %$user_permissions ) {

65
lib/calcms/series.pm
View File

@@ -1,7 +1,8 @@
package series;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
@@ -28,7 +29,7 @@ our @EXPORT_OK = qw(
sub debug;
# get series columns
sub get_columns {
sub get_columns ($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -41,7 +42,7 @@ sub get_columns {
}
# get series content
sub get {
sub get ($$) {
my $config = shift;
my $condition = shift;
@@ -132,7 +133,7 @@ sub get {
}
# insert series
sub insert {
sub insert ($$) {
my $config = shift;
my $series = shift;
@@ -174,7 +175,7 @@ sub insert {
}
# update series
sub update {
sub update ($$) {
my $config = shift;
my $series = shift;
@@ -210,7 +211,7 @@ sub update {
# delete series, its schedules and series dates
# unassign its users and events
sub delete {
sub delete($$) {
my $config = shift;
my $series = shift;
@@ -300,7 +301,7 @@ sub delete {
}
# get users directly assigned to project, studio, series (editors)
sub get_users {
sub get_users ($$) {
my $config = shift;
my $condition = shift;
@@ -346,7 +347,7 @@ sub get_users {
}
# assign user to series
sub add_user {
sub add_user ($$) {
my $config = shift;
my $entry = shift;
@@ -371,12 +372,13 @@ sub add_user {
insert calcms_user_series
set project_id=?, studio_id=?, series_id=?, user_id=?, modified_by=?, modified_at=now()
};
$bind_values = [ $entry->{project_id}, $entry->{studio_id}, $entry->{series_id}, $entry->{user_id}, $entry->{user} ];
$bind_values =
[ $entry->{project_id}, $entry->{studio_id}, $entry->{series_id}, $entry->{user_id}, $entry->{user} ];
db::put( $dbh, $query, $bind_values );
}
# remove user(s) from series.
sub remove_user {
sub remove_user ($$) {
my $config = shift;
my $condition = shift;
@@ -420,7 +422,7 @@ sub remove_user {
#search events by series_name and title (for events not assigned yet)
#TODO: add location
sub search_events {
sub search_events ($$$) {
my $config = shift;
my $request = shift;
my $options = shift;
@@ -469,7 +471,7 @@ sub search_events {
}
#get events (only assigned ones) by project_id,studio_id,series_id,
sub get_events {
sub get_events ($$) {
my $config = shift;
my $options = shift;
@@ -580,7 +582,7 @@ sub get_events {
# load event given by studio_id, series_id and event_id
# helper for gui - errors are written to gui output
# return undef on error
sub get_event {
sub get_event ($$) {
my $config = shift;
my $options = shift;
@@ -645,7 +647,7 @@ sub get_event {
}
# get name and title of series and age in days ('days_over')
sub get_event_age {
sub get_event_age($$) {
my $config = shift;
my $options = shift;
@@ -702,7 +704,7 @@ sub get_event_age {
}
# is event older than max_age days
sub is_event_older_than_days {
sub is_event_older_than_days ($$) {
my $config = shift;
my $options = shift;
@@ -736,7 +738,7 @@ sub is_event_older_than_days {
return 0;
}
sub get_next_episode {
sub get_next_episode($$) {
my $config = shift;
my $options = shift;
@@ -778,7 +780,7 @@ sub get_next_episode {
return $max + 1;
}
sub get_images {
sub get_images ($$) {
my $config = shift;
my $options = shift;
@@ -842,7 +844,7 @@ sub get_images {
#assign event to series
#TODO: manual assign needs to update automatic one
sub assign_event {
sub assign_event($$) {
my $config = shift;
my $entry = shift;
@@ -879,14 +881,15 @@ sub assign_event {
insert into calcms_series_events (project_id, studio_id, series_id, event_id, manual)
values (?,?,?,?,?)
};
$bind_values = [ $entry->{project_id}, $entry->{studio_id}, $entry->{series_id}, $entry->{event_id}, $entry->{manual} ];
$bind_values =
[ $entry->{project_id}, $entry->{studio_id}, $entry->{series_id}, $entry->{event_id}, $entry->{manual} ];
#print STDERR '<pre>'.$query.Dumper($bind_values).'</pre>';
return db::put( $dbh, $query, $bind_values );
}
#unassign event from series
sub unassign_event {
sub unassign_event($$) {
my $config = shift;
my $entry = shift;
@@ -913,7 +916,7 @@ sub unassign_event {
# put series id to given events (for legacy handling)
# used by calendar
# TODO: optionally add project_id and studio_id to conditions
sub add_series_ids_to_events {
sub add_series_ids_to_events ($$) {
my $config = shift;
my $events = shift;
@@ -961,7 +964,7 @@ sub add_series_ids_to_events {
# add event_ids to series and remove all event ids from series, not given event_ids
# for scan only, used at series
sub set_event_ids {
sub set_event_ids ($$$$$) {
my $config = shift;
my $project_id = shift;
my $studio_id = shift;
@@ -1037,7 +1040,7 @@ sub set_event_ids {
# check if user allowed to update series events
# evaluate permissions and consider editors directly assigned to series
sub can_user_update_events {
sub can_user_update_events ($$) {
my $request = shift;
my $options = shift;
@@ -1058,7 +1061,7 @@ sub can_user_update_events {
# check if user allowed to create series events
# evaluate permissions and consider editors directly assigned to series
sub can_user_create_events {
sub can_user_create_events ($$) {
my $request = shift;
my $options = shift;
@@ -1077,7 +1080,7 @@ sub can_user_create_events {
return is_series_assigned_to_user( $request, $options );
}
sub is_series_assigned_to_user {
sub is_series_assigned_to_user ($$) {
my $request = shift;
my $options = shift;
@@ -1104,7 +1107,7 @@ sub is_series_assigned_to_user {
# check if user is assigned to studio where location matchs to event
# return 1 on success or error text
sub is_event_assigned_to_user {
sub is_event_assigned_to_user ($$) {
my $request = shift;
my $options = shift;
@@ -1157,7 +1160,7 @@ sub is_event_assigned_to_user {
# to find multiple recurrences this does not include the recurrence_count
# use events::get_key to add the recurrence
sub get_event_key {
sub get_event_key ($) {
my $event = shift;
my $program = $event->{program} || '';
@@ -1176,7 +1179,7 @@ sub get_event_key {
return $key;
}
sub update_recurring_events {
sub update_recurring_events ($$) {
my $config = shift;
my $options = shift;
@@ -1217,7 +1220,7 @@ sub update_recurring_events {
next if $event->{recurrence} == 0;
next if $event->{recurrence_count} == 0;
print STDERR
"remove recurrence\t'$event->{event_id}'\t'$event->{start}'\t'$event->{rerun}'\t'$event->{recurrence}'\t'$event->{key}'\n";
"remove recurrence\t'$event->{event_id}'\t'$event->{start}'\t'$event->{rerun}'\t'$event->{recurrence}'\t'$event->{key}'\n";
$event->{recurrence} = 0;
$event->{recurrence_count} = 0;
$event->{rerun} = 0;
@@ -1253,7 +1256,7 @@ sub update_recurring_events {
}
}
sub update_recurring_event {
sub update_recurring_event($$) {
my $config = shift;
my $event = shift;
@@ -1284,7 +1287,7 @@ sub update_recurring_event {
db::put( $dbh, $update_sql, $bind_values );
}
sub error {
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

37
lib/calcms/series_dates.pm
View File

@@ -1,7 +1,8 @@
package series_dates;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Date::Calc();
@@ -16,11 +17,11 @@ use series_schedule();
# columns: id, studio_id, series_id, start(datetime), end(datetime)
# TODO: delete column schedule_id
use base 'Exporter';
our @EXPORT_OK = qw(get_columns get insert update delete get_dates get_series);
our @EXPORT_OK = qw(get_columns get insert update delete get_dates get_series);
sub debug;
sub get_columns {
sub get_columns ($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -34,7 +35,7 @@ sub get_columns {
# get all series_dates for studio_id and series_id within given time range
# calculate start_date, end_date, weeday, day from start and end(datetime)
sub get {
sub get ($;$) {
my $config = shift;
my $condition = shift;
@@ -47,7 +48,6 @@ sub get {
push @conditions, 'project_id=?';
push @bind_values, $condition->{project_id};
}
if ( ( defined $condition->{studio_id} ) && ( $condition->{studio_id} ne '' ) ) {
push @conditions, 'studio_id=?';
push @bind_values, $condition->{studio_id};
@@ -116,7 +116,7 @@ sub get {
}
#check if event is scheduled (on permission check)
sub is_event_scheduled {
sub is_event_scheduled($$) {
my $request = shift;
my $options = shift;
@@ -140,12 +140,13 @@ sub is_event_scheduled {
}
#get all series for given studio_id, time range and search
sub get_series {
sub get_series($;$) {
my $config = shift;
my $condition = shift;
my $date_range_include = 0;
$date_range_include = 1 if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
$date_range_include = 1
if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
my $dbh = db::connect($config);
@@ -259,7 +260,7 @@ sub get_series {
return $entries;
}
sub addSeriesScheduleAttributes {
sub addSeriesScheduleAttributes ($$) {
my $config = shift;
my $entries = shift;
@@ -295,7 +296,7 @@ sub addSeriesScheduleAttributes {
}
#update series dates for all schedules of a series and studio_id
sub update {
sub update($$) {
my $config = shift;
my $entry = shift;
@@ -383,7 +384,7 @@ sub update {
return $j . " dates out of studio times, " . $i;
}
sub get_schedule_dates {
sub get_schedule_dates($$) {
my $schedule = shift;
my $options = shift;
@@ -412,7 +413,7 @@ sub get_schedule_dates {
return $dates;
}
sub get_week_of_month_dates {
sub get_week_of_month_dates ($$$$$$$) {
my $start = shift; # datetime string
my $end = shift; # datetime string
my $duration = shift; # in minutes
@@ -463,7 +464,7 @@ sub get_week_of_month_dates {
}
#add duration to a single date
sub get_single_date {
sub get_single_date ($$) {
my $start_datetime = shift;
my $duration = shift;
@@ -483,12 +484,12 @@ sub get_single_date {
}
#calculate all dates between start_datetime and end_date with duration(minutes) and frequency(days)
sub get_dates {
sub get_dates($$$$) {
my $start_datetime = shift;
my $end_date = shift;
my $duration = shift; # in minutes
my $frequency = shift; # in days
#print "start_datetime:$start_datetime end_date:$end_date duration:$duration frequency:$frequency\n";
#print "start_datetime:$start_datetime end_date:$end_date duration:$duration frequency:$frequency\n";
my @start = @{ time::datetime_to_array($start_datetime) };
return unless @start >= 6;
@@ -540,7 +541,7 @@ sub get_dates {
}
#remove all series_dates for studio_id and series_id
sub delete {
sub delete ($$) {
my $config = shift;
my $entry = shift;
@@ -562,7 +563,7 @@ sub delete {
}
# get all series dates where no event has been created for
sub getDatesWithoutEvent {
sub getDatesWithoutEvent ($$) {
my $config = shift;
my $options = shift;
@@ -592,7 +593,7 @@ sub getDatesWithoutEvent {
}
sub error {
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

34
lib/calcms/series_events.pm
View File

@@ -1,7 +1,8 @@
package series_events;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Date::Calc;
@@ -36,7 +37,7 @@ sub debug;
# update main fields of the event by id
# do not check for project,studio,series
# all changed columns are returned for history handling
sub save_content {
sub save_content($$) {
my $config = shift;
my $entry = shift;
@@ -114,7 +115,7 @@ sub save_content {
# save event time by id
# do not check project, studio, series
# for history handling all changed columns are returned
sub save_event_time {
sub save_event_time($$) {
my $config = shift;
my $entry = shift;
@@ -165,7 +166,7 @@ sub save_event_time {
return $event;
}
sub set_playout_status {
sub set_playout_status ($$) {
my $config = shift;
my $entry = shift;
@@ -208,7 +209,7 @@ sub set_playout_status {
}
# is event assigned to project, studio and series?
sub is_event_assigned {
sub is_event_assigned($$) {
my $config = shift;
my $entry = shift;
@@ -230,7 +231,7 @@ sub is_event_assigned {
return 0;
}
sub delete_event {
sub delete_event ($$) {
my $config = shift;
my $entry = shift;
@@ -269,7 +270,7 @@ sub delete_event {
# key permission: permissions to be checked (one of)
# key check_for: user, studio, series, events, schedule
# return error text or 1 if okay
sub check_permission {
sub check_permission($$) {
my $request = shift;
my $options = shift;
@@ -294,7 +295,7 @@ sub check_permission {
#check if permissions are set (like create_event)
my $found = 0;
for my $permission ( split /\,/, $options->{permission} ) {
$found = 1 if ( defined $permissions->{$permission} ) && ( $permissions->{$permission} ) eq '1' ;
$found = 1 if ( defined $permissions->{$permission} ) && ( $permissions->{$permission} ) eq '1';
}
return 'missing permission to ' . $options->{permission} if $found == 0;
delete $options->{permission};
@@ -343,7 +344,8 @@ sub check_permission {
}
if ( ( defined $check->{studio} ) && ( project::is_series_assigned( $config, $options ) == 0 ) ) {
return "Series '$series_name' ($options->{series_id}) is not assigned to studio '$studio_name' ($options->{studio_id})";
return
"Series '$series_name' ($options->{series_id}) is not assigned to studio '$studio_name' ($options->{studio_id})";
}
# check series and can user update events
@@ -412,7 +414,7 @@ sub check_permission {
# category, time_of_day,
#insert event
sub insert_event {
sub insert_event ($$) {
my $config = shift;
my $options = shift;
@@ -443,7 +445,11 @@ sub insert_event {
$event = series_events::add_event_dates( $config, $event, $params );
#get event content from series
for my $attr ( 'program', 'series_name', 'title', 'excerpt', 'content', 'topic', 'image', 'episode', 'podcast_url', 'archive_url' ) {
for my $attr (
'program', 'series_name', 'title', 'excerpt', 'content', 'topic',
'image', 'episode', 'podcast_url', 'archive_url'
)
{
$event->{$attr} = $serie->{$attr} if defined $serie->{$attr};
}
$event->{series_image} = $serie->{image} if defined $serie->{image};
@@ -488,7 +494,7 @@ sub insert_event {
}
#set start, end, start-date, end_date to an event
sub add_event_dates {
sub add_event_dates($$$) {
my $config = shift;
my $event = shift;
my $params = shift;
@@ -504,7 +510,7 @@ sub add_event_dates {
return $event;
}
sub update_series_images {
sub update_series_images ($$) {
my $config = shift;
my $options = shift;
@@ -530,7 +536,7 @@ sub update_series_images {
}
}
sub error {
sub error ($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

218
lib/calcms/series_schedule.pm
View File

@@ -1,7 +1,9 @@
package series_schedule;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use series_dates();
@@ -17,168 +19,168 @@ use series_dates();
# nextDay (add 24 hours to start)
use base 'Exporter';
our @EXPORT_OK = qw(get_columns get insert update delete);
our @EXPORT_OK = qw(get_columns get insert update delete);
sub debug;
sub get_columns {
my $config = shift;
sub get_columns ($) {
my $config = shift;
my $dbh = db::connect($config);
my $cols = db::get_columns( $dbh, 'calcms_series_schedule' );
my $columns = {};
for my $col (@$cols) {
$columns->{$col} = 1;
}
return $columns;
my $dbh = db::connect($config);
my $cols = db::get_columns( $dbh, 'calcms_series_schedule' );
my $columns = {};
for my $col (@$cols) {
$columns->{$col} = 1;
}
return $columns;
}
#map schedule id to id
sub get {
my $config = shift;
my $condition = shift;
sub get($$) {
my $config = shift;
my $condition = shift;
my $dbh = db::connect($config);
my $dbh = db::connect($config);
my @conditions = ();
my @bind_values = ();
my @conditions = ();
my @bind_values = ();
if ( ( defined $condition->{project_id} ) && ( $condition->{project_id} ne '' ) ) {
push @conditions, 'project_id=?';
push @bind_values, $condition->{project_id};
}
if ( ( defined $condition->{studio_id} ) && ( $condition->{studio_id} ne '' ) ) {
push @conditions, 'studio_id=?';
push @bind_values, $condition->{studio_id};
}
if ( ( defined $condition->{project_id} ) && ( $condition->{project_id} ne '' ) ) {
push @conditions, 'project_id=?';
push @bind_values, $condition->{project_id};
}
if ( ( defined $condition->{studio_id} ) && ( $condition->{studio_id} ne '' ) ) {
push @conditions, 'studio_id=?';
push @bind_values, $condition->{studio_id};
}
if ( ( defined $condition->{series_id} ) && ( $condition->{series_id} ne '' ) ) {
push @conditions, 'series_id=?';
push @bind_values, $condition->{series_id};
}
if ( ( defined $condition->{series_id} ) && ( $condition->{series_id} ne '' ) ) {
push @conditions, 'series_id=?';
push @bind_values, $condition->{series_id};
}
if ( ( defined $condition->{schedule_id} ) && ( $condition->{schedule_id} ne '' ) ) {
push @conditions, 'id=?';
push @bind_values, $condition->{schedule_id};
}
if ( ( defined $condition->{schedule_id} ) && ( $condition->{schedule_id} ne '' ) ) {
push @conditions, 'id=?';
push @bind_values, $condition->{schedule_id};
}
if ( ( defined $condition->{schedule_ids} ) && ( ref( $condition->{schedule_ids} ) eq 'ARRAY' ) ) {
my @scheduleIds = @{ $condition->{schedule_ids} };
push @conditions, 'id in (' . ( join( ',', ( map { '?' } @scheduleIds ) ) ) . ')';
for my $id (@scheduleIds) {
push @bind_values, $id;
}
}
if ( ( defined $condition->{schedule_ids} ) && ( ref( $condition->{schedule_ids} ) eq 'ARRAY' ) ) {
my @scheduleIds = @{ $condition->{schedule_ids} };
push @conditions, 'id in (' . ( join( ',', ( map { '?' } @scheduleIds ) ) ) . ')';
for my $id (@scheduleIds) {
push @bind_values, $id;
}
}
if ( ( defined $condition->{start} ) && ( $condition->{start} ne '' ) ) {
push @conditions, 'start=?';
push @bind_values, $condition->{start};
}
if ( ( defined $condition->{start} ) && ( $condition->{start} ne '' ) ) {
push @conditions, 'start=?';
push @bind_values, $condition->{start};
}
if ( ( defined $condition->{exclude} ) && ( $condition->{exclude} ne '' ) ) {
push @conditions, 'exclude=?';
push @bind_values, $condition->{exclude};
}
if ( ( defined $condition->{exclude} ) && ( $condition->{exclude} ne '' ) ) {
push @conditions, 'exclude=?';
push @bind_values, $condition->{exclude};
}
if ( ( defined $condition->{period_type} ) && ( $condition->{period_type} ne '' ) ) {
push @conditions, 'period_type=?';
push @bind_values, $condition->{period_type};
}
if ( ( defined $condition->{period_type} ) && ( $condition->{period_type} ne '' ) ) {
push @conditions, 'period_type=?';
push @bind_values, $condition->{period_type};
}
my $conditions = '';
$conditions = " where " . join( " and ", @conditions ) if ( @conditions > 0 );
my $conditions = '';
$conditions = " where " . join( " and ", @conditions ) if ( @conditions > 0 );
my $query = qq{
my $query = qq{
select *
from calcms_series_schedule
$conditions
order by exclude, start
};
#print STDERR $query."\n".Dumper(\@bind_values);
#print STDERR $query."\n".Dumper(\@bind_values);
my $entries = db::get( $dbh, $query, \@bind_values );
for my $entry (@$entries) {
$entry->{schedule_id} = $entry->{id};
delete $entry->{id};
}
my $entries = db::get( $dbh, $query, \@bind_values );
for my $entry (@$entries) {
$entry->{schedule_id} = $entry->{id};
delete $entry->{id};
}
#print STDERR Dumper($entries);
return $entries;
#print STDERR Dumper($entries);
return $entries;
}
sub insert {
my $config = shift;
my $entry = shift;
sub insert($$) {
my $config = shift;
my $entry = shift;
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{series_id};
return undef unless defined $entry->{start};
my $dbh = db::connect($config);
return db::insert( $dbh, 'calcms_series_schedule', $entry );
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{series_id};
return undef unless defined $entry->{start};
my $dbh = db::connect($config);
return db::insert( $dbh, 'calcms_series_schedule', $entry );
}
#schedule id to id
sub update {
my $config = shift;
my $entry = shift;
sub update($$) {
my $config = shift;
my $entry = shift;
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{series_id};
return undef unless defined $entry->{schedule_id};
return undef unless defined $entry->{start};
$entry->{nextDay} = 0 unless defined $entry->{nextDay};
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{series_id};
return undef unless defined $entry->{schedule_id};
return undef unless defined $entry->{start};
$entry->{nextDay} = 0 unless defined $entry->{nextDay};
$entry->{id} = $entry->{schedule_id};
delete $entry->{schedule_id};
$entry->{id} = $entry->{schedule_id};
delete $entry->{schedule_id};
my $dbh = db::connect($config);
my $values = join( ",", map { $_ . '=?' } ( keys %$entry ) );
my @bind_values = map { $entry->{$_} } ( keys %$entry );
my $dbh = db::connect($config);
my $values = join( ",", map { $_ . '=?' } ( keys %$entry ) );
my @bind_values = map { $entry->{$_} } ( keys %$entry );
push @bind_values, $entry->{project_id};
push @bind_values, $entry->{studio_id};
push @bind_values, $entry->{id};
push @bind_values, $entry->{project_id};
push @bind_values, $entry->{studio_id};
push @bind_values, $entry->{id};
my $query = qq{
my $query = qq{
update calcms_series_schedule
set $values
where project_id=? and studio_id=? and id=?
};
#print STDERR Dumper($query).Dumper(\@bind_values);
db::put( $dbh, $query, \@bind_values );
print "done\n";
#print STDERR Dumper($query).Dumper(\@bind_values);
db::put( $dbh, $query, \@bind_values );
print "done\n";
}
#map schedule id to id
sub delete {
my $config = shift;
my $entry = shift;
sub delete($$) {
my $config = shift;
my $entry = shift;
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{series_id};
return undef unless defined $entry->{schedule_id};
return undef unless defined $entry->{project_id};
return undef unless defined $entry->{studio_id};
return undef unless defined $entry->{series_id};
return undef unless defined $entry->{schedule_id};
my $dbh = db::connect($config);
my $dbh = db::connect($config);
my $query = qq{
my $query = qq{
delete
from calcms_series_schedule
where project_id=? and studio_id=? and series_id=? and id=?
};
my $bind_values = [ $entry->{project_id}, $entry->{studio_id}, $entry->{series_id}, $entry->{schedule_id} ];
my $bind_values = [ $entry->{project_id}, $entry->{studio_id}, $entry->{series_id}, $entry->{schedule_id} ];
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
db::put( $dbh, $query, $bind_values );
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
db::put( $dbh, $query, $bind_values );
}
sub error {
my $msg = shift;
print "ERROR: $msg<br/>\n";
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}
#do not delete last line!

3
lib/calcms/startup.pl
View File

@@ -2,8 +2,6 @@ use lib qw(/home/radio/calcms/calcms/);
use Data::Dumper;
use Apache::DBI();
#$Apache::DBI::DEBUG = 2;
use Time::Local();
use Date::Calc();
use Calendar::Simple qw(date_span);
@@ -12,7 +10,6 @@ use config();
use log();
use time();
use db();
use cache();
use template();
#do not delete last line!

7
lib/calcms/studio_timeslot_dates.pm
View File

@@ -1,7 +1,8 @@
package studio_timeslot_dates;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Date::Calc();
@@ -16,7 +17,7 @@ our @EXPORT_OK = qw(get_columns get insert update delete get_dates);
sub debug;
sub get_columns {
sub get_columns ($){
my $config = shift;
my $dbh = db::connect($config);
@@ -30,7 +31,7 @@ sub get_columns {
# get all studio_timeslot_dates for studio_id within given time range
# calculate start_date, end_date, weeday, day from start and end(datetime)
sub get {
sub get ($$){
my $config = shift;
my $condition = shift;

15
lib/calcms/studio_timeslot_schedule.pm
View File

@@ -1,7 +1,8 @@
package studio_timeslot_schedule;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use studio_timeslot_dates();
@@ -14,7 +15,7 @@ our @EXPORT_OK = qw(get_columns get insert update delete);
sub debug;
sub get_columns {
sub get_columns($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -27,7 +28,7 @@ sub get_columns {
}
#map schedule id to id
sub get {
sub get($$) {
my $config = shift;
my $condition = shift;
@@ -70,7 +71,7 @@ sub get {
return $entries;
}
sub insert {
sub insert($$) {
my $config = shift;
my $entry = shift;
@@ -85,7 +86,7 @@ sub insert {
}
#schedule id to id
sub update {
sub update($$) {
my $config = shift;
my $entry = shift;
@@ -119,7 +120,7 @@ sub update {
}
#map schedule id to id
sub delete {
sub delete ($$){
my $config = shift;
my $entry = shift;
@@ -138,7 +139,7 @@ sub delete {
db::put( $dbh, $query, $bind_values );
}
sub error {
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

22
lib/calcms/studios.pm
View File

@@ -1,7 +1,8 @@
package studios;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use images();
@@ -11,7 +12,7 @@ our @EXPORT_OK = qw(get_columns get get_by_id insert update delete check check_s
sub debug;
sub get_columns {
sub get_columns($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -22,8 +23,7 @@ sub get_columns {
}
return $columns;
}
sub get {
sub get($;$) {
my $config = shift;
my $condition = shift || {};
@@ -61,7 +61,7 @@ sub get {
$limit
};
} else {
push @conditions, 's.id=ps.studio_id';
push @conditions, 's.id=ps.studio_id';
push @conditions, 'ps.project_id=?';
push @bind_values, $condition->{project_id};
@@ -80,7 +80,7 @@ sub get {
return $studios;
}
sub getImageById {
sub getImageById($$) {
my $config = shift;
my $conditions = shift;
@@ -91,7 +91,7 @@ sub getImageById {
return $studios->[0]->{image};
}
sub insert {
sub insert ($$) {
my $config = shift;
my $entry = shift;
@@ -104,7 +104,7 @@ sub insert {
return $id;
}
sub update {
sub update ($$) {
my $config = shift;
my $studio = shift;
@@ -133,7 +133,7 @@ sub update {
db::put( $dbh, $query, \@bind_values );
}
sub delete {
sub delete ($$) {
my $config = shift;
my $studio = shift;
@@ -142,13 +142,13 @@ sub delete {
}
#TODO rename to check
sub check_studio {
sub check_studio($$) {
my $config = shift;
my $options = shift;
return check( $config, $options );
}
sub check {
sub check ($$) {
my $config = shift;
my $options = shift;
return "missing studio_id" unless defined $options->{studio_id};

5
lib/calcms/tags.pm
View File

@@ -1,13 +1,14 @@
package tags;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use base 'Exporter';
our @EXPORT_OK = qw(get_tags);
sub get_tags {
sub get_tags($) {
my $dbh = shift;
my $query = qq{
select name, count(name) sum from calcms_tags

86
lib/calcms/template.pm
View File

@@ -1,11 +1,13 @@
package template;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use HTML::Template::Compiled();
use HTML::Template::Compiled::Plugin::XMLEscape();
#use HTML::Template::JIT();
use JSON();
use Cwd();
@@ -20,7 +22,7 @@ use base 'Exporter';
our @EXPORT_OK = qw(check process exit_on_missing_permission clear_cache);
# TODO:config
sub process {
sub process($$$$) {
my $config = $_[0];
# my $output=$_[1];
@@ -47,7 +49,8 @@ sub process {
my $user_permissions = roles::get_user_permissions($config);
for my $permission ( keys %$user_permissions ) {
$params->{$permission} = $user_permissions->{$permission} if ( $user_permissions->{$permission} eq '1' );
$params->{$permission} = $user_permissions->{$permission}
if ( $user_permissions->{$permission} eq '1' );
}
$params->{jobs} = roles::get_user_jobs($config);
@@ -65,25 +68,28 @@ sub process {
return;
}
unless (-r $filename){
log::error($config, qq{template "$filename" does not exist}) unless -e $filename;
log::error($config, qq{missing permissions to read "$filename"});
unless ( -r $filename ) {
log::error( $config, qq{template "$filename" does not exist} ) unless -e $filename;
log::error( $config, qq{missing permissions to read "$filename"} );
}
my $html_template = initTemplate($filename);
setRelativeUrls( $params, 0 ) unless ( defined $params->{extern} ) && ( $params->{extern} eq '1' );
setRelativeUrls( $params, 0 )
unless ( defined $params->{extern} ) && ( $params->{extern} eq '1' );
$html_template->param($params);
my $output = $html_template->output();
if ($filename=~/html/){
my ($header, $content) = split(/\n\n/, $output, 2);
if ($content){
#$content =~s/\s+/ /g;
$output = $header."\n\n".$content;
}else{
#$output =~s/[ \t]+/ /g;
}
}
if ( $filename =~ /html/ ) {
my ( $header, $content ) = split( /\n\n/, $output, 2 );
if ($content) {
#$content =~s/\s+/ /g;
$output = $header . "\n\n" . $content;
} else {
#$output =~s/[ \t]+/ /g;
}
}
if ( ( defined $_[1] ) && ( $_[1] eq 'print' ) ) {
print $output;
@@ -92,8 +98,8 @@ sub process {
}
}
sub initTemplate{
my $filename=shift;
sub initTemplate($) {
my $filename = shift;
my $default_escape = 'none';
$default_escape = 'js' if ( $filename =~ /\.js$/ );
@@ -113,7 +119,7 @@ sub initTemplate{
utf8 => 1,
plugin => [qw(HTML::Template::Compiled::Plugin::XMLEscape)],
);
}
}
return HTML::Template::Compiled->new(
filename => $filename,
@@ -125,12 +131,15 @@ sub initTemplate{
default_escape => $default_escape,
cache => 1,
utf8 => 1,
#pre_chomp => 1,
#post_chomp => 1,
#pre_chomp => 1,
#post_chomp => 1,
);
}
# set relative urls in nested params structure
sub setRelativeUrls;
sub setRelativeUrls {
my $params = shift;
my $depth = shift || 0;
@@ -179,7 +188,7 @@ sub setRelativeUrls {
#requires read config
#TODO:add config
sub check {
sub check($;$$) {
my $config = shift;
my $template = shift || '';
my $default = shift;
@@ -207,7 +216,9 @@ sub check {
my $cwd = Cwd::getcwd();
$template .= '.html' unless ( $template =~ /\./ );
if ( ( $config->{cache}->{compress} eq '1' ) && ( -e $cwd . '/templates/compressed/' . $template ) ) {
if ( ( $config->{cache}->{compress} eq '1' )
&& ( -e $cwd . '/templates/compressed/' . $template ) )
{
$template = $cwd . '/templates/compressed/' . $template;
} elsif ( -e $cwd . '/templates/' . $template ) {
$template = $cwd . '/templates/' . $template;
@@ -216,29 +227,36 @@ sub check {
}
log::error( $config, "missing permission to read template '$template'" ) unless ( -r $template );
log::error( $config, "missing permission to read template '$template'" )
unless ( -r $template );
return $template;
}
#deprecated (for old admin only)
sub exit_on_missing_permission {
my $config = shift;
my $permission = shift;
sub exit_on_missing_permission($$) {
my $config = shift;
my $permission = shift;
my $user_permissions = roles::get_user_permissions($config);
if ( $user_permissions->{$permission} ne '1' ) {
print STDERR "missing permission to $permission\n";
template::process( $config, 'print', template::check( $config, 'default.html' ), { error => 'sorry, missing permission!' } );
template::process(
$config, 'print',
template::check( $config, 'default.html' ),
{ error => 'sorry, missing permission!' }
);
die();
}
}
#do not delete last line!
1;
__END__
sub clear_cache {
HTML::Template::Compiled->clear_cache();
# return;
# my $html_template = HTML::Template::Compiled->new();
# $html_template->clear_cache();
# return;
# my $html_template = HTML::Template::Compiled->new();
# $html_template->clear_cache();
}
#do not delete last line!
1;

92
lib/calcms/time.pm
View File

@@ -1,7 +1,8 @@
package time;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use utf8;
use Time::Local();
@@ -73,32 +74,32 @@ my $DURATIONS = [
120, 135, 150, 165, 180, 195, 210, 225, 240, 300, 360, 420, 480, 540, 600, 660, 720, 1440
];
sub getDurations {
sub getDurations() {
return $DURATIONS;
}
sub getWeekdayNames {
sub getWeekdayNames(;$) {
my $language = shift || 'en';
return $NAMES->{$language}->{weekdays};
}
sub getWeekdayNamesShort {
sub getWeekdayNamesShort(;$) {
my $language = shift || 'en';
return $NAMES->{$language}->{weekdays_abbr};
}
sub getMonthNames {
sub getMonthNames(;$) {
my $language = shift || 'en';
return $NAMES->{$language}->{months};
}
sub getMonthNamesShort {
sub getMonthNamesShort(;$) {
my $language = shift || 'en';
return $NAMES->{$language}->{months_abbr};
}
sub getWeekdayIndex($) {
sub getWeekdayIndex(;$) {
my $weekday = shift || '';
return $WEEKDAY_INDEX->{$weekday};
}
@@ -128,14 +129,14 @@ sub getWeekdays {
}
#deprecated, for wordpress sync
sub format_datetime {
sub format_datetime(;$) {
my $datetime = shift;
return $datetime if ( $datetime eq '' );
return add_hours_to_datetime( $datetime, 0 );
}
#deprecated
sub format_time {
sub format_time($) {
my $t = $_[0];
my $year = $t->[5] + 1900;
@@ -155,7 +156,7 @@ sub format_time {
}
# convert datetime to unix time
sub datetime_to_time {
sub datetime_to_time ($){
my $datetime = $_[0];
# print $datetime."\n";
@@ -167,7 +168,6 @@ sub datetime_to_time {
my $minute = $5;
my $second = $8 || 0;
return Time::Local::timelocal( $second, $minute, $hour, $day, $month, $year ) || print STDERR "datetime_to_time: no valid date time found! ($datetime)\n";
;
} else {
print STDERR "datetime_to_time: no valid date time found! ($datetime)\n";
@@ -176,14 +176,14 @@ sub datetime_to_time {
}
#get rfc822 datetime string from datetime string
sub datetime_to_rfc822 {
sub datetime_to_rfc822($) {
my $datetime = $_[0];
my $time = datetime_to_time($datetime);
return POSIX::strftime( "%a, %d %b %Y %H:%M:%S %z", localtime($time) );
}
#get seconds from epoch
sub datetime_to_utc {
sub datetime_to_utc($$) {
my $datetime = shift;
my $time_zone = shift;
$datetime = get_datetime( $datetime, $time_zone );
@@ -191,7 +191,7 @@ sub datetime_to_utc {
}
# get full utc datetime including timezone offset
sub datetime_to_utc_datetime {
sub datetime_to_utc_datetime($$) {
my $datetime = shift;
my $time_zone = shift;
$datetime = get_datetime( $datetime, $time_zone );
@@ -199,7 +199,7 @@ sub datetime_to_utc_datetime {
}
#add hours to datetime string
sub add_hours_to_datetime {
sub add_hours_to_datetime($;$) {
my $datetime = shift;
my $hours = shift;
$hours = 0 unless defined $hours;
@@ -207,7 +207,7 @@ sub add_hours_to_datetime {
}
#add minutes to datetime string
sub add_minutes_to_datetime {
sub add_minutes_to_datetime($;$) {
my $datetime = shift;
my $minutes = shift;
$minutes = 0 unless defined $minutes;
@@ -215,7 +215,7 @@ sub add_minutes_to_datetime {
}
#add days to datetime string
sub add_days_to_datetime {
sub add_days_to_datetime($;$) {
my $datetime = shift;
my $days = shift;
$days = 0 unless defined $days;
@@ -226,7 +226,7 @@ sub add_days_to_datetime {
return array_to_datetime($time);
}
sub add_days_to_date {
sub add_days_to_date($;$) {
my $datetime = shift;
my $days = shift;
$days = 0 unless defined $days;
@@ -236,7 +236,7 @@ sub add_days_to_date {
}
# convert unix time to datetime format
sub time_to_datetime {
sub time_to_datetime(;$) {
my $time = shift;
$time = time() unless ( defined $time ) && ( $time ne '' );
my @t = localtime($time);
@@ -244,7 +244,7 @@ sub time_to_datetime {
}
# convert unix time to date format
sub time_to_date {
sub time_to_date(;$) {
my $time = shift;
$time = time() unless ( defined $time ) && ( $time ne '' );
my @t = localtime($time);
@@ -252,7 +252,7 @@ sub time_to_date {
}
# convert datetime to a array of date/time values
sub datetime_to_array {
sub datetime_to_array(;$) {
my $datetime = $_[0] || '';
if ( $datetime =~ /(\d\d\d\d)\-(\d+)\-(\d+)([T\s]+(\d+)\:(\d+)(\:(\d+))?)?/ ) {
my $year = $1;
@@ -267,7 +267,7 @@ sub datetime_to_array {
}
# convert datetime to date
sub datetime_to_date {
sub datetime_to_date(;$) {
my $datetime = $_[0] || '';
if ( $datetime =~ /(\d\d\d\d)\-(\d+)\-(\d+)/ ) {
my $year = $1;
@@ -279,7 +279,7 @@ sub datetime_to_date {
}
#convert datetime array or single value to datetime string
sub array_to_datetime {
sub array_to_datetime(;$) {
my $date = shift;
if ( ref($date) eq 'ARRAY' ) {
return sprintf( "%04d-%02d-%02d %02d:%02d:%02d", $date->[0], $date->[1], $date->[2], $date->[3], $date->[4], $date->[5] );
@@ -293,7 +293,7 @@ sub array_to_datetime {
}
#convert date array or single values to date string
sub array_to_date {
sub array_to_date($;$$) {
my $date = shift;
if ( ref($date) eq 'ARRAY' ) {
return sprintf( "%04d-%02d-%02d", $date->[0], $date->[1], $date->[2] );
@@ -303,7 +303,7 @@ sub array_to_date {
return sprintf( "%04d-%02d-%02d", $date, $month, $day );
}
sub array_to_time {
sub array_to_time(;$) {
my $date = shift;
if ( ref($date) eq 'ARRAY' ) {
return sprintf( "%02d:%02d:%02d", $date->[3], $date->[4], $date->[5] );
@@ -313,7 +313,7 @@ sub array_to_time {
return sprintf( "%02d:%02d:%02d", $date, $minute, $second );
}
sub array_to_time_hm {
sub array_to_time_hm(;$) {
my $date = shift;
if ( ref($date) eq 'ARRAY' ) {
return sprintf( "%02d:%02d", $date->[3], $date->[4] );
@@ -323,14 +323,14 @@ sub array_to_time_hm {
}
# get number of days between two days
sub days_between {
sub days_between($$) {
my $today = $_[0];
my $date = $_[1];
my $delta_days = eval { Date::Calc::Delta_Days( $today->[0], $today->[1], $today->[2], $date->[0], $date->[1], $date->[2] ) };
return $delta_days;
}
sub dayOfYear {
sub dayOfYear($) {
my $datetime = $_[0];
if ( $datetime =~ /(\d\d\d\d)\-(\d+)\-(\d+)/ ) {
my $year = $1;
@@ -342,7 +342,7 @@ sub dayOfYear {
}
# get duration in minutes
sub get_duration {
sub get_duration($$$) {
my $start = shift;
my $end = shift;
my $timezone = shift;
@@ -353,7 +353,7 @@ sub get_duration {
}
# get duration in seconds
sub get_duration_seconds {
sub get_duration_seconds($$;$) {
my $start = shift;
my $end = shift;
my $timezone = shift || 'UTC';
@@ -382,7 +382,7 @@ sub get_duration_seconds {
}
# convert date string to a array of date values
sub date_to_array {
sub date_to_array($) {
my $datetime = $_[0];
if ( $datetime =~ /(\d\d\d\d)\-(\d+)\-(\d+)/ ) {
my $year = $1;
@@ -395,7 +395,7 @@ sub date_to_array {
# parse date string and return date string
# pass 'today', return '' on parse error
sub date_cond {
sub date_cond($) {
my $date = shift;
return '' if ( $date eq '' );
@@ -411,7 +411,7 @@ sub date_cond {
#parse time and return time string hh:mm:ss
#return hh:00 if time is 'now'
sub time_cond {
sub time_cond($) {
my $time = shift;
return '' if ( $time eq '' );
@@ -432,7 +432,7 @@ sub time_cond {
}
#parse date and time string and return yyyy-mm-ddThh:mm:ss
sub datetime_cond {
sub datetime_cond($) {
my $datetime = shift;
return '' if ( $datetime eq '' );
@@ -445,7 +445,7 @@ sub datetime_cond {
return $date . 'T' . $time;
}
sub check_date {
sub check_date($) {
my $date = shift;
return "" if ( !defined $date ) || ( $date eq '' );
@@ -460,7 +460,7 @@ sub check_date {
#error("no valid date format given!");
}
sub check_time {
sub check_time($) {
my $time = shift;
return "" if ( !defined $time ) || ( $time eq '' );
return $time if ( $time eq 'now' ) || ( $time eq 'future' );
@@ -470,7 +470,7 @@ sub check_time {
return -1;
}
sub check_datetime {
sub check_datetime($) {
my $date = shift;
return "" if ( !defined $date ) || ( $date eq '' );
@@ -480,7 +480,7 @@ sub check_datetime {
return -1;
}
sub check_year_month {
sub check_year_month($) {
my $date = shift;
return -1 unless ( defined $date );
return $date if ( $date eq '' );
@@ -491,7 +491,7 @@ sub check_year_month {
}
#TODO: remove config dependency
sub date_time_format {
sub date_time_format($$;$) {
my $config = shift;
my $datetime = shift;
my $language = shift || $config->{date}->{language} || 'en';
@@ -509,7 +509,7 @@ sub date_time_format {
#format datetime to date string
#TODO: remove config dependency
sub date_format {
sub date_format($$;$) {
my $config = shift;
my $datetime = shift;
my $language = shift || $config->{date}->{language} || 'en';
@@ -525,7 +525,7 @@ sub date_format {
}
#format datetime to time string
sub time_format {
sub time_format($) {
my $datetime = shift;
if ( defined $datetime && $datetime =~ /(\d\d?\:\d\d?)/ ) {
return $1;
@@ -534,7 +534,7 @@ sub time_format {
}
#get offset from given time_zone
sub utc_offset {
sub utc_offset($) {
my $time_zone = shift;
my $datetime = DateTime->now();
@@ -543,7 +543,7 @@ sub utc_offset {
}
#get weekday from (yyyy,mm,dd)
sub weekday {
sub weekday($$$) {
my ( $year, $month, $day ) = @_;
my $time = Time::Local::timelocal( 0, 0, 0, $day, $month - 1, $year );
return ( localtime($time) )[6];
@@ -551,7 +551,7 @@ sub weekday {
#get current date, related to starting day_starting_hour
#TODO: remove config dependency
sub get_event_date {
sub get_event_date($) {
my $config = shift;
my $datetime = time::time_to_datetime( time() );
@@ -571,7 +571,7 @@ sub get_event_date {
}
#get datetime object from datetime string
sub get_datetime {
sub get_datetime(;$$) {
my $datetime = shift;
my $timezone = shift;
@@ -599,7 +599,7 @@ sub get_datetime {
}
#get list of nth weekday in month from start to end
sub get_nth_weekday_in_month {
sub get_nth_weekday_in_month(;$$$$) {
my $start = shift; # datetime string
my $end = shift; # datetime string
my $nth = shift; # every nth week of month

108
lib/calcms/uac.pm
View File

@@ -1,6 +1,8 @@
package uac;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use CGI::Session qw(-ip-match);
use CGI::Cookie();
@@ -28,7 +30,7 @@ our @EXPORT_OK = qw(
sub debug;
# get user by name
sub get_user {
sub get_user($$) {
my $config = shift;
my $user = shift;
@@ -49,7 +51,7 @@ sub get_user {
}
# get all users
sub get_users {
sub get_users($;$) {
my $config = shift;
my $condition = shift;
@@ -82,7 +84,7 @@ sub get_users {
# get all users of a given studio id
# used at series (previously named get_studio_users)
sub get_users_by_studio {
sub get_users_by_studio ($$) {
my $config = shift;
my $condition = shift;
@@ -117,7 +119,7 @@ sub get_users_by_studio {
}
# get projects a user is assigned by name
sub get_projects_by_user {
sub get_projects_by_user ($$) {
my $config = shift;
my $condition = shift;
@@ -156,7 +158,7 @@ sub get_projects_by_user {
# get all studios a user is assigned to by role
# used at series (previously named get_user_studios)
sub get_studios_by_user {
sub get_studios_by_user ($$) {
my $config = shift;
my $condition = shift;
@@ -192,7 +194,7 @@ sub get_studios_by_user {
return $users;
}
sub insert_user {
sub insert_user($$) {
my $config = shift;
my $entry = shift;
@@ -203,7 +205,7 @@ sub insert_user {
db::insert( $dbh, 'calcms_users', $entry );
}
sub update_user {
sub update_user($$) {
my $config = shift;
my $entry = shift;
@@ -223,7 +225,7 @@ sub update_user {
db::put( $dbh, $query, \@bind_values );
}
sub delete_user {
sub delete_user($$) {
my $config = shift;
my $id = shift;
return unless ( defined $id && ( $id =~ /^\d+$/ ) );
@@ -238,7 +240,7 @@ sub delete_user {
# get all roles used by all users of a studio
# available conditions: project_id, studio_id
sub get_studio_roles {
sub get_studio_roles($$) {
my $config = shift;
my $condition = shift;
@@ -273,7 +275,7 @@ sub get_studio_roles {
}
# get role columns (for external use only)
sub get_role_columns {
sub get_role_columns($) {
my $config = shift;
my $dbh = db::connect($config);
my $columns = db::get_columns_hash( $dbh, 'calcms_roles' );
@@ -282,7 +284,7 @@ sub get_role_columns {
# get roles
# filter: studio_id project_id
sub get_roles {
sub get_roles($$) {
my $config = shift;
my $condition = shift;
@@ -313,7 +315,7 @@ sub get_roles {
}
#insert role to database, set created_at and modified_at
sub insert_role {
sub insert_role ($$) {
my $config = shift;
my $entry = shift;
@@ -330,7 +332,7 @@ sub insert_role {
}
#update role, set modified_at
sub update_role {
sub update_role($$) {
my $config = shift;
my $entry = shift;
@@ -354,7 +356,7 @@ sub update_role {
}
# delete role from database
sub delete_role {
sub delete_role($$) {
my $config = shift;
my $id = shift;
@@ -370,7 +372,7 @@ sub delete_role {
# get all roles for given conditions: project_id, studio_id, user_id, name
# includes global admin user role
sub get_user_roles {
sub get_user_roles($$) {
my $config = shift;
my $condition = shift;
@@ -425,7 +427,7 @@ sub get_user_roles {
}
#return admin user roles for given conditions: project_id, studio_id, user, user_id
sub get_admin_user_roles {
sub get_admin_user_roles ($$) {
my $config = shift;
my $condition = shift;
@@ -468,7 +470,7 @@ sub get_admin_user_roles {
# read permissions for given conditions and add to user_permissions
# return user_permissions
# studio_id, user_id, name
sub get_user_permissions {
sub get_user_permissions ($$;$) {
my $config = shift;
my $conditions = shift;
my $user_permissions = shift;
@@ -478,8 +480,8 @@ sub get_user_permissions {
my @user_roles = ( @$admin_roles, @$user_roles );
#set default permissions
$user_permissions = {} unless ( defined $user_permissions );
$user_permissions->{is_admin} = 1 if ( scalar @$admin_roles > 0 );
$user_permissions = {} unless defined $user_permissions;
$user_permissions->{is_admin} = 1 if scalar @$admin_roles > 0;
my $max_level = 0;
@@ -501,7 +503,8 @@ sub get_user_permissions {
&& ( $permission ne 'studio_id' )
&& ( $permission ne 'project_id' ) )
{
$user_permissions->{$permission} = 1 if ( defined $user_role->{$permission} ) && ( $user_role->{$permission} ne '0' );
$user_permissions->{$permission} = 1
if ( defined $user_role->{$permission} ) && ( $user_role->{$permission} ne '0' );
}
}
}
@@ -509,7 +512,7 @@ sub get_user_permissions {
}
#get user id by user name
sub get_user_id {
sub get_user_id ($$) {
my $config = shift;
my $user = shift;
@@ -527,7 +530,7 @@ sub get_user_id {
}
#get role id by role name
sub get_role_id {
sub get_role_id ($$) {
my $config = shift;
my $role = shift;
@@ -545,7 +548,7 @@ sub get_role_id {
}
# assign a role to an user (for a studio)
sub assign_user_role {
sub assign_user_role($$) {
my $config = shift;
my $options = shift;
@@ -561,8 +564,9 @@ sub assign_user_role {
from calcms_user_roles
where project_id=? and studio_id=? and user_id=? and role_id=?
};
my $dbh = db::connect($config);
my $user_roles = db::get( $dbh, $query, [ $options->{project_id}, $options->{studio_id}, $options->{user_id}, $options->{role_id} ] );
my $dbh = db::connect($config);
my $user_roles = db::get( $dbh, $query,
[ $options->{project_id}, $options->{studio_id}, $options->{user_id}, $options->{role_id} ] );
return undef if scalar @$user_roles > 0;
#insert entry
@@ -578,7 +582,7 @@ sub assign_user_role {
}
# unassign a user from a role of (for a studio)
sub remove_user_role {
sub remove_user_role($$) {
my $config = shift;
my $options = shift;
@@ -603,7 +607,7 @@ sub remove_user_role {
}
#checks
sub is_user_assigned_to_studio {
sub is_user_assigned_to_studio ($$) {
my $request = shift;
my $options = shift;
@@ -626,26 +630,26 @@ sub is_user_assigned_to_studio {
# print errors at get_user_presets and check for project id and studio id
# call after header is printed
sub check {
sub check($$$) {
my $config = shift;
my $params = shift;
my $user_presets = shift;
if ( defined $user_presets->{error} ) {
uac::print_error( $user_presets->{error} );
return undef;
return 0;
}
my $project_check = project::check( $config, { project_id => $params->{project_id} } );
if ( $project_check ne '1' ) {
uac::print_error($project_check);
return undef;
return 0;
}
my $studio_check = studios::check( $config, { studio_id => $params->{studio_id} } );
if ( $studio_check ne '1' ) {
uac::print_error($studio_check);
return undef;
return 0;
}
return 1;
}
@@ -653,7 +657,7 @@ sub check {
# get user, projects and studios user is assigned to for selected values from params
# set permissions for selected project and studio
# return request
sub get_user_presets {
sub get_user_presets($$) {
my $config = shift;
my $options = shift;
@@ -666,8 +670,8 @@ sub get_user_presets {
$config->{access}->{write} = 0;
my $user_settings = user_settings::get( $config, { user => $user } );
$project_id = $user_settings->{project_id} if $project_id eq '';
$studio_id = $user_settings->{studio_id} if $studio_id eq '';
$project_id = $user_settings->{project_id} || '' if $project_id eq '';
$studio_id = $user_settings->{studio_id} || '' if $studio_id eq '';
#get
my $admin_roles = get_admin_user_roles( $config, { user => $user } );
@@ -732,7 +736,8 @@ sub get_user_presets {
}
}
my $permissions = uac::get_user_permissions( $config, { user => $user, project_id => $project_id, studio_id => $studio_id } );
my $permissions =
uac::get_user_permissions( $config, { user => $user, project_id => $project_id, studio_id => $studio_id } );
#only admin is allowed to select all projects
# if($permissions->{is_admin}==1){
@@ -780,7 +785,7 @@ sub get_user_presets {
return $result;
}
sub setDefaultProject {
sub setDefaultProject ($$) {
my $params = shift;
my $user_presets = shift;
@@ -789,7 +794,7 @@ sub setDefaultProject {
return $params;
}
sub setDefaultStudio {
sub setDefaultStudio($$) {
my $params = shift;
my $user_presets = shift;
@@ -799,7 +804,7 @@ sub setDefaultStudio {
}
#set user preset properties to request
sub prepare_request {
sub prepare_request ($$) {
my $request = shift;
my $user_presets = shift;
@@ -815,7 +820,7 @@ sub prepare_request {
}
#TODO: shift to permissions sub entry
sub set_template_permissions {
sub set_template_permissions ($$) {
my $permissions = shift;
my $params = shift;
@@ -826,25 +831,34 @@ sub set_template_permissions {
}
#print error message
sub permissions_denied {
sub permissions_denied($) {
my $message = shift;
$message =~ s/_/ /g;
print '<div class="error">Sorry! Missing permissions to ' . $message . '</div>' . "\n";
print STDERR 'Sorry! Missing permissions to ' . $message . "\n";
}
sub print_info {
print '<div class="ok head">' . '<span class="ui-icon ui-icon-check" style="float:left"></span>&nbsp;' . $_[0] . '</div>' . "\n";
sub print_info($) {
print '<div class="ok head">'
. '<span class="ui-icon ui-icon-check" style="float:left"></span>&nbsp;'
. $_[0]
. '</div>' . "\n";
}
sub print_warn {
print '<div class="warn head">' . '<span class="ui-icon ui-icon-info" style="float:left"></span>&nbsp;' . $_[0] . '</div>' . "\n";
sub print_warn($) {
print '<div class="warn head">'
. '<span class="ui-icon ui-icon-info" style="float:left"></span>&nbsp;'
. $_[0]
. '</div>' . "\n";
}
sub print_error {
sub print_error ($) {
my $message = shift;
print STDERR "ERROR:" . $message . "\n";
print '<div class="error" head>' . '<span class="ui-icon ui-icon-alert" style="float:left"></span>&nbsp;' . $message . '</div>' . "\n";
print '<div class="error" head>'
. '<span class="ui-icon ui-icon-alert" style="float:left"></span>&nbsp;'
. $message
. '</div>' . "\n";
}
#do not delete last line!

27
lib/calcms/user_settings.pm
View File

@@ -1,7 +1,8 @@
package user_settings;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use series_dates();
@@ -9,7 +10,7 @@ use series_dates();
# table: calcms_user_settings
# columns: user, colors
use base 'Exporter';
our @EXPORT_OK = qw(getColors getColorCss get insert update delete get_columns defaultColors);
our @EXPORT_OK = qw(getColors getColorCss get insert update delete get_columns defaultColors);
sub debug;
@@ -66,9 +67,10 @@ our $defaultColors = [
}
];
sub getColors {
sub getColors($$) {
my $config = shift;
my $conditions = shift;
return unless defined $conditions->{user};
my $user = $conditions->{user};
@@ -95,12 +97,12 @@ sub getColors {
$key =~ s/\s+$//;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
$colorMap->{$key}->{color} = $value if ( $key ne '' ) && ( $value ne '' ) && ( defined $colorMap->{$key} ) ;
$colorMap->{$key}->{color} = $value if ( $key ne '' ) && ( $value ne '' ) && ( defined $colorMap->{$key} );
}
return $colors;
}
sub getColorCss {
sub getColorCss ($$) {
my $config = shift;
my $conditions = shift;
return unless defined $conditions->{user};
@@ -131,7 +133,7 @@ sub getColorCss {
return $style;
}
sub get_columns {
sub get_columns($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -143,7 +145,7 @@ sub get_columns {
return $columns;
}
sub get {
sub get ($$) {
my $config = shift;
my $condition = shift;
@@ -170,7 +172,7 @@ sub get {
return $entries->[0] || undef;
}
sub insert {
sub insert ($$) {
my $config = shift;
my $entry = shift;
@@ -179,7 +181,7 @@ sub insert {
return db::insert( $dbh, 'calcms_user_settings', $entry );
}
sub update {
sub update($$) {
my $config = shift;
my $entry = shift;
@@ -195,12 +197,13 @@ sub update {
set $values
where user=?
};
#print STDERR Dumper($query).Dumper(\@bind_values);
#print STDERR Dumper($query).Dumper(\@bind_values);
db::put( $dbh, $query, \@bind_values );
print "done\n";
}
sub delete {
sub delete ($$) {
my $config = shift;
my $entry = shift;
@@ -218,7 +221,7 @@ sub delete {
db::put( $dbh, $query, $bind_values );
}
sub error {
sub error ($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

23
lib/calcms/user_stats.pm
View File

@@ -1,15 +1,16 @@
package user_stats;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use base 'Exporter';
our @EXPORT_OK = qw(get_columns get update insert get_stats increase);
our @EXPORT_OK = qw(get_columns get update insert get_stats increase);
sub debug;
sub get_columns {
sub get_columns($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -21,7 +22,7 @@ sub get_columns {
return $columns;
}
sub get {
sub get ($$) {
my $config = shift;
my $condition = shift;
@@ -72,7 +73,7 @@ sub get {
return $results;
}
sub get_stats {
sub get_stats($$) {
my $config = shift;
my $condition = shift;
@@ -129,7 +130,9 @@ sub get_stats {
my $results = db::get( $dbh, $query, \@bind_values );
for my $result (@$results) {
$result->{score} = 0;
for my $column ( 'create_events', 'update_events', 'delete_events', 'create_series', 'update_series', 'delete_series' ) {
for my $column ( 'create_events', 'update_events', 'delete_events', 'create_series', 'update_series',
'delete_series' )
{
$result->{score} += $result->{$column};
}
}
@@ -137,7 +140,7 @@ sub get_stats {
return \@results;
}
sub insert {
sub insert($$) {
my $config = shift;
my $stats = shift;
@@ -160,7 +163,7 @@ sub insert {
}
# update project
sub update {
sub update ($$) {
my $config = shift;
my $stats = shift;
@@ -194,7 +197,7 @@ sub update {
return db::put( $dbh, $query, \@bind_values );
}
sub increase {
sub increase ($$$) {
my $config = shift;
my $usecase = shift;
my $options = shift;
@@ -241,7 +244,7 @@ sub increase {
}
sub error {
sub error ($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

28
lib/calcms/work_dates.pm
View File

@@ -1,7 +1,8 @@
package work_dates;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Date::Calc();
@@ -16,11 +17,11 @@ use work_schedule();
# columns: id, studio_id, schedule_id, start(datetime), end(datetime)
# TODO: delete column schedule_id
use base 'Exporter';
our @EXPORT_OK = qw(get_columns get insert update delete get_dates);
our @EXPORT_OK = qw(get_columns get insert update delete get_dates);
sub debug;
sub get_columns {
sub get_columns($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -34,12 +35,13 @@ sub get_columns {
# get all work_dates for studio_id and schedule_id within given time range
# calculate start_date, end_date, weeday, day from start and end(datetime)
sub get {
sub get ($$) {
my $config = shift;
my $condition = shift;
my $date_range_include = 0;
$date_range_include = 1 if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
$date_range_include = 1
if ( defined $condition->{date_range_include} ) && ( $condition->{date_range_include} == 1 );
my $dbh = db::connect($config);
@@ -125,7 +127,7 @@ sub get {
}
#update work dates for all schedules of a work and studio_id
sub update {
sub update($$) {
my $config = shift;
my $entry = shift;
@@ -215,7 +217,7 @@ sub update {
return $j . " dates out of studio times, " . $i;
}
sub get_schedule_dates {
sub get_schedule_dates($$) {
my $schedule = shift;
my $options = shift;
@@ -239,7 +241,7 @@ sub get_schedule_dates {
return $dates;
}
sub get_week_of_month_dates {
sub get_week_of_month_dates($$$$$$) {
my $start = shift; # datetime string
my $end = shift; # datetime string
my $duration = shift; # in minutes
@@ -283,7 +285,7 @@ sub get_week_of_month_dates {
}
#add duration to a single date
sub get_single_date {
sub get_single_date($$) {
my $start_datetime = shift;
my $duration = shift;
@@ -303,12 +305,12 @@ sub get_single_date {
}
#calculate all dates between start_datetime and end_date with duration(minutes) and frequency(days)
sub get_dates {
sub get_dates($$$$) {
my $start_datetime = shift;
my $end_date = shift;
my $duration = shift; # in minutes
my $frequency = shift; # in days
#print "start_datetime:$start_datetime end_date:$end_date duration:$duration frequency:$frequency\n";
#print "start_datetime:$start_datetime end_date:$end_date duration:$duration frequency:$frequency\n";
my @start = @{ time::datetime_to_array($start_datetime) };
return unless @start >= 6;
@@ -364,7 +366,7 @@ sub get_dates {
}
#remove all work_dates for studio_id and schedule_id
sub delete {
sub delete($$) {
my $config = shift;
my $entry = shift;
@@ -385,7 +387,7 @@ sub delete {
return db::put( $dbh, $query, $bind_values );
}
sub error {
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}

17
lib/calcms/work_schedule.pm
View File

@@ -1,7 +1,8 @@
package work_schedule;
use warnings "all";
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use series_dates();
@@ -17,11 +18,11 @@ use series_dates();
# month
use base 'Exporter';
our @EXPORT_OK = qw(get_columns get insert update delete);
our @EXPORT_OK = qw(get_columns get insert update delete);
sub debug;
sub get_columns {
sub get_columns($) {
my $config = shift;
my $dbh = db::connect($config);
@@ -34,7 +35,7 @@ sub get_columns {
}
#map schedule id to id
sub get {
sub get($$) {
my $config = shift;
my $condition = shift;
@@ -89,7 +90,7 @@ sub get {
return $entries;
}
sub insert {
sub insert ($$) {
my $config = shift;
my $entry = shift;
@@ -101,7 +102,7 @@ sub insert {
}
#schedule id to id
sub update {
sub update ($$) {
my $config = shift;
my $entry = shift;
@@ -128,7 +129,7 @@ sub update {
}
#map schedule id to id
sub delete {
sub delete($$) {
my $config = shift;
my $entry = shift;
@@ -149,7 +150,7 @@ sub delete {
return db::put( $dbh, $query, $bind_values );
}
sub error {
sub error($) {
my $msg = shift;
print "ERROR: $msg<br/>\n";
}