copy current state of medienstaatsvertrag.org, to be verified
This commit is contained in:
Milan
45
lib/calcms/UTF8DBI.pm
Normal file
45
lib/calcms/UTF8DBI.pm
Normal file
@@ -0,0 +1,45 @@
|
||||
# UTF8DBI.pm re-implementation by Pavel Kudinov http://search.cpan.org/~kudinov/
|
||||
# originally from: http://dysphoria.net/code/perl-utf8/
|
||||
# And patched again by Andrew Forrest, Jan 2007
|
||||
|
||||
use DBI 1.21;
|
||||
use utf8;
|
||||
use Encode;
|
||||
|
||||
package UTF8DBI; use base DBI;
|
||||
sub _utf8_ {
|
||||
if (ref $_ eq 'ARRAY') { _utf8_() foreach @$_ }
|
||||
elsif (ref $_ eq 'HASH' ) { _utf8_() foreach values %$_ }
|
||||
else {
|
||||
Encode::_utf8_on($_);
|
||||
if (Encode::is_utf8($_) && ! Encode::is_utf8($_, 1)) {
|
||||
#$_ = '⁂malformed-UTF8‼' #die "Malformed utf8 string in database"
|
||||
#print data_string_desc($_)."\n"
|
||||
#data_string_desc(STRING);
|
||||
#Encode::decode_utf8($_);
|
||||
#;
|
||||
#Encode::_utf8_off($_);
|
||||
#Encode::decode_utf8($_);
|
||||
#Encode::encode_utf8($_);
|
||||
}
|
||||
};
|
||||
$_;
|
||||
};
|
||||
|
||||
|
||||
package UTF8DBI::db; use base DBI::db;
|
||||
|
||||
sub selectrow_arrayref { return UTF8DBI::_utf8_ for shift->SUPER::selectrow_arrayref(@_) };
|
||||
sub selectrow_hashref { return UTF8DBI::_utf8_ for shift->SUPER::selectrow_hashref (@_) };
|
||||
sub selectall_arrayref { return UTF8DBI::_utf8_ for shift->SUPER::selectall_arrayref(@_) };
|
||||
sub selectall_hashref { return UTF8DBI::_utf8_ for shift->SUPER::selectall_hashref (@_) };
|
||||
sub selectcol_arrayref { return UTF8DBI::_utf8_ for shift->SUPER::selectcol_arrayref(@_) };
|
||||
|
||||
sub selectrow_array { @{shift->selectrow_arrayref(@_)} };
|
||||
|
||||
|
||||
package UTF8DBI::st; use base DBI::st;
|
||||
|
||||
sub fetch { return UTF8DBI::_utf8_ for shift->SUPER::fetch (@_) };
|
||||
|
||||
1;
|
||||
294
lib/calcms/aggregator.pm
Normal file
294
lib/calcms/aggregator.pm
Normal file
@@ -0,0 +1,294 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use events;
|
||||
use comments;
|
||||
use calendar;
|
||||
use project;
|
||||
|
||||
package aggregator;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_cache configure_cache put_cache get_list check_params);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
#my $cgi=undef;
|
||||
|
||||
sub get_list{
|
||||
my $config = shift;
|
||||
my $request=shift;
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
my $debug=$config->{system}->{debug};
|
||||
|
||||
#customize prefiltered request parameters
|
||||
$request->{params}->{original}->{date}=$request->{params}->{checked}->{date};
|
||||
if ($params->{event_id}ne''){
|
||||
$request->{params}->{original}->{template}='event_details.html';
|
||||
}else{
|
||||
$request->{params}->{original}->{template}='event_list.html';
|
||||
}
|
||||
$request->{params}->{checked} = events::check_params($config, $request->{params}->{original});
|
||||
log::write($config, 'params',$request->{params}->{checked}) if ($debug);
|
||||
|
||||
my $content='';
|
||||
my $results=events::get($config, $request);
|
||||
events::render($content, $config, $request, $results);
|
||||
# calendar::get_cached_or_render($content,$request);
|
||||
|
||||
|
||||
#set url to embed as last loaded url in javascript
|
||||
my $date=$params->{date}||'';
|
||||
$date='heute' if ($params->{date}eq'today');
|
||||
$date=$results->[0]->{day} if ($params->{event_id}ne'');
|
||||
my $url='';
|
||||
#$config->{controllers}->{events}.'/'.$date.'/';
|
||||
if ($params->{from_date}ne'' && $params->{till_date}ne''){
|
||||
$url=$config->{controllers}->{events}.'/'.$params->{from_date}.'/'.$params->{till_date} ;
|
||||
}else{
|
||||
$url=$config->{controllers}->{events}.'/'.$params->{from_date}.'/'.$params->{till_date} ;
|
||||
}
|
||||
|
||||
#count most projects
|
||||
my $used_projects={};
|
||||
for my $result (@$results){
|
||||
my $project=$result->{project_title}||'';
|
||||
$used_projects->{$project}++;
|
||||
}
|
||||
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},
|
||||
event_id => $results->[0]->{event_id},
|
||||
program => $results->[0]->{program},
|
||||
project_title => $most_used_project,
|
||||
series_name => $results->[0]->{series_name},
|
||||
title => $results->[0]->{title},
|
||||
content => $content,
|
||||
results => $results,
|
||||
url => $url,
|
||||
};
|
||||
}
|
||||
|
||||
sub get_menu{
|
||||
my $config = shift;
|
||||
my $request=shift;
|
||||
my $date=shift;
|
||||
my $results=shift;
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
|
||||
#load details only on demand
|
||||
if ($params->{event_id}ne''){
|
||||
$request->{params}->{original}->{template}='event_menu.html';
|
||||
$request->{params}->{original}->{event_id}=undef;
|
||||
$request->{params}->{original}->{date}=$date;
|
||||
$request->{params}->{checked} =events::check_params($config, $request->{params}->{original});
|
||||
$results=events::get($config, $request);
|
||||
}else{
|
||||
$request->{params}->{checked}->{template}=template::check('event_menu.html');
|
||||
}
|
||||
|
||||
#events menu
|
||||
my $output='';
|
||||
events::render($output, $config, $request, $results);
|
||||
|
||||
return {
|
||||
content => $output
|
||||
};
|
||||
}
|
||||
|
||||
sub get_calendar{
|
||||
my $config = shift;
|
||||
my $request=shift;
|
||||
my $date=shift;
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
my $debug=$config->{system}->{debug};
|
||||
|
||||
$request->{params}->{original}->{template} = 'calendar.html';
|
||||
$request->{params}->{original}->{date} = $date if (defined $date);
|
||||
$request->{params}->{checked} = calendar::check_params($config, $request->{params}->{original});
|
||||
$params = $request->{params}->{checked};
|
||||
log::write($config, 'params',$params) if ($debug);
|
||||
|
||||
#set query string for caching
|
||||
my $options=[];
|
||||
push (@$options,'date='.$params->{date}) if ($params->{date} ne'');
|
||||
push (@$options,'from_date='.$params->{from_date}) if ($params->{from_date} ne'');
|
||||
push (@$options,'till_date='.$params->{till_date}) if ($params->{till_date} ne'');
|
||||
$ENV{QUERY_STRING}=''.join("&",@$options);
|
||||
|
||||
my $content='';
|
||||
calendar::get_cached_or_render($content, $config, $request);
|
||||
|
||||
return {
|
||||
content => $content
|
||||
};
|
||||
}
|
||||
|
||||
sub get_newest_comments{
|
||||
my $config = shift;
|
||||
my $request=shift;
|
||||
|
||||
my $params={
|
||||
template =>'comments_newest.html',
|
||||
limit => 10,
|
||||
type =>'list',
|
||||
show_max => 3
|
||||
};
|
||||
$request={
|
||||
url => $ENV{QUERY_STRING},
|
||||
params => {
|
||||
original => $params,
|
||||
checked => comments::check_params($config, $params),
|
||||
},
|
||||
config => $config,
|
||||
connection => $request->{connection}
|
||||
};
|
||||
my $content='';
|
||||
comments::get_cached_or_render($content, $config, $request);
|
||||
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);
|
||||
log::write($config, 'cache_files',cache::get_map()) if ($debug);
|
||||
my $cache=cache::load($config, $params);
|
||||
log::write($config, 'cache_files',$cache->{action}) if ($debug);
|
||||
return $cache;
|
||||
}
|
||||
return{};
|
||||
}
|
||||
|
||||
sub configure_cache{
|
||||
my $config = shift;
|
||||
|
||||
cache::init();
|
||||
my $controllers=$config->{controllers};
|
||||
|
||||
my $date_pattern=$cache::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{
|
||||
my $config = shift;
|
||||
my $params = shift;
|
||||
|
||||
#get start and stop from projects
|
||||
my $range= project::get_date_range($config);
|
||||
my $start_date = $range->{start_date};
|
||||
my $end_date = $range->{end_date};
|
||||
|
||||
# my $project_name=$config->{project}||'';
|
||||
# log::error($config, 'no default project configured') if($project_name eq '');
|
||||
# log::error($config, "no configuration found for project '$project_name'") unless(exists($config->{projects}->{$project_name}));
|
||||
# my $project=$config->{projects}->{$project_name}||'';
|
||||
# log::erorr($config, 'no configuration found for project') if($project eq'');
|
||||
# if ((defined $params->{project}) && ($params->{project}=~/(\w+)/)){
|
||||
# $project=$config->{projects}->{$1} if exists($config->{projects}->{$1});
|
||||
# }
|
||||
|
||||
#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 =$config->{date}->{start_date} if ($date lt $config->{date}->{start_date});
|
||||
# $date =$config->{date}->{end_date} if ($date gt $config->{date}->{end_date});
|
||||
$date =$start_date if $date lt $start_date;
|
||||
$date =$end_date if $date gt $end_date;
|
||||
|
||||
#filter for date
|
||||
# my $date=time::check_date($params->{date});
|
||||
my $time=time::check_time($params->{time});
|
||||
if ((defined $params->{today}) && ($params->{today}eq'1')){
|
||||
$date =time::time_to_date(time());
|
||||
$params->{date}=$date;
|
||||
};
|
||||
|
||||
my $from_date=time::check_date($params->{from_date});
|
||||
my $till_date=time::check_date($params->{till_date});
|
||||
|
||||
my $previous_series=$params->{previous_series} || '';
|
||||
if(($previous_series)&&($previous_series=~/(\d+)/)){
|
||||
$params->{event_id}=events::get_previous_event_of_series(undef, $config, $1);
|
||||
}
|
||||
|
||||
my $next_series=$params->{next_series} || '';
|
||||
if(($next_series)&&($next_series=~/(\d+)/)){
|
||||
$params->{event_id}=events::get_next_event_of_series(undef, $config, $1);
|
||||
}
|
||||
|
||||
my $event_id=$params->{event_id}||'';
|
||||
unless ($event_id eq''){
|
||||
if ($event_id=~/(\d+)/){
|
||||
$event_id=$1;
|
||||
}else{
|
||||
log::error($config, "invalid event_id");
|
||||
}
|
||||
}
|
||||
|
||||
my $debug=$params->{debug}||'';
|
||||
if ($debug=~/([a-z\_\,]+)/){
|
||||
$debug=$1;
|
||||
}
|
||||
|
||||
#set query string for caching
|
||||
if ((!exists $ENV{QUERY_STRING}) || ($ENV{QUERY_STRING}eq'')){
|
||||
my $options=[];
|
||||
push (@$options,'date='.$date) if $date ne'';
|
||||
push (@$options,'from_date='.$from_date) if $from_date ne'';
|
||||
push (@$options,'till_date='.$till_date) if $till_date ne'';
|
||||
push (@$options,'event_id='.$event_id) if $event_id ne'';
|
||||
$ENV{QUERY_STRING}=''.join("&",@$options);
|
||||
}
|
||||
|
||||
return {
|
||||
date => $date,
|
||||
time => $time,
|
||||
from_date => $from_date,
|
||||
till_date => $till_date,
|
||||
event_id => $event_id,
|
||||
# project => $project,
|
||||
debug => $debug,
|
||||
};
|
||||
;
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
180
lib/calcms/audio_recordings.pm
Normal file
180
lib/calcms/audio_recordings.pm
Normal file
@@ -0,0 +1,180 @@
|
||||
#!/bin/perl
|
||||
|
||||
package audio_recordings;
|
||||
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
use db;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
# columns:
|
||||
# id, project_id, studio_id, event_id
|
||||
# created_by, created_at
|
||||
# path, md5
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_audio_recordings');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $columns;
|
||||
}
|
||||
|
||||
# get playout entries
|
||||
sub get{
|
||||
my $config = shift;
|
||||
my $condition = shift;
|
||||
|
||||
return undef unless defined $condition->{project_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 $dbh=db::connect($config);
|
||||
|
||||
my $conditions=[];
|
||||
my $bind_values=[];
|
||||
|
||||
if ((defined $condition->{id}) && ($condition->{id} ne '')){
|
||||
push @$conditions, 'id=?';
|
||||
push @$bind_values, $condition->{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->{event_id}) && ($condition->{event_id} ne '')){
|
||||
push @$conditions, 'event_id=?';
|
||||
push @$bind_values, $condition->{event_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{path}) && ($condition->{path} ne '')){
|
||||
push @$conditions, 'path=?';
|
||||
push @$bind_values, $condition->{path};
|
||||
}
|
||||
|
||||
my $limit='';
|
||||
if ((defined $condition->{limit}) && ($condition->{limit} ne '')){
|
||||
$limit= 'limit '.$condition->{limit};
|
||||
}
|
||||
|
||||
my $whereClause='';
|
||||
$whereClause=" where ".join(" and ",@$conditions) if (scalar @$conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select id
|
||||
,project_id
|
||||
,studio_id
|
||||
,event_id
|
||||
,path
|
||||
,md5
|
||||
,size
|
||||
,created_by
|
||||
,created_at
|
||||
from calcms_audio_recordings
|
||||
$whereClause
|
||||
order by created_at desc
|
||||
};
|
||||
|
||||
print STDERR Dumper($query).Dumper($bind_values);
|
||||
my $entries=db::get($dbh, $query, $bind_values);
|
||||
return $entries;
|
||||
}
|
||||
|
||||
|
||||
# update playout entry if differs to old values
|
||||
sub update{
|
||||
my $config = shift;
|
||||
my $dbh = shift;
|
||||
my $entry = shift;
|
||||
|
||||
print STDERR "update:".Dumper($entry);
|
||||
|
||||
my $day_start=$config->{date}->{day_starting_hour};
|
||||
|
||||
my $bind_values=[
|
||||
$entry->{path}, $entry->{md5}, $entry->{size}, $entry->{created_by}, $entry->{created_at},
|
||||
$entry->{project_id}, $entry->{studio_id}, $entry->{event_id}
|
||||
];
|
||||
|
||||
my $query=qq{
|
||||
update calcms_audio_recordings
|
||||
set path=?, md5=?, size=?, created_by=?, created_at=?
|
||||
where project_id=? and studio_id=? and event_id=?
|
||||
};
|
||||
print STDERR Dumper($query).Dumper($bind_values);
|
||||
return db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
# insert playout entry
|
||||
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->{event_id};
|
||||
return undef unless defined $entry->{path};
|
||||
|
||||
print STDERR "insert into audio_recordings:".Dumper($entry);
|
||||
return db::insert($dbh, 'calcms_audio_recordings', {
|
||||
project_id => $entry->{project_id},
|
||||
studio_id => $entry->{studio_id},
|
||||
event_id => $entry->{event_id},
|
||||
path => $entry->{path},
|
||||
size => $entry->{size},
|
||||
md5 => $entry->{md5},
|
||||
created_by => $entry->{created_by},
|
||||
});
|
||||
|
||||
}
|
||||
|
||||
# delete playout entry
|
||||
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->{event_id};
|
||||
return undef unless defined $entry->{path};
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_audio_recordings
|
||||
where project_id=? and studio_id=? and event_id=? and path=?
|
||||
};
|
||||
my $bind_values = [ $entry->{project_id}, $entry->{studio_id}, $entry->{event_id}, $entry->{path} ];
|
||||
return db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg = shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
354
lib/calcms/auth.pm
Normal file
354
lib/calcms/auth.pm
Normal file
@@ -0,0 +1,354 @@
|
||||
#!/bin/perl
|
||||
|
||||
use CGI;
|
||||
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
|
||||
use CGI::Session qw(-ip-match);
|
||||
use CGI::Cookie;
|
||||
#$CGI::Session::IP_MATCH=1;
|
||||
|
||||
package auth;
|
||||
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
use Authen::Passphrase::BlowfishCrypt;
|
||||
use time;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_user login logout crypt_password);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
|
||||
my $defaultExpiration=60;
|
||||
my $tmp_dir='/var/tmp/';
|
||||
my $debug=0;
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_user{
|
||||
my $cgi=shift;
|
||||
my $config=shift;
|
||||
|
||||
my %parms=$cgi->Vars();
|
||||
my $parms=\%parms;
|
||||
|
||||
debug("get_user")if ($debug);
|
||||
|
||||
# login or logout on action
|
||||
if (defined $parms->{action}){
|
||||
if ($parms->{action} eq 'login'){
|
||||
my $user=login($cgi, $config, $parms->{user}, $parms->{password});
|
||||
$cgi->delete('user','password','uri','action');
|
||||
return $user;
|
||||
}elsif($parms->{action} eq 'logout'){
|
||||
logout($cgi);
|
||||
$cgi->delete('user','password','uri','action');
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# read session id from cookie
|
||||
my $session_id=read_cookie($cgi);
|
||||
|
||||
# login if no cookie found
|
||||
return show_login_form($parms->{user}, 'Please login') unless defined $session_id;
|
||||
|
||||
# read session
|
||||
my $session=read_session($session_id);
|
||||
|
||||
# login if user not found
|
||||
return show_login_form($parms->{user}, 'unknown User') unless defined $session;
|
||||
|
||||
$parms->{user} = $session->{user};
|
||||
$parms->{expires} = $session->{expires};
|
||||
debug($parms->{expires});
|
||||
return $session->{user}, $session->{expires};
|
||||
}
|
||||
|
||||
sub crypt_password{
|
||||
my $password=shift;
|
||||
|
||||
my $ppr = Authen::Passphrase::BlowfishCrypt->new(
|
||||
cost => 8,
|
||||
salt_random => 1,
|
||||
passphrase => $password
|
||||
);
|
||||
return{
|
||||
salt => $ppr->salt_base64,
|
||||
crypt => $ppr->as_crypt
|
||||
};
|
||||
}
|
||||
|
||||
sub login{
|
||||
my $cgi=shift;
|
||||
my $config=shift;
|
||||
my $user=shift;
|
||||
my $password=shift;
|
||||
debug("login")if ($debug);
|
||||
|
||||
#print STDERR "login $user $password\n";
|
||||
my $result = authenticate($config, $user, $password);
|
||||
#print STDERR Dumper($result);
|
||||
|
||||
return show_login_form($user,'Could not authenticate you') unless defined $result;
|
||||
return unless defined $result->{login}eq '1';
|
||||
|
||||
my $timeout=$result->{timeout} || $defaultExpiration;
|
||||
$timeout='+'.$timeout.'m';
|
||||
|
||||
my $session_id=create_session($user, $password, $timeout);
|
||||
return $user if(create_cookie($cgi, $session_id, $timeout));
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub logout{
|
||||
my $cgi=shift;
|
||||
my $session_id=read_cookie($cgi);
|
||||
debug("logout")if ($debug);
|
||||
unless(delete_session($session_id)){
|
||||
return show_login_form('Cant delete session', 'logged out');
|
||||
};
|
||||
unless(delete_cookie($cgi)){
|
||||
return show_login_form('Cant remove cookie', 'logged out');
|
||||
}
|
||||
my $uri=$ENV{HTTP_REFERER}||'';
|
||||
$uri=~s/action=logout//g;
|
||||
print $cgi->redirect($uri);
|
||||
# return show_login_form('', 'logged out');
|
||||
}
|
||||
|
||||
#read and write data from browser, http://perldoc.perl.org/CGI/Cookie.html
|
||||
sub create_cookie{
|
||||
my $cgi=shift;
|
||||
my $session_id=shift;
|
||||
my $timeout=shift;
|
||||
#debug("create_cookie")if ($debug);
|
||||
|
||||
my $cookie = CGI::Cookie->new(
|
||||
-name => 'sessionID',
|
||||
-value => $session_id,
|
||||
-expires => $timeout,
|
||||
# -domain => '.capricorn.com',
|
||||
# -path => '/agenda/admin/',
|
||||
-secure => 1
|
||||
);
|
||||
print "Set-Cookie: ",$cookie->as_string,"\n";
|
||||
print STDERR "#Set-Cookie: ",$cookie->as_string,"\n";
|
||||
# print $cgi->header( -cookie => $cookie );
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub read_cookie{
|
||||
my $cgi=shift;
|
||||
|
||||
debug("read_cookie")if ($debug);
|
||||
my %cookie = CGI::Cookie->fetch;
|
||||
debug("cookies: ".Dumper(\%cookie))if ($debug);
|
||||
my $cookie=$cookie{'sessionID'};
|
||||
debug("cookie: ".$cookie)if ($debug);
|
||||
return undef unless (defined $cookie);
|
||||
my $session_id= $cookie->value || undef;
|
||||
debug("sid: ".$session_id)if ($debug);
|
||||
return $session_id;
|
||||
#return $cgi->cookie('sessionID') || undef;
|
||||
};
|
||||
|
||||
sub delete_cookie{
|
||||
my $cgi=shift;
|
||||
|
||||
debug("delete_cookie")if ($debug);
|
||||
my $cookie = $cgi->cookie(
|
||||
-name => 'sessionID',
|
||||
-value => '',
|
||||
-expires => '+1s'
|
||||
);
|
||||
print $cgi->header( -cookie => $cookie );
|
||||
return 1;
|
||||
}
|
||||
|
||||
#read and write server-side session data
|
||||
sub create_session{
|
||||
my $user=shift;
|
||||
my $password=shift;
|
||||
my $expiration=shift;
|
||||
|
||||
debug("create_session")if ($debug);
|
||||
my $session = new CGI::Session(undef, undef, {Directory=>$tmp_dir});
|
||||
$session->expire($expiration);
|
||||
$session->param("user", $user);
|
||||
$session->param("pid", $$);
|
||||
# $session->param("password", $password);
|
||||
return $session->id();
|
||||
}
|
||||
|
||||
sub read_session{
|
||||
my $session_id=shift;
|
||||
|
||||
debug("read_session")if $debug;
|
||||
return undef unless(defined $session_id);
|
||||
|
||||
debug("read_session2")if $debug;
|
||||
my $session = new CGI::Session(undef, $session_id, {Directory=>$tmp_dir});
|
||||
return undef unless defined $session;
|
||||
|
||||
debug("read_session3")if $debug;
|
||||
my $user = $session->param("user") || undef;
|
||||
return undef unless defined $user;
|
||||
my $expires = time::time_to_datetime($session->param("_SESSION_ATIME")+$session->param("_SESSION_ETIME"));
|
||||
return {
|
||||
user => $user,
|
||||
expires => $expires
|
||||
}
|
||||
}
|
||||
|
||||
sub delete_session{
|
||||
my $session_id=shift;
|
||||
|
||||
debug("delete_session")if ($debug);
|
||||
return undef unless(defined $session_id);
|
||||
my $session = new CGI::Session(undef, $session_id, {Directory=>$tmp_dir});
|
||||
$session->delete();
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
#check user authentication
|
||||
sub authenticate{
|
||||
my $config=shift;
|
||||
my $user=shift;
|
||||
my $password=shift;
|
||||
|
||||
$config->{access}->{write}=0;
|
||||
my $dbh = db::connect($config);
|
||||
my $query = qq{
|
||||
select *
|
||||
from calcms_users
|
||||
where name=?
|
||||
};
|
||||
my $bind_values = [$user];
|
||||
#print STDERR "query:".Dumper($query).Dumper($bind_values);
|
||||
|
||||
my $users = db::get($dbh,$query,$bind_values);
|
||||
#print STDERR "result:".Dumper($users);
|
||||
|
||||
if (scalar(@$users) != 1){
|
||||
print STDERR "auth: did not find user '$user'\n";
|
||||
return undef;
|
||||
}
|
||||
#print STDERR Dumper($users);
|
||||
|
||||
my $salt=$users->[0]->{salt};
|
||||
my $ppr = Authen::Passphrase::BlowfishCrypt->from_crypt(
|
||||
$users->[0]->{pass},
|
||||
$users->[0]->{salt}
|
||||
);
|
||||
|
||||
return undef unless $ppr->match($password);
|
||||
if($users->[0]->{disabled} == 1){
|
||||
print STDERR "user '$user' is disabled\n";
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $timeout = $users->[0]->{session_timeout} || 120;
|
||||
$timeout =10 if $timeout < 10;
|
||||
$timeout =12*60 if $timeout > 12*60;
|
||||
|
||||
return {
|
||||
timeout => $timeout,
|
||||
login => 1
|
||||
}
|
||||
}
|
||||
|
||||
sub show_login_form{
|
||||
my $user=shift||'';
|
||||
my $uri=$ENV{HTTP_REFERER}||'';
|
||||
my $message=shift||'';
|
||||
debug("show_login_form")if ($debug);
|
||||
print qq{Content-type:text/html
|
||||
|
||||
<!DOCTYPE HTML>
|
||||
<html>
|
||||
<head>
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1.0">
|
||||
<style type="text/css">
|
||||
html,body{
|
||||
height: 100%;
|
||||
font-family:helvetica,arial,sans-serif;
|
||||
}
|
||||
|
||||
body{
|
||||
display: table;
|
||||
margin: 0 auto;
|
||||
}
|
||||
|
||||
input, .row, .field{
|
||||
padding:0.5em;
|
||||
}
|
||||
|
||||
.container{
|
||||
height: 100%;
|
||||
display: table-cell;
|
||||
vertical-align: middle;
|
||||
}
|
||||
|
||||
#login_form{
|
||||
background:#ddd;
|
||||
box-shadow: 1em 1em 1em #888;
|
||||
margin:1em;
|
||||
padding:1em;
|
||||
text-align:center;
|
||||
}
|
||||
|
||||
#login_form .field{
|
||||
width:8em;
|
||||
float:left;
|
||||
}
|
||||
|
||||
#login_form .message{
|
||||
background:#ccc;
|
||||
text-align:left;
|
||||
font-weight:bold;
|
||||
padding:1em;
|
||||
margin:-1em;
|
||||
margin-bottom:0;
|
||||
}
|
||||
</style>
|
||||
</head>
|
||||
<body>
|
||||
|
||||
<div class="container">
|
||||
<div id="login_form">
|
||||
<div class="message">$message</div><br/>
|
||||
<form method="post">
|
||||
<div class="row">
|
||||
<div class="field">user</div>
|
||||
<input name="user" value="$user"><br/>
|
||||
</div>
|
||||
<div class="row">
|
||||
<div class="field">password</div>
|
||||
<input type="password" name="password"><br/>
|
||||
</div>
|
||||
<div class="row">
|
||||
<input type="submit" name="action" value="login">
|
||||
<input type="submit" name="action" value="logout">
|
||||
</div>
|
||||
<input type="hidden" name="uri" value="$uri">
|
||||
</form>
|
||||
</div>
|
||||
</container>
|
||||
</body>
|
||||
</html>
|
||||
};
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub debug{
|
||||
my $message=shift;
|
||||
print STDERR "$message\n" if $debug>0;
|
||||
}
|
||||
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
179
lib/calcms/cache.pm
Normal file
179
lib/calcms/cache.pm
Normal file
@@ -0,0 +1,179 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
#use Data::Dumper;
|
||||
|
||||
use config;
|
||||
use time;
|
||||
use log;
|
||||
use markup;
|
||||
|
||||
package cache;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(init add_map get_map get_map_keys load save get_filename escape_regexp escape_regexp_line);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
my $cache_map ={};
|
||||
my $cache_map_keys =[];
|
||||
my $header_printed =0;
|
||||
|
||||
our $date_pattern ='(\d{4})\-(\d{2})\-(\d{2})';
|
||||
our $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 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;
|
||||
log::write($config, 'cache_trace',"look at \"$filename\" for $pattern") if ($config->{system}->{debug});
|
||||
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;
|
||||
516
lib/calcms/calendar.pm
Normal file
516
lib/calcms/calendar.pm
Normal file
@@ -0,0 +1,516 @@
|
||||
#use Calendar::Simple qw(date_span);
|
||||
use Date::Calc;
|
||||
|
||||
use config;
|
||||
use template;
|
||||
use markup;
|
||||
use cache;
|
||||
use log;
|
||||
use time;
|
||||
use project;
|
||||
use events;
|
||||
|
||||
package calendar;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(init get_cached_or_render get render get_calendar_weeks configure_cache);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
#my $debug='';
|
||||
|
||||
sub init{
|
||||
}
|
||||
|
||||
sub get_cached_or_render{
|
||||
# my $output = $_[0]
|
||||
my $config = $_[1];
|
||||
my $request = $_[2];
|
||||
|
||||
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);
|
||||
log::write($config, 'cache',$cache->{action}) if ($debug);
|
||||
if (defined $cache->{content}){
|
||||
$_[0]=$cache->{content};
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my $calendar=calendar::get($config, $request);
|
||||
log::write($config, 'calendar',$calendar) if ($debug);
|
||||
#print STDERR Dumper($calendar);
|
||||
|
||||
calendar::render($_[0], $config, $request, $calendar);
|
||||
|
||||
#write to cache
|
||||
if ($config->{cache}->{use_cache} == 1){
|
||||
#todo:put out reference only
|
||||
$cache->{content}=$_[0];
|
||||
log::write($config, 'cache_files',$cache) if ($debug);
|
||||
cache::save($cache);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub get{
|
||||
my $config = shift;
|
||||
my $request = shift;
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
my $debug=$config->{system}->{debug};
|
||||
|
||||
my $language = $config->{date}->{language} || 'en';
|
||||
|
||||
my $date = $params->{date}||'';
|
||||
my $template = $params->{template}||'';
|
||||
my $from_time = $params->{from_time}||'';
|
||||
my $till_time = $params->{till_time}||'';
|
||||
|
||||
my @today=localtime(time());
|
||||
my $today=sprintf('%04d-%02d-%02d', 1900+$today[5], $today[4]+1, $today[3]);
|
||||
|
||||
my $weekday_names = $time::names->{$language}->{weekdays};
|
||||
my $weekday_short_names = $time::names->{$language}->{weekdays_abbr};
|
||||
my $week_label={};
|
||||
my $c=0;
|
||||
for my $weekday (@$weekday_short_names){
|
||||
$week_label->{$weekday}=$weekday_names->[$c]||'';
|
||||
$c++;
|
||||
}
|
||||
|
||||
$template=~s/\'//gi;
|
||||
$from_time=~s/\'//gi;
|
||||
$till_time=~s/\'//gi;
|
||||
|
||||
#put "clear all" filter into final results
|
||||
my $day_result={};
|
||||
my $clear_filter=$day_result;
|
||||
|
||||
#put "week day" filter into final results
|
||||
my $days=[];
|
||||
$c=0;
|
||||
for my $weekday (@$weekday_short_names){
|
||||
my $day_result={
|
||||
label => $week_label->{$weekday},
|
||||
weekday => $c+1,
|
||||
weekday_parameter => 'weekday='.$c,
|
||||
weekday_short_name => $weekday_short_names->[$c] ||'',
|
||||
weekday_name => $weekday_names->[$c] ||'',
|
||||
description => qq{alle $week_label->{$weekday}-Termine anzeigen},
|
||||
};
|
||||
push @$days,$day_result;
|
||||
$c++;
|
||||
}
|
||||
|
||||
#weeks and days array
|
||||
my $weekAndDayResults=[];
|
||||
|
||||
#weekday array
|
||||
my $weekdayResults=$days;
|
||||
|
||||
#week array
|
||||
my $weekResults=[];
|
||||
|
||||
#info hash by timedate
|
||||
my $dateInfo={};
|
||||
|
||||
#generate content for each day in a week in a month in a year
|
||||
#get today
|
||||
my $start_date='';
|
||||
my $end_date='';
|
||||
if ($date=~/(\d{4})\-(\d{2})/){
|
||||
my $year=$1;
|
||||
my $month=$2;
|
||||
$start_date = "$year-$month-01";
|
||||
$end_date = "$year-$month-".Date::Calc::Days_in_Month($year,$month);
|
||||
}else{
|
||||
$start_date = $params->{start_date};
|
||||
$end_date = $params->{end_date};
|
||||
}
|
||||
|
||||
my $previous_month=$start_date;
|
||||
if ($previous_month=~/(\d{4})\-(\d{2})/){
|
||||
my $year =$1;
|
||||
my $month=$2-1;
|
||||
$month='0'.$month if (length($month)<2);
|
||||
if ($month lt '01'){
|
||||
$year-=1;
|
||||
$month='12';
|
||||
}
|
||||
$previous_month="$year-$month-01";
|
||||
$previous_month=$params->{start_date} if ($previous_month lt $params->{start_date});
|
||||
}
|
||||
|
||||
my $next_month=$end_date;
|
||||
if ($next_month=~/(\d{4})\-(\d{2})/){
|
||||
my $year=$1;
|
||||
my $month=$2+1;
|
||||
$month='0'.$month if (length($month)<2);
|
||||
if ($month gt '12'){
|
||||
$year+=1;
|
||||
$month='01';
|
||||
}
|
||||
$next_month="$year-$month-01";
|
||||
$next_month=$params->{end_date} if ($next_month gt $params->{end_date});
|
||||
}
|
||||
|
||||
my $start_year=undef;
|
||||
my $start_month=undef;
|
||||
if ($start_date=~/(\d{4})\-(\d{2})/){
|
||||
$start_year=$1;
|
||||
$start_month=$2;
|
||||
}
|
||||
my $start_month_name=$time::names->{$language}->{months_abbr}->[$start_month-1];
|
||||
|
||||
if($params->{month_only}eq'1'){
|
||||
return {
|
||||
next_month => $next_month,
|
||||
previous_month => $previous_month,
|
||||
start_year => $start_year,
|
||||
start_month => $start_month,
|
||||
start_month_name => $start_month_name
|
||||
};
|
||||
}
|
||||
|
||||
my $years=calendar::get_calendar_weeks($config, $start_date, $end_date);
|
||||
|
||||
my $dbh=db::connect($config, $request);
|
||||
|
||||
my $used_days=events::get_by_date_range($dbh, $config, $start_date, $end_date);
|
||||
my $used_day={};
|
||||
for my $day(@$used_days){
|
||||
$used_day->{$day->{start_date}}=1;
|
||||
}
|
||||
|
||||
for my $year (sort {$a <=> $b} keys %$years){
|
||||
my $months=$years->{$year};
|
||||
|
||||
for my $month (sort {$a <=> $b} keys %$months){
|
||||
my $weeks=$months->{$month};
|
||||
|
||||
my $weekCounter=1;
|
||||
for my $week (@$weeks){
|
||||
my $dayResults=[];
|
||||
|
||||
my $week_end =undef;
|
||||
my $week_start=undef;
|
||||
|
||||
my $week_of_year=undef;
|
||||
my $woy_year = undef;
|
||||
|
||||
for my $date (@$week){
|
||||
my ($year, $month, $day)=split(/\-/,$date);
|
||||
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;
|
||||
|
||||
$day_result={
|
||||
date => $date,
|
||||
date_parameter => 'date='.$date,
|
||||
day => $day,
|
||||
year => $year,
|
||||
month => $month,
|
||||
};
|
||||
$day_result->{time} =$from_time if defined $from_time;
|
||||
|
||||
$day_result->{class}.= ' calcms_today' if $date eq $today;
|
||||
$day_result->{class}.= ' selected' if defined $used_day->{$date};
|
||||
$day_result->{class}.= " week_$weekCounter";
|
||||
$day_result->{class}.= " other_month" if ($weekCounter<2) && ($day gt "15");
|
||||
$day_result->{class}.= " other_month" if ($weekCounter>3) && ($day lt "15");
|
||||
$day_result->{class}=~s/^\s+//g;
|
||||
|
||||
$week_start =$day unless defined $week_start;
|
||||
$week_end =$day;
|
||||
|
||||
log::write($config, 'day_results',$day_result)if ($debug);
|
||||
|
||||
$day_result->{weekday_name}=$weekday_names->[$weekday];
|
||||
$day_result->{weekday_short_name}=$weekday_short_names->[$weekday];
|
||||
$day_result->{weekday}=$weekday+1;
|
||||
|
||||
$dateInfo->{$day_result->{date}}=$day_result->{weekday} if defined $day_result->{date};
|
||||
|
||||
push @$dayResults, $day_result;
|
||||
$weekday++;
|
||||
|
||||
}#end for days
|
||||
|
||||
#week filter
|
||||
my $start_date=$week->[0];
|
||||
my $end_date =$week->[-1];
|
||||
|
||||
my $week_result={
|
||||
from_date => $start_date,
|
||||
till_date => $end_date,
|
||||
week_start => $week_start,
|
||||
week_end => $week_end,
|
||||
week_month => sprintf("%2d",$month),
|
||||
week_year => $year,
|
||||
week_of_year => $week_of_year,
|
||||
};
|
||||
|
||||
$week_result->{class}.= ' selected' if (
|
||||
((defined $params->{from_date}) && ($start_date eq $params->{from_date}))
|
||||
|| ((defined $params->{till_date}) && ($end_date eq $params->{till_date}))
|
||||
);
|
||||
$week_result->{class}.= " week_$weekCounter";
|
||||
$week_result->{class}=~s/^\s+//g;
|
||||
|
||||
push @$weekResults, $week_result;
|
||||
|
||||
push @$weekAndDayResults,{
|
||||
days=>$dayResults,
|
||||
week=>[$week_result]
|
||||
};
|
||||
$weekCounter++;
|
||||
|
||||
}#end week
|
||||
|
||||
}#end month
|
||||
|
||||
}#end year
|
||||
|
||||
for my $weekday (@$weekdayResults){
|
||||
$weekday->{start_date} = $start_date;
|
||||
$weekday->{end_date} = $end_date;
|
||||
}
|
||||
|
||||
return {
|
||||
week_and_days => $weekAndDayResults,
|
||||
weekdays => $weekdayResults,
|
||||
weeks => $weekResults,
|
||||
days => $dateInfo,
|
||||
next_month => $next_month,
|
||||
previous_month => $previous_month,
|
||||
start_date => $start_date,
|
||||
end_date => $end_date,
|
||||
start_month_name => $start_month_name,
|
||||
start_month => $start_month,
|
||||
start_year => $start_year,
|
||||
base_url => $config->{locations}->{base_url},
|
||||
cache_base_url => $config->{cache}->{base_url},
|
||||
controllers => $config->{controllers},
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
sub render{
|
||||
# my $out = $_[0];
|
||||
my $config = $_[1];
|
||||
my $request = $_[2];
|
||||
my $calendar = $_[3];
|
||||
|
||||
my $parms =$request->{params}->{checked};
|
||||
my $debug=$config->{system}->{debug};
|
||||
|
||||
my $template_parameters=$calendar;
|
||||
$template_parameters->{debug} = $config->{system}->{debug};
|
||||
$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::process($_[0], $parms->{template}, $template_parameters);
|
||||
}
|
||||
|
||||
sub get_calendar_weeks{
|
||||
my $config = shift;
|
||||
my $start = shift;
|
||||
my $end = shift;
|
||||
|
||||
my $debug = $config->{system}->{debug};
|
||||
|
||||
$start = time::date_to_array($start);
|
||||
$end = time::date_to_array($end);
|
||||
|
||||
my $start_year = int($start->[0]);
|
||||
my $end_year = int($end->[0]);
|
||||
|
||||
my $start_month = int($start->[1]);
|
||||
my $end_month = int($end->[1]);
|
||||
|
||||
my $years={};
|
||||
for my $year ($start_year..$end_year){
|
||||
my $months={};
|
||||
for my $month ($start_month..$end_month){
|
||||
#get week arrays of days of the month
|
||||
my $weeks=getWeeksOfMonth($year, $month);
|
||||
$months->{$month}=$weeks;
|
||||
}
|
||||
$years->{$year}=$months;
|
||||
}
|
||||
log::write($config, 'years',$years)if ($debug);
|
||||
return $years;
|
||||
}
|
||||
|
||||
sub getWeeksOfMonth{
|
||||
my $thisYear = shift;
|
||||
my $thisMonth = shift;
|
||||
my $thisDay = 1;
|
||||
|
||||
# get weekday of 1st of month
|
||||
my $thisMonthWeekday = Date::Calc::Day_of_Week($thisYear,$thisMonth,1);
|
||||
|
||||
# get next month date
|
||||
my($nextYear, $nextMonth, $nextDay)=Date::Calc::Add_Delta_YM($thisYear,$thisMonth,$thisDay, 0,1);
|
||||
# get weekday of 1st of next month
|
||||
my $nextMonthWeekday = Date::Calc::Day_of_Week($nextYear, $nextMonth, $nextDay);
|
||||
my($lastYear, $lastMonth, $lastDayOfMonth)=Date::Calc::Add_Delta_Days($nextYear,$nextMonth,$nextDay, -1);
|
||||
|
||||
# get date of 1st of row
|
||||
my( $week,$year) = Date::Calc::Week_of_Year($thisYear,$thisMonth,$thisDay);
|
||||
($year,my $month, my $day) = Date::Calc::Monday_of_Week($week,$year);
|
||||
|
||||
my @weeks=();
|
||||
my $weekday=1;
|
||||
|
||||
{
|
||||
# first week
|
||||
my @days=();
|
||||
for $weekday(0 .. $thisMonthWeekday-2){
|
||||
push @days, sprintf("%04d-%02d-%02d",$year,$month,$day);
|
||||
$day++;
|
||||
}
|
||||
# set current month
|
||||
$month = $thisMonth;
|
||||
$year = $thisYear;
|
||||
$day = 1;
|
||||
for $weekday($thisMonthWeekday..7){
|
||||
push @days, sprintf("%04d-%02d-%02d",$year,$month,$day);
|
||||
$day++;
|
||||
}
|
||||
# next week
|
||||
push @weeks, \@days;
|
||||
}
|
||||
|
||||
# weeks until end of month
|
||||
while(scalar(@weeks)<6){
|
||||
my @days=();
|
||||
$weekday=1;
|
||||
while($weekday<=7){
|
||||
push @days, sprintf("%04d-%02d-%02d",$year,$month,$day);
|
||||
$day++;
|
||||
$weekday++;
|
||||
last if $day>$lastDayOfMonth;
|
||||
}
|
||||
|
||||
if ($day>$lastDayOfMonth){
|
||||
# set next month
|
||||
$month=$nextMonth;
|
||||
$year=$nextYear;
|
||||
$day=1;
|
||||
|
||||
if ($nextMonthWeekday!=1){
|
||||
# finish end week
|
||||
if($weekday<=7){
|
||||
while( $weekday<=7){
|
||||
push @days, sprintf("%04d-%02d-%02d",$year,$month,$day);
|
||||
$day++;
|
||||
$weekday++;
|
||||
}
|
||||
}
|
||||
}
|
||||
push @weeks, \@days;
|
||||
last;
|
||||
};
|
||||
push @weeks, \@days if $weeks[-1]->[-1] ne $days[-1];
|
||||
}
|
||||
|
||||
#coming weeks
|
||||
while(scalar(@weeks)<6){
|
||||
my @days=();
|
||||
for $weekday(1..7){
|
||||
push @days, sprintf("%04d-%02d-%02d",$year,$month,$day);
|
||||
$day++;
|
||||
}
|
||||
push @weeks, \@days;
|
||||
}
|
||||
return \@weeks;
|
||||
}
|
||||
|
||||
sub configure_cache{
|
||||
my $config = shift;
|
||||
my $debug=$config->{system}->{debug};
|
||||
|
||||
cache::init();
|
||||
|
||||
my $date_pattern = $cache::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');
|
||||
|
||||
log::write($config, 'cache_files',cache::get_map()) if ($debug);
|
||||
}
|
||||
|
||||
sub check_params{
|
||||
my $config=shift;
|
||||
my $params=shift;
|
||||
|
||||
#get start and stop from projects
|
||||
my $range= project::get_date_range($config);
|
||||
my $start_date = $range->{start_date};
|
||||
my $end_date = $range->{end_date};
|
||||
|
||||
#switch off limiting end date by project
|
||||
my $open_end=0;
|
||||
if((defined $params->{'open_end'})&&($params->{'open_end'}=~/(\d+)/)){
|
||||
$open_end = $1;
|
||||
$end_date = time::add_days_to_datetime(time::time_to_datetime(), 365);
|
||||
}
|
||||
|
||||
my $month_only=$params->{month_only}||'';
|
||||
|
||||
#filter for date
|
||||
my $date=time::check_date($params->{date});
|
||||
|
||||
$date =$start_date if ($date lt $start_date);
|
||||
$date =$end_date if ($date gt $end_date);
|
||||
log::error($config, "no valid year-month format given!") if ($date eq"-1");
|
||||
|
||||
my $time=time::check_time($params->{time});
|
||||
log::error($config, "no valid time format given!") if ($time eq"-1");
|
||||
|
||||
my $from_date=time::check_date($params->{from_date})||'';
|
||||
log::error($config, "no valid date format given!") if (defined $from_date && $from_date eq"-1");
|
||||
$from_date =$start_date if ($from_date lt $start_date);
|
||||
$from_date =$end_date if ($from_date gt $end_date);
|
||||
|
||||
my $till_date=time::check_date($params->{till_date}||'');
|
||||
log::error($config, "no valid date format given!") if (defined $till_date && $till_date eq"-1");
|
||||
$till_date =$start_date if ($till_date lt $start_date);
|
||||
$till_date =$end_date if ($till_date gt $end_date);
|
||||
|
||||
my $template=template::check($params->{template},'calendar.html');
|
||||
|
||||
my $debug=$params->{debug};
|
||||
if ((defined $debug) && ($debug=~/([a-z\_\,]+)/)){
|
||||
$debug=$1;
|
||||
}
|
||||
|
||||
return {
|
||||
template => $template,
|
||||
date => $date,
|
||||
from_date => $from_date,
|
||||
till_date => $till_date,
|
||||
debug => $debug,
|
||||
month_only => $month_only,
|
||||
open_end => $open_end,
|
||||
start_date => $start_date,
|
||||
end_date => $end_date
|
||||
}
|
||||
}
|
||||
#do not delete last line!
|
||||
1;
|
||||
|
||||
712
lib/calcms/comments.pm
Normal file
712
lib/calcms/comments.pm
Normal file
@@ -0,0 +1,712 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use config;
|
||||
use template;
|
||||
use time;
|
||||
|
||||
package comments;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
#our @EXPORT = qw(all);
|
||||
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);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub init{
|
||||
}
|
||||
|
||||
sub get_cached_or_render{
|
||||
# my $response=$_[0];
|
||||
my $config = $_[1];
|
||||
my $request = $_[2];
|
||||
my $mark_locked = $_[3];
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
#print STDERR Dumper($params);
|
||||
$config->{app_name}=$config->{controllers}->{comments};
|
||||
|
||||
my $comment=$request->{params}->{checked};
|
||||
|
||||
my $filename='';
|
||||
my $cache={};
|
||||
|
||||
my $results=comments::get($config, $request);
|
||||
|
||||
if((defined $mark_locked) && ($mark_locked eq 'mark_locked')){
|
||||
for my $result(@$results){
|
||||
if($result->{lock_status}ne'show'){
|
||||
$result->{author}='Zensur';
|
||||
$result->{content}='Dieser Eintrag wurde gelöscht.';
|
||||
}
|
||||
}
|
||||
}elsif((defined $mark_locked) && ($mark_locked eq 'filter_locked')){
|
||||
my @results2=();
|
||||
for my $result(@$results){
|
||||
push @results2, $result if($result->{lock_status}eq'show');
|
||||
}
|
||||
$results=\@results2;
|
||||
}
|
||||
|
||||
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})
|
||||
){
|
||||
my @results2=();
|
||||
my $c=0;
|
||||
for my $result(@$results){
|
||||
push @results2,$result;
|
||||
$c++;
|
||||
last if ($c>=$params->{show_max});
|
||||
}
|
||||
$results=\@results2;
|
||||
}
|
||||
|
||||
comments::render($_[0], $config, $request, $results);
|
||||
|
||||
}
|
||||
|
||||
sub get{
|
||||
my $config = shift;
|
||||
my $request= shift;
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
|
||||
my $dbh=db::connect($config, $request);
|
||||
|
||||
(my $query, my $bind_values)=comments::get_query($dbh, $config, $request);
|
||||
#print STDERR Dumper($$query);
|
||||
#print STDERR Dumper($bind_values);
|
||||
my $results=db::get($dbh, $$query, $bind_values);
|
||||
#print STDERR Dumper($results);
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub get_query{
|
||||
my $dbh = shift;
|
||||
my $config = shift;
|
||||
my $request=shift;
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
|
||||
my $event_id = undef;
|
||||
my $event_start = undef;
|
||||
my $from = 'calcms_comments c';
|
||||
my $where = '';
|
||||
my $limit = '';
|
||||
my @conditions=();
|
||||
my $bind_values=[];
|
||||
|
||||
#exclude comments from config filter/exclude_locations
|
||||
if (
|
||||
(defined $config->{filter})
|
||||
&& (defined $config->{filter}->{exclude_locations})
|
||||
){
|
||||
my @exclude_locations=split(/[,\s]+/,$config->{filter}->{exclude_locations});
|
||||
my $exclude_locations=join(', ',map {'?'} @exclude_locations);
|
||||
|
||||
$from.=',calcms_events e';
|
||||
push @conditions,'e.id=c.event_id';
|
||||
push @conditions,'e.location not in ('.$exclude_locations.')';
|
||||
for my $location (@exclude_locations){
|
||||
push @$bind_values, $location;
|
||||
}
|
||||
}
|
||||
|
||||
if (
|
||||
(defined $params->{event_id} && $params->{event_id}ne'') &&
|
||||
(defined $params->{event_start} && $params->{event_start}ne'')
|
||||
){
|
||||
#$where =qq{ and (event_id=? or event_start=?) };
|
||||
push @conditions, q{ (event_id=? or event_start=?) };
|
||||
push @$bind_values, $params->{event_id};
|
||||
push @$bind_values, $params->{event_start};
|
||||
}
|
||||
|
||||
my $sort_order=$params->{sort_order};
|
||||
|
||||
if ($params->{limit} ne''){
|
||||
$limit ='limit ?';
|
||||
push @$bind_values,$params->{limit};
|
||||
}
|
||||
|
||||
if (@conditions>0){
|
||||
$where= 'where '.join(' and ',@conditions);
|
||||
}
|
||||
|
||||
my $dbcols=['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{
|
||||
select $cols
|
||||
from $from
|
||||
$where
|
||||
order by created_at $sort_order
|
||||
$limit
|
||||
};
|
||||
# where lock_status='show'
|
||||
# use Data::Dumper;print STDERR Dumper($query);
|
||||
|
||||
return (\$query, $bind_values);
|
||||
}
|
||||
|
||||
sub modify_results{
|
||||
my $results = $_[0];
|
||||
my $config = $_[1];
|
||||
my $request = $_[2];
|
||||
|
||||
my $params=$request->{params}->{checked};
|
||||
|
||||
my $time_diff='';
|
||||
if ($params->{template}=~/\.xml/){
|
||||
$time_diff=time::utc_offset($config->{date}->{time_zone});
|
||||
$time_diff=~s/(\d\d)(\d\d)/$1\:$2/g;
|
||||
}
|
||||
|
||||
my $language = $config->{date}->{language} || 'en';
|
||||
|
||||
for my $result (@$results){
|
||||
$result->{allow}->{new_comments} = 1 if ($params->{allow}->{new_comments});
|
||||
$result->{start_date_name} = time::date_format($result->{created_at}, $language);
|
||||
$result->{start_time_name} = time::time_format($result->{created_at});
|
||||
my $comment_limit=100;
|
||||
if (length($result->{content})>$comment_limit){
|
||||
$result->{short_content} = substr($result->{content},0,$comment_limit).'...' ;
|
||||
}else{
|
||||
$result->{short_content} = $result->{content};
|
||||
}
|
||||
$result->{base_url} = $config->{locations}->{base_url};
|
||||
$result->{cache_base_url} = $config->{cache}->{base_url};
|
||||
|
||||
if($params->{template}=~/\.xml/){
|
||||
# $result->{content} =~s/(\[\[.*?\]\])//gi;
|
||||
# $result->{content} =markup::plain_to_xml($result->{content});
|
||||
# $result->{content} =$result->{html_content};
|
||||
|
||||
$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});
|
||||
|
||||
if (defined $result->{created_at}){
|
||||
$result->{created_at}=~s/ /T/gi;
|
||||
$result->{created_at}.=$time_diff;
|
||||
}
|
||||
|
||||
if (defined $result->{modified_at}){
|
||||
$result->{modified_at}=~s/ /T/gi;
|
||||
$result->{modified_at}.=$time_diff;
|
||||
}
|
||||
}
|
||||
}
|
||||
return $results;
|
||||
}
|
||||
|
||||
|
||||
sub render{
|
||||
# my $response =$_[0];
|
||||
my $config = $_[1];
|
||||
my $request = $_[2];
|
||||
my $results = $_[3];
|
||||
|
||||
my $params =$request->{params}->{checked};
|
||||
|
||||
my %template_parameters=%$params;
|
||||
my $template_parameters=\%template_parameters;
|
||||
|
||||
$template_parameters->{comments} = $results;
|
||||
$template_parameters->{comment_count} =(@$results)+0;
|
||||
$template_parameters->{one_result} =1 if($template_parameters->{comment_count}==1);
|
||||
$template_parameters->{allow}->{new_comments} =1 if ($params->{allow}->{new_comments});
|
||||
|
||||
$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::process($_[0],$params->{template},$template_parameters);
|
||||
}
|
||||
|
||||
#check if comment exists already
|
||||
sub check{
|
||||
my $dbh = shift;
|
||||
my $config = shift;
|
||||
my $comment = shift;
|
||||
|
||||
my $query=qq{
|
||||
select id
|
||||
from calcms_comments
|
||||
where (
|
||||
event_start=?
|
||||
or event_id=?
|
||||
)
|
||||
and parent_id=?
|
||||
and author=?
|
||||
and ip=?
|
||||
and 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);
|
||||
|
||||
my @comments=@$comments;
|
||||
return 0 if (@comments>0);
|
||||
return 1;
|
||||
}
|
||||
|
||||
#used for insert
|
||||
sub get_level{
|
||||
my $dbh = shift;
|
||||
my $config = shift;
|
||||
my $comment = shift;
|
||||
|
||||
my $parent_id=$comment->{parent_id};
|
||||
return 0 unless defined $parent_id;
|
||||
if($parent_id=~/(\d+)/){
|
||||
$parent_id=$1;
|
||||
}
|
||||
return 0 unless $parent_id=~/^\d+$/;
|
||||
return 0 if $parent_id==0;
|
||||
|
||||
#get level from parent node
|
||||
my $query=qq{
|
||||
select level
|
||||
from calcms_comments
|
||||
where (
|
||||
event_start=?
|
||||
or event_id=?
|
||||
)
|
||||
and id=?
|
||||
limit 1
|
||||
};
|
||||
my $bind_values=[
|
||||
$comment->{event_start},
|
||||
$comment->{event_id},
|
||||
$parent_id
|
||||
];
|
||||
|
||||
my $comments=db::get($dbh,$query,$bind_values);
|
||||
|
||||
my @comments=@$comments;
|
||||
if (@comments>0){
|
||||
return $comments->[0]->{level}+1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub get_by_event{
|
||||
my $dbh = shift;
|
||||
my $config = shift;
|
||||
my $request =$_[0];
|
||||
|
||||
my $params = $request->{params}->{checked}->{comment};
|
||||
|
||||
my $event_id = undef;
|
||||
my $search = undef;
|
||||
my $where = '';
|
||||
my $limit = '';
|
||||
my $bind_values=[];
|
||||
|
||||
if ($params->{event_id}ne''){
|
||||
$where =qq{ event_id=? };
|
||||
$bind_values=[$params->{event_id}];
|
||||
}
|
||||
|
||||
if ((defined $params->{search}) && ($params->{search}ne'')){
|
||||
$search ='%'.$params->{search}.'%';
|
||||
$where =qq{ (content like ?) or (email like ?) or (author like ?) or (ip like ?)};
|
||||
$bind_values=[
|
||||
$search,
|
||||
$search,
|
||||
$search,
|
||||
$search
|
||||
];
|
||||
}
|
||||
|
||||
my $sort_order=$params->{sort_order} || 'desc';
|
||||
|
||||
if ((defined $params->{limit}) && ($params->{limit} ne'')){
|
||||
$limit ='limit ?';
|
||||
push @$bind_values,$params->{limit};
|
||||
}
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_comments
|
||||
where $where
|
||||
order by created_at $sort_order
|
||||
$limit
|
||||
};
|
||||
|
||||
#print STDERR $query."\n";
|
||||
my $comments=db::get($dbh, $query, $bind_values);
|
||||
|
||||
return $comments;
|
||||
}
|
||||
|
||||
sub get_by_time{
|
||||
my $dbh = shift;
|
||||
my $config = shift;
|
||||
my $comment = shift;
|
||||
|
||||
my $where='';
|
||||
my $bind_values=[];
|
||||
if ($comment->{age} ne ''){
|
||||
$where=qq{
|
||||
where event_id in (
|
||||
select distinct event_id
|
||||
from calcms_comments
|
||||
where (
|
||||
unix_timestamp(now()) - ? < unix_timestamp(created_at)
|
||||
)
|
||||
)
|
||||
};
|
||||
$bind_values=[
|
||||
$comment->{age}*3600,
|
||||
];
|
||||
}elsif (($comment->{from} ne '') && ($comment->{till} ne '')){
|
||||
$where=qq{
|
||||
where event_id in (
|
||||
select distinct event_id
|
||||
from calcms_comments
|
||||
where created_at >= ?
|
||||
and created_at <= ?
|
||||
)
|
||||
};
|
||||
$bind_values=[
|
||||
$comment->{from},
|
||||
$comment->{till}
|
||||
];
|
||||
}
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_comments
|
||||
$where
|
||||
order by event_id, id
|
||||
};
|
||||
my $comments=db::get($dbh, $query, $bind_values);
|
||||
return $comments;
|
||||
}
|
||||
|
||||
sub get_events{
|
||||
my $dbh=shift;
|
||||
my $config = shift;
|
||||
my $request=shift;
|
||||
my $comments=shift;
|
||||
|
||||
my $params=$request->{params}->{checked}->{comment};
|
||||
|
||||
#get event_ids from comments
|
||||
my $event_ids={};
|
||||
for my $comment (@$comments){
|
||||
my $event_id=$comment->{event_id};
|
||||
$event_ids->{$event_id}=1;
|
||||
}
|
||||
|
||||
#get events from comment's event ids
|
||||
return [] if ((keys %{$event_ids})==0);
|
||||
|
||||
#my $quoted_event_ids=join "," ,(map {$dbh->quote($_)}(keys %{$event_ids}));
|
||||
my @bind_values=keys %{$event_ids};
|
||||
my $event_id_values=join "," ,(map {'?'}(keys %{$event_ids}));
|
||||
|
||||
my $query=qq{
|
||||
select id, start, program, series_name, title, excerpt
|
||||
from calcms_events
|
||||
where id in ($event_id_values)
|
||||
};
|
||||
|
||||
my $events=db::get($dbh, $query, \@bind_values);
|
||||
|
||||
#build lookup table for events by id
|
||||
my $events_by_id={};
|
||||
for my $event (@$events){
|
||||
$events_by_id->{$event->{id}}=$event;
|
||||
$event->{max_comment_id}=0;
|
||||
}
|
||||
|
||||
#add unassigned events
|
||||
# for my $event_id (keys %{$event_ids}){
|
||||
# if ($events_by_id->{$event_id}eq''){
|
||||
# my $event={
|
||||
# title => "not assigned",
|
||||
# max_comment_id => 0
|
||||
#
|
||||
# };
|
||||
# push @$events,$event;
|
||||
# $events_by_id->{$event_id}=$event;
|
||||
# }
|
||||
# }
|
||||
|
||||
for my $comment (@$comments){
|
||||
my $event_id=$comment->{event_id};
|
||||
my $event=$events_by_id->{$event_id};
|
||||
next unless (defined $event);
|
||||
$event->{comment_count}++;
|
||||
push @{$event->{comments}},$comment;# if ($params->{event_id}ne'');
|
||||
$event->{max_comment_id}=$comment->{id} if ($comment->{id} > $event->{max_comment_id});
|
||||
for my $name (keys %{$config->{controllers}}){
|
||||
$comment->{"controller_".$name}=$config->{controllers}->{$name}||'';
|
||||
# $event->{"controller_$name"}=$config->{controllers}->{$name};
|
||||
}
|
||||
}
|
||||
my @sorted_events=reverse sort {$a->{max_comment_id} <=> $b->{max_comment_id}} @$events;
|
||||
return \@sorted_events;
|
||||
}
|
||||
|
||||
sub insert{
|
||||
my $dbh = shift;
|
||||
my $config = shift;
|
||||
my $comment = shift;
|
||||
|
||||
$comment->{level}=comments::get_level($dbh, $config, $comment);
|
||||
|
||||
my $entry={
|
||||
event_start => $comment->{event_start},
|
||||
event_id => $comment->{event_id},
|
||||
parent_id => $comment->{parent_id},
|
||||
level => $comment->{level},
|
||||
title => $comment->{title},
|
||||
content => $comment->{content},
|
||||
author => $comment->{author},
|
||||
email => $comment->{email},
|
||||
ip => $comment->{ip}
|
||||
};
|
||||
|
||||
my $comment_id=db::insert($dbh, 'calcms_comments', $entry);
|
||||
return $comment_id;
|
||||
}
|
||||
|
||||
sub set_lock_status{
|
||||
my $dbh=shift;
|
||||
my $config = shift;
|
||||
my $comment=shift;
|
||||
|
||||
my $id = $comment->{id};
|
||||
my $lock_status = $comment->{set_lock_status};
|
||||
my $query=qq{
|
||||
update calcms_comments
|
||||
set lock_status = ?
|
||||
where id = ?
|
||||
};
|
||||
my $bind_values=[
|
||||
$lock_status,
|
||||
$id
|
||||
];
|
||||
db::put($dbh,$query,$bind_values);
|
||||
|
||||
$query=qq{
|
||||
select event_id
|
||||
from calcms_comments
|
||||
where id=?
|
||||
};
|
||||
$bind_values=[$id];
|
||||
my $comments=db::get($dbh,$query,$bind_values);
|
||||
if (@$comments>0){
|
||||
$comment->{event_id}=$comments->[0]->{event_id};
|
||||
update_comment_count($dbh,$comment);
|
||||
}
|
||||
}
|
||||
|
||||
sub set_news_status{
|
||||
my $dbh=shift;
|
||||
my $config = shift;
|
||||
my $comment=shift;
|
||||
|
||||
my $id = $comment->{id};
|
||||
my $news_status = $comment->{set_news_status};
|
||||
my $query=qq{
|
||||
update calcms_comments
|
||||
set news_status= ?
|
||||
where id = ?
|
||||
};
|
||||
my $bind_values=[$news_status,$id];
|
||||
db::put($dbh,$query,$bind_values);
|
||||
}
|
||||
|
||||
sub update_comment_count{
|
||||
my $dbh=shift;
|
||||
my $config = shift;
|
||||
my $comment=shift;
|
||||
|
||||
my $query=qq{
|
||||
select count(id) count
|
||||
from calcms_comments
|
||||
where lock_status='show'
|
||||
and event_id=?
|
||||
};
|
||||
my $bind_values=[$comment->{event_id}];
|
||||
my $comments=db::get($dbh,$query,$bind_values);
|
||||
|
||||
my $count=0;
|
||||
$count=$comments->[0]->{count} if (@$comments>0);
|
||||
$query=qq{
|
||||
update calcms_events
|
||||
set comment_count=?
|
||||
where id=?
|
||||
};
|
||||
$bind_values=[
|
||||
$count,
|
||||
$comment->{event_id}
|
||||
];
|
||||
db::put($dbh,$query,$bind_values);
|
||||
}
|
||||
|
||||
#precondition: results are presorted by creation date (by sql)
|
||||
sub sort{
|
||||
my $config = shift;
|
||||
my $results=shift;
|
||||
|
||||
#define parent nodes
|
||||
my $nodes={};
|
||||
for my $node (@$results){
|
||||
$nodes->{$node->{id}}=$node;
|
||||
}
|
||||
my @root_nodes=();
|
||||
for my $node (@$results){
|
||||
#fill childs into parent nodes
|
||||
push @{$nodes->{$node->{parent_id}}->{childs}},$node;
|
||||
#define root nodes
|
||||
push @root_nodes,$node if ($node->{level}==0);
|
||||
}
|
||||
#print STDERR Dumper(\@root_nodes);
|
||||
|
||||
#sort root nodes from newest to oldest
|
||||
my $sorted_nodes=[];
|
||||
for my $node (@root_nodes){
|
||||
#for my $node (reverse @root_nodes){
|
||||
sort_childs($node,$nodes,$sorted_nodes);
|
||||
}
|
||||
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 $date_pattern = $cache::date_pattern;
|
||||
my $datetime_pattern = $cache::datetime_pattern;
|
||||
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='.$datetime_pattern ,$controllers->{comments}.'/$1_$2-$3-$4_$5-$6.html');
|
||||
}
|
||||
|
||||
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)?/) ){
|
||||
$comment->{event_start}=$1;
|
||||
}
|
||||
|
||||
$comment->{sort_order}='desc';
|
||||
$comment->{limit}='';
|
||||
if ( (defined $params->{limit}) && ($params->{limit}=~/(\d+)/) ){
|
||||
$comment->{limit}=$1;
|
||||
}
|
||||
|
||||
$comment->{show_max}='';
|
||||
if ( (defined $params->{show_max}) && ($params->{show_max}=~/(\d+)/) ){
|
||||
$comment->{show_max}=$1;
|
||||
}
|
||||
|
||||
if ( (defined $params->{sort_order}) && ($params->{sort_order}eq'asc') ){
|
||||
$comment->{sort_order}='asc';
|
||||
}
|
||||
|
||||
$comment->{event_id}='';
|
||||
if ( (defined $params->{event_id}) && ($params->{event_id}=~/(\d+)/) ){
|
||||
$comment->{event_id}=$1;
|
||||
}
|
||||
|
||||
if ( (defined $params->{parent_id}) && ($params->{parent_id}=~/(\d+)/) ){
|
||||
$comment->{parent_id}=$1;
|
||||
}
|
||||
|
||||
if ((defined $params->{type}) && ($params->{type} eq 'list')){
|
||||
$comment->{type}='list';
|
||||
}else{
|
||||
$comment->{type}='tree';
|
||||
}
|
||||
|
||||
my $debug=$params->{debug}||'';
|
||||
if ($debug=~/([a-z\_\,]+)/){
|
||||
$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'') );
|
||||
|
||||
my $delta_days=1;
|
||||
if ($comment->{event_start}ne''){
|
||||
my $today = time::datetime_to_array(time::time_to_datetime());
|
||||
my $date = time::datetime_to_array($comment->{event_start});
|
||||
$delta_days = time::days_between($today,$date);
|
||||
}
|
||||
if(
|
||||
($delta_days > $config->{permissions}->{no_new_comments_before} )
|
||||
|| ($delta_days < -1*$config->{permissions}->{no_new_comments_after} )
|
||||
){
|
||||
$comment->{allow}->{new_comments}=0;
|
||||
}else{
|
||||
$comment->{allow}->{new_comments}=1;
|
||||
}
|
||||
|
||||
$comment->{template}=template::check($params->{template},'comments.html');
|
||||
|
||||
return $comment;
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
33
lib/calcms/config.pm
Normal file
33
lib/calcms/config.pm
Normal file
@@ -0,0 +1,33 @@
|
||||
package config;
|
||||
|
||||
require Exporter;
|
||||
my @ISA = qw(Exporter);
|
||||
my @EXPORT_OK = qw(get $config);
|
||||
my %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
use Config::General;
|
||||
|
||||
our $modified_at=-999;
|
||||
our $config= undef;
|
||||
|
||||
sub get{
|
||||
my $filename=shift;
|
||||
|
||||
#return config if known
|
||||
#my $age=(-M $filename);
|
||||
#return $config::config if ((defined $config::config) && ($age <= $config::modified_at));
|
||||
|
||||
#reload config if changed
|
||||
my $configuration = new Config::General(
|
||||
-ConfigFile=>$filename,
|
||||
-UTF8=>1
|
||||
);
|
||||
$config::config=$configuration->{DefaultConfig}->{config};
|
||||
$config::modified_at=$age;
|
||||
#print STDERR "reload $filename\n";
|
||||
|
||||
return $config::config;
|
||||
}
|
||||
|
||||
#do not delete last line
|
||||
1;
|
||||
261
lib/calcms/creole_wiki.pm
Normal file
261
lib/calcms/creole_wiki.pm
Normal file
@@ -0,0 +1,261 @@
|
||||
use warnings;
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use markup;
|
||||
|
||||
package creole_wiki;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(extractEventFromWikiText removeMeta eventToWikiText extractMeta removeMeta metaToWiki);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
#convert creole wiki text to event
|
||||
sub extractEventFromWikiText{
|
||||
my $params=shift;
|
||||
my $event=shift;
|
||||
$event={} unless (defined $event);
|
||||
|
||||
my $title =$params->{title}||'';
|
||||
my $content =$params->{content}||'';
|
||||
my $local_media_url =$params->{local_media_url}||'';
|
||||
|
||||
#split content into excerpt, content and comments
|
||||
$content=~s/\s*\,\s*/, /g;
|
||||
my @lines=split(/\s*\-{10,99}\s*/,$content);
|
||||
my $lines=\@lines;
|
||||
for my $line (@$lines){
|
||||
$line=~s/^\s+|\s+$//g;
|
||||
}
|
||||
if (@lines==1){
|
||||
$event->{content}=shift @lines;
|
||||
}elsif(@lines==2){
|
||||
$event->{excerpt}=shift @lines;
|
||||
$event->{content}=shift @lines;
|
||||
}else{
|
||||
$event->{excerpt}=shift @lines;
|
||||
$event->{content}=shift @lines;
|
||||
$event->{comments}=join("--------------------\n",@lines);
|
||||
}
|
||||
if (defined $event->{excerpt}){
|
||||
$event->{excerpt}=markup::html_to_plain($event->{excerpt});
|
||||
}
|
||||
#extract program from title
|
||||
$event->{program}='';
|
||||
|
||||
if ($title=~/^(.*?)\:/){
|
||||
my $program=$1;
|
||||
unless ($program=~/\s\-\s/){
|
||||
$event->{program}=$program;
|
||||
$event->{program}=~s/^\s+|\s+$//g;
|
||||
$event->{program}=~s/\s+/ /g;
|
||||
$title=~s/^.*?\:\s+//gi;
|
||||
}
|
||||
}
|
||||
|
||||
#extract series_name from title
|
||||
$event->{series_name}='';
|
||||
if ($title=~/^(.*?)\s+\-\s+/){
|
||||
$event->{series_name}=$1;
|
||||
$event->{series_name}=~s/^\s+|\s+$//g;
|
||||
$event->{series_name}=~s/\s+/ /g;
|
||||
$title=~s/^(.*?)\s+\-\s+//gi;
|
||||
}
|
||||
|
||||
#extract categories from title
|
||||
my @categories=();
|
||||
while ($title=~/\((.*?),(.*?)\)/){
|
||||
my $category=$1;
|
||||
$category =~s/\s+/ /g;
|
||||
$category =~s/^\s+|\s+$//g;
|
||||
$category =~s/\&/\+/g;
|
||||
push @categories,$category if (defined $category && $category=~/\S/);
|
||||
|
||||
$category='';
|
||||
$category=$2 if (defined $2);
|
||||
$category =~s/\s+/ /g;
|
||||
$category =~s/^\s+|\s+$//g;
|
||||
$category =~s/\&/\+/g;
|
||||
push @categories,$category if (defined $category && $category=~/\S/);
|
||||
$title=~s/\((.*?),(.*?)\)/\($2\)/;
|
||||
}
|
||||
if ($title=~/\((.*?)\)/){
|
||||
my $category=$1;
|
||||
$category =~s/\s+/ /g;
|
||||
$category =~s/^\s+|\s+$//g;
|
||||
$category =~s/\&/\+/g;
|
||||
|
||||
# print $category."\n";
|
||||
push @categories,$category if (defined $category && $category=~/\S/);
|
||||
$title=~s/\((.*?)\)//;
|
||||
}
|
||||
$event->{categories} = \@categories if (@categories>0);
|
||||
$event->{title} = $title;
|
||||
$event->{title} =~s/^\s+|\s+$//g;
|
||||
|
||||
if (defined $event->{content}){
|
||||
#extract podcast_url from content link 'podcast'
|
||||
my $podcast_url='';
|
||||
if ($event->{content}=~/\[\[\s*([^\|\]]+)\s*\|\s*podcast\s*\]\]/i){
|
||||
$podcast_url=$1;
|
||||
# $podcast_url=~s/\|.*//g;
|
||||
# print "found podcast:".$podcast_url."\n";
|
||||
}
|
||||
$event->{podcast_url} = $podcast_url;
|
||||
|
||||
#extract media_url from content link 'download'
|
||||
my $media_url='';
|
||||
if ($event->{content}=~/\[\[\s*([^\|\]]+)\s*\|\s*(direct\s+)?download\s*\]\]/i){
|
||||
$media_url=$1;
|
||||
# $podcast_url=~s/\|.*//g;
|
||||
# print "found media:".$media_url."\n";
|
||||
}
|
||||
$event->{media_url} = $media_url;
|
||||
|
||||
#replace "thumbs/xxx" link by link to local media URI
|
||||
$event->{content}=~s/\{\{\s*thumbs\/+(.*?)\s*\|\s*(.*?)\s*\}\}/\[\[$local_media_url\/images\/$1\|\{\{$local_media_url\/thumbs\/$1\|$2\}\}\]\]/g;
|
||||
|
||||
#extract image from content
|
||||
if ($event->{content}=~/\{\{(.*?)(\||\}\})/){
|
||||
$event->{image}=$1;
|
||||
}
|
||||
}
|
||||
|
||||
#meta
|
||||
if (defined $event->{comments}){
|
||||
my $meta=extractMeta($event->{comments});
|
||||
$event->{meta} = $meta if (@$meta>0);
|
||||
}
|
||||
|
||||
return $event;
|
||||
}
|
||||
|
||||
sub eventToWikiText{
|
||||
my $event=shift;
|
||||
my $local_media_url =$event->{local_media_url}||'';
|
||||
|
||||
$event->{program} =~s/^\s+|\s+$//g;
|
||||
$event->{series_name} =~s/^\s+|\s+$//g;
|
||||
$event->{title} =~s/^\s+|\s+$//g;
|
||||
$event->{excerpt} =~s/^\s+|\s+$//g;
|
||||
$event->{content} =~s/^\s+|\s+$//g;
|
||||
$event->{comments} =~s/^\s+|\s+$//g;
|
||||
|
||||
my $title='';
|
||||
if($event->{program} ne''){
|
||||
$title=$event->{program};
|
||||
$title.=': ' if (($event->{series_name} ne'') || ($event->{title} ne''));
|
||||
}
|
||||
if($event->{series_name} ne''){
|
||||
$title.=$event->{series_name};
|
||||
$title.=' - ' if ($event->{title} ne'');
|
||||
}
|
||||
$title.=$event->{title};
|
||||
if ($event->{categories}){
|
||||
$title.=' ('.join(",", @{$event->{categories}} ).')' if (@{$event->{categories}}>0);
|
||||
}
|
||||
|
||||
my $meta=extractMeta($event->{comments}, $event->{meta});
|
||||
#use Data::Dumper;print "extracted meta".Dumper($meta);
|
||||
|
||||
$event->{comments}=removeMeta($event->{comments});
|
||||
$event->{wiki_comments}=$event->{comments}."\n\n".metaToWiki($meta);
|
||||
#use Data::Dumper;print "event content".Dumper($event->{content});
|
||||
|
||||
#rich content editors:
|
||||
#$event->{wiki_content}=markup::html_to_creole($event->{content});
|
||||
|
||||
#markup editors
|
||||
$event->{wiki_content}=$event->{content};
|
||||
|
||||
|
||||
# [[http://localhost/agenda_files/media/images/Vl8X7YmaWrmm9RMN_OMywA.jpg|{{http://localhost/agenda_files/media/thumbs/Vl8X7YmaWrmm9RMN_OMywA.jpg|}}]]
|
||||
#replace "thumbs/xxx" link by link to local media URI
|
||||
# while ($event->{wiki_content}=~/\[\[.*?\/+media\/+images\/+(.*?)\s*\|.*?\{\{.*?\/+media\/+thumbs\/+(.*?)\s*\|\s*(.*?)\s*\}\}\]\]/){
|
||||
$event->{wiki_content}=~s/\[\[.*?\/+media\/+images\/+(.*?)\s*\|.*?\{\{.*?\/+media\/+thumbs\/+(.*?)\s*\|\s*(.*?)\s*\}\}\]\]/\{\{thumbs\/$1\|$3\}\}/g;
|
||||
# }
|
||||
|
||||
my $wiki_content=join("\n".("-"x20)."\n",($event->{excerpt}, $event->{wiki_content}) );
|
||||
$wiki_content.="\n".("-"x20)."\n".$event->{wiki_comments} if ($event->{wiki_comments}=~/\S/);
|
||||
|
||||
return {
|
||||
title => $title,
|
||||
content => $event->{content},
|
||||
wiki_content => $wiki_content
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
#extrace meta tags from comment text
|
||||
sub extractMeta{
|
||||
my $comments =shift;
|
||||
my $meta =shift;
|
||||
|
||||
$meta=[] unless (defined $meta);
|
||||
|
||||
#push meta tags into meta list
|
||||
if (defined $comments){
|
||||
#build index for meta already defined
|
||||
my $meta_keys={};
|
||||
for my $pair (@$meta){
|
||||
$meta_keys->{$pair->{name}.'='.$pair->{value}}=1;
|
||||
}
|
||||
|
||||
while ($comments=~/\~\~META\:(.+?)\=(.+?)\~\~/g){
|
||||
my $name=$1;
|
||||
my $value=$2;
|
||||
|
||||
#fix meta values
|
||||
$name=lc($name);
|
||||
$name=~s/^\s+|\s+$//g;
|
||||
$value=~s/^\s+|\s+$//g;
|
||||
|
||||
#insert into list, if not defined yet
|
||||
unless( ($name eq'') || ($value eq'') || (exists $meta_keys->{$name.'='.$value}) ){
|
||||
push @$meta,{
|
||||
name=>$name,
|
||||
value=>$value,
|
||||
};
|
||||
$meta_keys->{$name.'='.$value}=1;
|
||||
}
|
||||
};
|
||||
}
|
||||
# use Data::Dumper;print Dumper($meta);
|
||||
return $meta;
|
||||
}
|
||||
|
||||
#remove meta tags from comment text
|
||||
sub removeMeta{
|
||||
my $comments=shift||'';
|
||||
|
||||
my $result='';
|
||||
for my $line (split(/\n/,$comments)){
|
||||
$result.=$line unless ($line=~/\~\~META\:(.+?)\=(.+?)\~\~/g);
|
||||
}
|
||||
#use Data::Dumper;print "removed metsas:".Dumper($result);
|
||||
$result=~s/^\s+//g;
|
||||
$result=~s/\s+$//g;
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
#add meta tags to comment text
|
||||
sub metaToWiki{
|
||||
my $meta =shift;
|
||||
|
||||
my $result='';
|
||||
for my $pair (@$meta){
|
||||
# use Data::Dumper;print Dumper($pair);
|
||||
$result.='~~META:'.$pair->{name}.'='.$pair->{value}.'~~'."\n";
|
||||
}
|
||||
return $result;
|
||||
#use Data::Dumper;print Dumper($meta);
|
||||
|
||||
}
|
||||
|
||||
|
||||
#test:
|
||||
#perl -e 'use creole_wiki;$a=creole_wiki::extractEventFromWikiText("teaser\n----------------------\nbody[[asd|download]][[bsd|hallo]][[csd|podcast]]{{a|b}}[[dsd|wer]]\n----------------------\ncomments",{title=>" a : b - c ( d e - f , g h i - j, k - m - l) "});use Data::Dumper;print Dumper($a)';
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
278
lib/calcms/db.pm
Normal file
278
lib/calcms/db.pm
Normal file
@@ -0,0 +1,278 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
#use DBI;
|
||||
#use Apache::DBI;
|
||||
use DBD::mysql;
|
||||
|
||||
package db;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
connect disconnect
|
||||
get insert put
|
||||
next_id get_max_id
|
||||
shift_date_by_hours shift_datetime_by_minutes
|
||||
get_columns get_columns_hash
|
||||
$write
|
||||
$read
|
||||
);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
#debug settings
|
||||
our $debug_read=0;
|
||||
our $debug_write=0;
|
||||
|
||||
#database control
|
||||
our $read=1;
|
||||
our $write=1;
|
||||
|
||||
# connect to database
|
||||
sub connect{
|
||||
my $options=shift;
|
||||
my $request=shift;
|
||||
|
||||
return $request->{connection} if ((defined $request) && (defined $request->{connection}));
|
||||
|
||||
my $access_options=$options->{access};
|
||||
|
||||
my $hostname =$access_options->{hostname};
|
||||
my $port =$access_options->{port};
|
||||
my $database =$access_options->{database};
|
||||
my $username =$access_options->{username};
|
||||
my $password =$access_options->{password};
|
||||
|
||||
if ((defined $access_options->{write}) && ($access_options->{write}eq'1')){
|
||||
$username =$access_options->{username_write};
|
||||
$password =$access_options->{password_write};
|
||||
}
|
||||
|
||||
my $dbh=undef;
|
||||
my $dsn = "DBI:mysql:database=$database;host=$hostname;port=$port";
|
||||
# if ($db::utf8dbi eq '1'){
|
||||
# use UTF8DBI;
|
||||
# $dbh = UTF8DBI->connect( $dsn,$username,$password) || die "Database connection not made: $DBI::errstr"; # \nfor $dsn, $username
|
||||
# }else{
|
||||
# use DBI;
|
||||
$dbh = DBI->connect( $dsn,$username,$password,{mysql_enable_utf8 => 1}) || die "could not connect to database: $DBI::errstr"; # \nfor $dsn, $username
|
||||
# }
|
||||
#print STDERR "db connect $username\n" if ($debug_read==1);
|
||||
#print STDERR "db connect $username\n";
|
||||
$dbh->{RaiseError} = 1;
|
||||
|
||||
$dbh->{'mysql_enable_utf8'} = 1;
|
||||
put($dbh,"set character set utf8");
|
||||
put($dbh,"set names utf8");
|
||||
put($dbh,"set time_zone='".$options->{date}->{time_zone}."'");
|
||||
|
||||
$request->{connection}=$dbh;
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub disconnect{
|
||||
my $request=shift;
|
||||
my $dbh=$request->{connection};
|
||||
$dbh->disconnect;
|
||||
delete $request->{connection};
|
||||
}
|
||||
|
||||
# get all database entries of an sql query (as list of hashs)
|
||||
sub get{
|
||||
my $dbh=shift;
|
||||
my $sql=shift;
|
||||
my $bind_values=shift;
|
||||
|
||||
if ($debug_read==1){
|
||||
print STDERR $sql."\n";
|
||||
print STDERR Dumper($bind_values)."\n" if defined $bind_values;
|
||||
}
|
||||
|
||||
my $sth = $dbh->prepare( $sql );
|
||||
if ((defined $bind_values)&&(ref($bind_values)eq'ARRAY')){
|
||||
# print STDERR Dumper($bind_values)."\n";
|
||||
my $result = $sth->execute(@$bind_values);
|
||||
unless ($result){
|
||||
print STDERR $sql."\n";
|
||||
die "db: $DBI::errstr $sql" if ($read==1);
|
||||
}
|
||||
}else{
|
||||
$sth->execute() || die "db: $DBI::errstr $sql" if ($read==1);
|
||||
}
|
||||
|
||||
my @results=();
|
||||
while ( my $row=$sth->fetchrow_hashref){
|
||||
my $result={};
|
||||
foreach my $key (keys %$row){
|
||||
$result->{$key}=$row->{$key};
|
||||
}
|
||||
push @results, $result;
|
||||
}
|
||||
|
||||
if ($debug_read==1){
|
||||
print STDERR Dumper($results[0])."\n" if (@results==1);
|
||||
print STDERR @results."\n" if (@results!=1);
|
||||
}
|
||||
|
||||
$sth->finish;
|
||||
return \@results;
|
||||
}
|
||||
|
||||
# get list of table columns
|
||||
sub get_columns{
|
||||
my $dbh=shift;
|
||||
my $table=shift;
|
||||
|
||||
my $columns=db::get($dbh, 'select column_name from information_schema.columns where table_name=?',[$table]);
|
||||
my @result=map {$_->{column_name}} (@$columns);
|
||||
return \@result;
|
||||
}
|
||||
|
||||
# get hash with table columns as keys
|
||||
sub get_columns_hash{
|
||||
my $dbh=shift;
|
||||
my $table=shift;
|
||||
|
||||
my $columns=db::get_columns($dbh, $table);
|
||||
my $result={};
|
||||
for my $column (@$columns){
|
||||
$result->{$column}=1;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
||||
# insert an entry into database (select from where)
|
||||
sub insert_old{
|
||||
my $dbh=shift;
|
||||
my $tablename=shift;
|
||||
my $entry=shift;
|
||||
my $do_not_quote=shift;
|
||||
|
||||
my $keys =join(",", map {$_} (keys %$entry));
|
||||
my $values =undef;
|
||||
if (defined $do_not_quote && $do_not_quote ne ''){
|
||||
$values =join("\n,", map {$entry->{$_}} (keys %$entry));
|
||||
}else{
|
||||
$values =join("\n,", map {$dbh->quote($entry->{$_})} (keys %$entry));
|
||||
}
|
||||
my $sql ="insert into $tablename \n ($keys) \n values ($values);\n";
|
||||
print STDERR $sql."\n" if ($debug_write==1);
|
||||
put($dbh,$sql);
|
||||
|
||||
}
|
||||
|
||||
#returns last inserted id
|
||||
sub insert{
|
||||
my $dbh=shift;
|
||||
my $tablename=shift;
|
||||
my $entry=shift;
|
||||
# my $do_not_quote=shift;
|
||||
|
||||
my $keys =join(",", map {$_} (keys %$entry));
|
||||
my $values =join(",", map {'?'} (keys %$entry));
|
||||
my @bind_values =map {$entry->{$_}} (keys %$entry);
|
||||
|
||||
my $sql ="insert into $tablename \n ($keys) \n values ($values);\n";
|
||||
|
||||
if ($debug_write==1){
|
||||
print STDERR $sql."\n";
|
||||
print STDERR Dumper(\@bind_values)."\n" if (@bind_values);
|
||||
}
|
||||
|
||||
put($dbh, $sql, \@bind_values);
|
||||
my $result=get($dbh, 'SELECT LAST_INSERT_ID() id;');
|
||||
return $result->[0]->{id} if $result->[0]->{id}>0;
|
||||
return undef;
|
||||
}
|
||||
|
||||
# execute a modifying database command (update,insert,...)
|
||||
sub put{
|
||||
my $dbh=shift;
|
||||
my $sql=shift;
|
||||
my $bind_values=shift;
|
||||
|
||||
if ($debug_write==1){
|
||||
print STDERR $sql."\n";
|
||||
print STDERR Dumper($bind_values)."\n" if defined $bind_values;
|
||||
}
|
||||
|
||||
my $sth = $dbh->prepare( $sql );
|
||||
if ($write==1){
|
||||
if ((defined $bind_values)&&(ref($bind_values)eq'ARRAY')){
|
||||
$sth->execute(@$bind_values);
|
||||
}else{
|
||||
$sth->execute();
|
||||
}
|
||||
};
|
||||
$sth->finish;
|
||||
print STDERR "1\n" if ($debug_write==1);
|
||||
|
||||
my $result=get($dbh, 'SELECT ROW_COUNT() changes;');
|
||||
return $result->[0]->{changes} if $result->[0]->{changes}>0;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub quote{
|
||||
my $dbh=shift;
|
||||
my $sql=shift;
|
||||
|
||||
$sql=~s/\_/\\\_/g;
|
||||
return $dbh->quote($sql);
|
||||
}
|
||||
|
||||
#subtract hours, deprecated(!)
|
||||
sub shift_date_by_hours{
|
||||
my $dbh=shift;
|
||||
my $date=shift;
|
||||
my $offset=shift;
|
||||
|
||||
my $query='select date(? - INTERVAL ? HOUR) date';
|
||||
my $bind_values=[$date,$offset];
|
||||
my $results=db::get($dbh, $query, $bind_values);
|
||||
return $results->[0]->{date};
|
||||
}
|
||||
|
||||
#add minutes, deprecated(!)
|
||||
sub shift_datetime_by_minutes{
|
||||
my $dbh=shift;
|
||||
my $datetime=shift;
|
||||
my $offset=shift;
|
||||
|
||||
my $query="select ? + INTERVAL ? MINUTE date";
|
||||
my $bind_values=[$datetime,$offset];
|
||||
my $results=db::get($dbh, $query, $bind_values);
|
||||
return $results->[0]->{date};
|
||||
}
|
||||
|
||||
# get next free id of a database table
|
||||
sub next_id{
|
||||
my $dbh=shift;
|
||||
my $table=shift;
|
||||
|
||||
my $query=qq{
|
||||
select max(id) id
|
||||
from $table
|
||||
where 1
|
||||
};
|
||||
my $results=get($dbh,$query);
|
||||
return $results->[0]->{id}+1;
|
||||
}
|
||||
|
||||
# get max id from table
|
||||
sub get_max_id{
|
||||
my $dbh=shift;
|
||||
my $table=shift;
|
||||
|
||||
my $query=qq{
|
||||
select max(id) id
|
||||
from $table
|
||||
where 1
|
||||
};
|
||||
my $results=get($dbh,$query);
|
||||
return $results->[0]->{id};
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
134
lib/calcms/eventOps.pm
Normal file
134
lib/calcms/eventOps.pm
Normal file
@@ -0,0 +1,134 @@
|
||||
package eventOps;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
use series;
|
||||
use series_dates;
|
||||
use time;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
setAttributesFromSeriesTemplate
|
||||
setAttributesFromSchedule
|
||||
setAttributesFromOtherEvent
|
||||
setAttributesForCurrentTime
|
||||
getRecurrenceBaseId
|
||||
);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
# functions: to be separated
|
||||
sub setAttributesFromSeriesTemplate{
|
||||
my $config=shift;
|
||||
my $params=shift;
|
||||
my $event=shift;
|
||||
|
||||
#get attributes from series
|
||||
my $series=series::get(
|
||||
$config,{
|
||||
project_id => $params->{project_id},
|
||||
studio_id => $params->{studio_id},
|
||||
series_id => $params->{series_id},
|
||||
}
|
||||
);
|
||||
if(@$series!=1){
|
||||
uac::print_error("series not found");
|
||||
return undef;
|
||||
}
|
||||
|
||||
#copy fields from series template
|
||||
my $serie=$series->[0];
|
||||
for my $attr(
|
||||
'program','series_name','title',
|
||||
'excerpt', 'topic', 'content', 'html_content',
|
||||
'project','category','location','image', 'live',
|
||||
'archive_url', 'podcast_url'
|
||||
){
|
||||
$event->{$attr}=$serie->{$attr};
|
||||
}
|
||||
return $serie;
|
||||
}
|
||||
|
||||
sub setAttributesFromSchedule{
|
||||
my $config=shift;
|
||||
my $params=shift;
|
||||
my $event=shift;
|
||||
|
||||
#set attributes from schedule
|
||||
my $schedules=series_dates::get(
|
||||
$config, {
|
||||
project_id => $params->{project_id},
|
||||
studio_id => $params->{studio_id},
|
||||
series_id => $params->{series_id},
|
||||
start_at => $params->{start_date}
|
||||
}
|
||||
);
|
||||
|
||||
if(@$schedules!=1){
|
||||
uac::print_error("schedule not found");
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $schedule=$schedules->[0];
|
||||
for my $attr(
|
||||
'start','end',
|
||||
'day', 'weekday',
|
||||
'start_date', 'end_date'
|
||||
){
|
||||
$event->{$attr}=$schedule->{$attr};
|
||||
}
|
||||
|
||||
my $timezone=$config->{date}->{time_zone};
|
||||
$event->{duration} = time::get_duration($event->{start}, $event->{end}, $timezone);
|
||||
|
||||
return $event;
|
||||
}
|
||||
|
||||
sub setAttributesFromOtherEvent{
|
||||
my $config=shift;
|
||||
my $params=shift;
|
||||
my $event=shift;
|
||||
|
||||
my $event2=series::get_event($config, {
|
||||
allow_any => 1,
|
||||
#project_id => $params->{project_id},
|
||||
#studio_id => $params->{studio_id},
|
||||
#series_id => $params->{series_id},
|
||||
event_id => $params->{source_event_id}
|
||||
});
|
||||
if (defined $event2){
|
||||
for my $attr ('title', 'user_title', 'excerpt', 'user_excerpt', 'content', 'html_content', 'topics', 'image', 'live', 'no_event_sync', 'podcast_url', 'archive_url'){
|
||||
$event->{$attr}=$event2->{$attr};
|
||||
}
|
||||
$event->{rerun}=1;
|
||||
$event->{recurrence}=getRecurrenceBaseId($event2);
|
||||
}
|
||||
|
||||
return $event;
|
||||
}
|
||||
|
||||
sub setAttributesForCurrentTime{
|
||||
my $serie=shift;
|
||||
my $event=shift;
|
||||
|
||||
#on new event not from schedule use current time
|
||||
if($event->{start}eq''){
|
||||
$event->{start}=time::time_to_datetime();
|
||||
if ($event->{start}=~/(\d\d\d\d\-\d\d\-\d\d \d\d)/){
|
||||
$event->{start}=$1.':00';
|
||||
}
|
||||
}
|
||||
$event->{duration}=$serie->{duration}||60;
|
||||
$event->{end} =time::add_minutes_to_datetime($event->{start}, $event->{duration});
|
||||
$event->{end}=~s/(\d\d:\d\d)\:\d\d/$1/;
|
||||
|
||||
return $event;
|
||||
}
|
||||
|
||||
# get recurrence base id
|
||||
sub getRecurrenceBaseId{
|
||||
my $event = shift;
|
||||
return $event->{recurrence} if (defined $event->{recurrence}) && ($event->{recurrence} ne '') && ($event->{recurrence} ne '0');
|
||||
return $event->{event_id};
|
||||
}
|
||||
|
||||
176
lib/calcms/event_history.pm
Normal file
176
lib/calcms/event_history.pm
Normal file
@@ -0,0 +1,176 @@
|
||||
#!/bin/perl
|
||||
|
||||
package event_history;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get get_by_id insert insert_by_event_id delete);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_event_history');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $columns;
|
||||
}
|
||||
|
||||
sub get{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
return undef unless defined $condition->{studio_id};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{series_id}) && ($condition->{series_id} ne '')){
|
||||
push @conditions, 'series_id=?';
|
||||
push @bind_values, $condition->{series_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{event_id}) && ($condition->{event_id} ne '')){
|
||||
push @conditions, 'event_id=?';
|
||||
push @bind_values, $condition->{event_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{change_id}) && ($condition->{change_id} ne '')){
|
||||
push @conditions, 'id=?';
|
||||
push @bind_values, $condition->{change_id};
|
||||
}
|
||||
|
||||
my $limit='';
|
||||
if ((defined $condition->{limit}) && ($condition->{limit} ne '')){
|
||||
$limit= 'limit '.$condition->{limit};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_event_history
|
||||
$conditions
|
||||
order by modified_at desc
|
||||
$limit
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
|
||||
my $changes=db::get($dbh, $query, \@bind_values);
|
||||
#print STDERR Dumper($changes);
|
||||
|
||||
for my $change (@$changes){
|
||||
$change->{change_id}=$change->{id};
|
||||
delete $change->{id};
|
||||
}
|
||||
return $changes;
|
||||
}
|
||||
|
||||
sub get_by_id{
|
||||
my $config=shift;
|
||||
my $id=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_event_history
|
||||
where event_id=?
|
||||
};
|
||||
|
||||
my $studios=db::get($dbh,$query,[$id]);
|
||||
return undef if (@$studios!=1);
|
||||
return $studios->[0];
|
||||
}
|
||||
|
||||
sub insert{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
$entry->{event_id}=$entry->{id} if((defined $entry->{id})&&(!(defined $entry->{event_id})));
|
||||
delete $entry->{id};
|
||||
|
||||
#TODO:filter for existing attributes
|
||||
my $columns=get_columns($config);
|
||||
my $event={};
|
||||
for my $column (keys %$columns){
|
||||
$event->{$column}=$entry->{$column} if defined $entry->{$column};
|
||||
}
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $id=db::insert($dbh, 'calcms_event_history', $event);
|
||||
return $id;
|
||||
}
|
||||
|
||||
# insert event
|
||||
sub insert_by_event_id{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
return undef unless defined $options->{project_id};
|
||||
return undef unless defined $options->{studio_id};
|
||||
return undef unless defined $options->{series_id};
|
||||
return undef unless defined $options->{event_id};
|
||||
return undef unless defined $options->{user};
|
||||
|
||||
my $sql=q{
|
||||
select * from calcms_events
|
||||
where id=?
|
||||
};
|
||||
my $bind_values=[$options->{event_id}];
|
||||
my $dbh=db::connect($config);
|
||||
my $results=db::get($dbh, $sql, $bind_values);
|
||||
if(@$results!=1){
|
||||
print STDERR "cannot find event with event_id=$options->{event_id}";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# add to history
|
||||
my $event=$results->[0];
|
||||
$event->{project_id} = $options->{project_id};
|
||||
$event->{studio_id} = $options->{studio_id};
|
||||
$event->{series_id} = $options->{series_id};
|
||||
$event->{event_id} = $options->{event_id};
|
||||
$event->{user} = $options->{user};
|
||||
$event->{deleted} = 1;
|
||||
event_history::insert($config, $event);
|
||||
}
|
||||
|
||||
sub delete{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
db::put($dbh, 'delete from calcms_event_history where event_id=?', [$entry->{id}]);
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
1775
lib/calcms/events.pm
Normal file
1775
lib/calcms/events.pm
Normal file
File diff suppressed because it is too large
Load Diff
297
lib/calcms/images.pm
Normal file
297
lib/calcms/images.pm
Normal file
@@ -0,0 +1,297 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use config;
|
||||
use template;
|
||||
|
||||
package images;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
#our @EXPORT = qw(all);
|
||||
our @EXPORT_OK = qw(get insert update insert_or_update delete delete_files);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
#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'];
|
||||
|
||||
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->{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;
|
||||
}
|
||||
|
||||
my $where='';
|
||||
if (@cond>0){
|
||||
$where = 'where '.join (' and ', @cond);
|
||||
}
|
||||
|
||||
my $limit='';
|
||||
if ( (defined $options->{limit}) && ($options->{limit}=~/(\d+)/) ){
|
||||
$limit=' limit '.$1;
|
||||
}
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_images
|
||||
$where
|
||||
order by created_at desc
|
||||
$limit
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper($bind_values);
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $results=db::get($dbh, $query, $bind_values);
|
||||
|
||||
#print STDERR @$results."\n";
|
||||
return $results;
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
}
|
||||
|
||||
sub insert{
|
||||
my $dbh=shift;
|
||||
my $image=shift;
|
||||
|
||||
my @sql_columns=@$sql_columns;
|
||||
|
||||
#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;
|
||||
}
|
||||
|
||||
my $query=q{
|
||||
insert into calcms_images(
|
||||
}.join(',',@sql_columns).qq{
|
||||
)
|
||||
values( }.join(', ', (map {'?'} @sql_columns)).q{ )
|
||||
};
|
||||
my @bind_values=map { $image->{$_} } @sql_columns;
|
||||
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
return db::put($dbh, $query, \@bind_values);
|
||||
}
|
||||
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
$image->{modified_at}=time::time_to_datetime();
|
||||
|
||||
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};
|
||||
|
||||
push @$conditions, 'project_id=?';
|
||||
push @$bind_values, $image->{project_id}||0;
|
||||
|
||||
push @$conditions, 'studio_id=?';
|
||||
push @$bind_values, $image->{studio_id}||0;
|
||||
|
||||
return if (@set==0);
|
||||
|
||||
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);
|
||||
return db::put($dbh,$query,$bind_values);
|
||||
}
|
||||
|
||||
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->{project_id}){
|
||||
print STDERR "missing project_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 $conditions = ['filename=?'];
|
||||
my $bind_values = [$filename];
|
||||
|
||||
push @$conditions, 'project_id=?';
|
||||
push @$bind_values, $studio_id;
|
||||
|
||||
push @$conditions, 'studio_id=?';
|
||||
push @$bind_values, $project_id;
|
||||
|
||||
$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);
|
||||
}
|
||||
|
||||
# deactivated
|
||||
sub delete_files{
|
||||
my $config = $_[0];
|
||||
my $local_media_dir = $_[1];
|
||||
my $filename = $_[2];
|
||||
my $action_result = $_[3];
|
||||
my $errors = $_[4];
|
||||
|
||||
return undef;
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
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;
|
||||
#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.'/thumbs/'.$filename;
|
||||
delete_file($path,"Thumb $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];
|
||||
|
||||
return undef;
|
||||
|
||||
unless (-e $path){
|
||||
$errors.= qq{Error: File does not exist!<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>};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
110
lib/calcms/localization.pm
Normal file
110
lib/calcms/localization.pm
Normal file
@@ -0,0 +1,110 @@
|
||||
package localization;
|
||||
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use uac;
|
||||
use user_settings;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get getJavascript);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
# get localisation
|
||||
# file : po file
|
||||
# language : get for selected language
|
||||
# user : get from user settings
|
||||
# loc : add to existing localization, optional
|
||||
sub get{
|
||||
my $config =shift;
|
||||
my $options=shift;
|
||||
|
||||
#print STDERR Dumper($options);
|
||||
|
||||
#get pot file
|
||||
unless (defined $options->{file}){
|
||||
print STDERR "missing po file\n";
|
||||
return $options->{loc}||{};
|
||||
}
|
||||
|
||||
my $language=undef;
|
||||
#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';
|
||||
|
||||
my $loc={};
|
||||
$loc=$options->{loc} if defined $options->{loc};
|
||||
|
||||
my $files=$options->{file};
|
||||
$files=~s/[^a-zA-Z\,\_\-]//g;
|
||||
#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 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;
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
my $key='';
|
||||
open my $file, '<:encoding(UTF-8)', $po_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;
|
||||
}
|
||||
}
|
||||
return $loc;
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
1;
|
||||
166
lib/calcms/log.pm
Normal file
166
lib/calcms/log.pm
Normal file
@@ -0,0 +1,166 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use template;
|
||||
use config;
|
||||
|
||||
package log;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
#our @EXPORT = qw(all);
|
||||
our @EXPORT_OK = qw(init write read error mem);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
#our $debug=0;
|
||||
our $debug_params='';
|
||||
our $header="Content-type:text/html\n\n";
|
||||
|
||||
our $gtop = undef;
|
||||
our $proc = undef;
|
||||
|
||||
sub init{
|
||||
my $request =$_[0];
|
||||
$log::debug_params =$request->{params}->{checked}->{debug}||'';
|
||||
$log::header =$request->{header}if (defined $request->{header});
|
||||
|
||||
#if ($config->{system}->{debug_memory}>0){
|
||||
#use GTop();
|
||||
#$log::gtop=GTop->new;
|
||||
#$log::proc=$gtop->proc_mem($$);
|
||||
#}
|
||||
}
|
||||
|
||||
sub write{
|
||||
my $config = shift;
|
||||
my $key = shift;
|
||||
my $data = shift;
|
||||
my $dump = shift;
|
||||
|
||||
return unless(defined $config::config->{system}->{debug});
|
||||
return unless(($config::config->{system}->{debug}>0) &&($log::debug_params=~/$key/));
|
||||
|
||||
my $line=Dumper($data);
|
||||
$line=~s/^\$VAR1 = \{\n/<code>/g;
|
||||
$line=~s/\};\n$/<\/code>/g;
|
||||
$line=~s/\n/\\n/g;
|
||||
my $msg=localtime()." [$key] ".$ENV{REQUEST_URI}."\\n".$line;
|
||||
$msg.=Dumper($dump) if (defined $dump);
|
||||
$msg.="\n";
|
||||
|
||||
log::print($config, $msg);
|
||||
}
|
||||
|
||||
sub print{
|
||||
my $config = $_[0];
|
||||
my $message= $_[1];
|
||||
|
||||
unless (defined $config){
|
||||
print STDERR "missing config at log::error\n";
|
||||
return;
|
||||
}
|
||||
|
||||
my $filename=$config->{system}->{log_debug_file}||'';
|
||||
if ($filename eq ''){
|
||||
print STDERR "calcms config parameter 'system/log_debug_file' not set!\n";
|
||||
return;
|
||||
};
|
||||
|
||||
open my $FILE, ">>:utf8", $filename or warn("cant write log file '$filename'");
|
||||
print $FILE $message;
|
||||
close $FILE;
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $config = $_[0];
|
||||
my $message="Error: $_[1]\n";
|
||||
|
||||
unless (defined $config){
|
||||
print STDERR "missing config at log::error\n";
|
||||
}
|
||||
|
||||
print STDERR $message."\n";
|
||||
if($config::config->{system}->{debug}){
|
||||
log::write($config, '', $message);# if ($config::config->{system}->{debug}>1);
|
||||
|
||||
my $out='';
|
||||
#do not call template::check to avoid deep recursion!
|
||||
template::process('print','templates/default.html', {
|
||||
static_files_url => $config::config->{locations}->{static_files_url},
|
||||
error=>$message
|
||||
});
|
||||
}
|
||||
# TODO: remove exit
|
||||
die();
|
||||
#exit;
|
||||
}
|
||||
|
||||
sub mem{
|
||||
my $config = $_[0];
|
||||
return unless $config::config->{system}->{debug_memory};
|
||||
my $size=$log::gtop->proc_mem($$)->size();
|
||||
my $format_size=$size;
|
||||
$format_size=~s/(\d)(\d\d\d)$/$1\.$2/g;
|
||||
$format_size=~s/(\d)(\d\d\d)(\d\d\d)$/$1\.$2\.$3/g;
|
||||
my $line=localtime(time())."\t".$$."\t".$format_size."\t".$_[0];
|
||||
$line.="\t\t".($size-$_[1]) if(defined $_[1]);
|
||||
log::error($config, "log_memory_file is not defined!") if (!defined $config::config->{system}->{log_debug_memory_file});
|
||||
log::append_file($config::config->{system}->{log_debug_memory_file} , $line);
|
||||
}
|
||||
|
||||
sub load_file{
|
||||
my $filename=$_[0];
|
||||
# my $content=$_[1];
|
||||
|
||||
# binmode STDOUT, ":utf8";
|
||||
my $content='';
|
||||
if (-e $filename){
|
||||
my $FILE=undef;
|
||||
open $FILE, "<:utf8", $filename || warn "cant read file '$filename'";
|
||||
$content=join "",(<$FILE>);
|
||||
close $FILE;
|
||||
return $content;
|
||||
}
|
||||
}
|
||||
|
||||
sub save_file{
|
||||
my $filename=$_[0];
|
||||
my $content=$_[1];
|
||||
|
||||
#check if directory is writeable
|
||||
if ($filename=~/^(.+?)\/[^\/]+$/){
|
||||
my $dir=$1;
|
||||
unless (-w $dir){
|
||||
print STDERR `pwd;id -a;`;
|
||||
print STDERR "log::save_file : cannot write to directory ($dir)\n";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
open my $FILE, ">:utf8", $filename || warn("cant write file '$filename'");
|
||||
if (defined $FILE){
|
||||
print $FILE $content."\n";
|
||||
close $FILE;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub append_file{
|
||||
my $filename =$_[0];
|
||||
my $content =$_[1];
|
||||
|
||||
unless ( (defined $filename) && ($filename ne'') && (-e $filename) ){
|
||||
print STDERR "cannot append, file '$filename' does not exist\n";
|
||||
return;
|
||||
}
|
||||
|
||||
if (defined $content){
|
||||
open my $FILE, ">>:utf8", $filename or warn("cant write file '$filename'");
|
||||
print $FILE $content."\n";
|
||||
close $FILE;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
485
lib/calcms/markup.pm
Normal file
485
lib/calcms/markup.pm
Normal file
@@ -0,0 +1,485 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use Text::WikiCreole;
|
||||
|
||||
use HTML::Parse;
|
||||
use HTML::FormatText;
|
||||
|
||||
use log;
|
||||
|
||||
package markup;
|
||||
|
||||
use Encode;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
#our @EXPORT = qw(all);
|
||||
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);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
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;
|
||||
|
||||
my $s = "";
|
||||
while($num){
|
||||
$s= chr (--$num % 26 + ord "a").$s;
|
||||
$num = int $num/26;
|
||||
}
|
||||
|
||||
return $s;
|
||||
}
|
||||
|
||||
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;
|
||||
# $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;
|
||||
|
||||
#table elements
|
||||
# $s=~s/\s*<\/?td.*?>//gi;
|
||||
# $s=~s/\s*<\/?th.*?>//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;
|
||||
#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/<\/?b.*?>//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;
|
||||
#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=~/</);
|
||||
|
||||
$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;
|
||||
|
||||
#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/<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/\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;
|
||||
|
||||
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/\</\</g;
|
||||
|
||||
#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\*.*?\n)([^\*])/$1\n\n$2/g;
|
||||
|
||||
#enter line break before headlines
|
||||
$s=~s/(={2,99})/\n$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/\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/<\/a>//gi;
|
||||
|
||||
return $s;
|
||||
}
|
||||
|
||||
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([^\]]*?\]\])/$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=~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/\</\</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;
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
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 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;
|
||||
# $_[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;
|
||||
#remove images + links
|
||||
$_[0]=~s/\[\[.+?\|(.+?)\]\]/$1/g;
|
||||
$_[0]=~s/\{\{.+?\}\}//g;
|
||||
return encode_xml_element($_[0]);
|
||||
|
||||
# $_[0]=~s/\ä/ä/gi;
|
||||
# $_[0]=~s/\ö/ö/gi;
|
||||
# $_[0]=~s/\ü/ü/gi;
|
||||
# $_[0]=~s/\Ä/Ä/gi;
|
||||
# $_[0]=~s/\Ö/Ö/gi;
|
||||
# $_[0]=~s/\Ü/Ü/gi;
|
||||
# $_[0]=~s/\ß/ß/gi;
|
||||
# $_[0]=~s/\&/\&/gi;
|
||||
# $_[0]=~s/\</\</gi;
|
||||
# $_[0]=~s/\>/\>/gi;
|
||||
# $_[0]=~s/\"/\"/gi;
|
||||
|
||||
## $_[0]=~s/\n/<br\/>/gi;
|
||||
## $_[0]=~s/\&amp;/\&/gi;
|
||||
## $_[0]=~s/\&amp;/+/gi;
|
||||
## $_[0]=~s/\&/+/gi;
|
||||
## $_[0]=~s/\&/+/gi;
|
||||
# return $_[0];
|
||||
}
|
||||
|
||||
sub fix_utf8{
|
||||
$_[0] = decode( 'cp1252', $_[0] );
|
||||
return $_[0];
|
||||
}
|
||||
|
||||
sub uri_encode{
|
||||
$_[0] =~s/([^a-zA-Z0-9_\.\-])/sprintf("%%%02lx",ord($1))/esg;
|
||||
return $_[0];
|
||||
}
|
||||
|
||||
sub compress{
|
||||
my $header='';
|
||||
|
||||
if($_[0]=~/(Content\-type\:[^\n]+[\n]+)/){
|
||||
$header=$1;
|
||||
}else{
|
||||
#return;
|
||||
}
|
||||
|
||||
my $start=index($_[0],$header);
|
||||
return if ($start<0);
|
||||
|
||||
my $header_length=length($header);
|
||||
$header =substr($_[0],0,$start+$header_length);
|
||||
# print $header."\n";
|
||||
|
||||
my $content=substr($_[0],$start+$header_length);
|
||||
|
||||
# #remove multiple line breaks
|
||||
$content=~s/[\r\n]+[\s]*[\r\n]+/\n/g;
|
||||
|
||||
#remove leading whitespaces
|
||||
$content=~s/[\r\n]+[\s]+/\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;
|
||||
|
||||
#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 empty lines
|
||||
$content=~s/[\n\r]+/\n/g;
|
||||
|
||||
#remove whitespaces between tags
|
||||
$content=~s/\>[\t ]+\<(^\/T)/\>\<$1/g;
|
||||
|
||||
#multiple whitespaces
|
||||
$content=~s/[\t ]+/ /g;
|
||||
|
||||
#restore content-type line break
|
||||
$_[0]=$header.$content;
|
||||
#$_[0]=~s/HTTP_CONTENT_TYPE/\n\n/;
|
||||
# return $_[0];
|
||||
}
|
||||
|
||||
#from XML::RSS.pm
|
||||
my %entity = (
|
||||
nbsp => " ",
|
||||
iexcl => "¡",
|
||||
cent => "¢",
|
||||
pound => "£",
|
||||
curren => "¤",
|
||||
yen => "¥",
|
||||
brvbar => "¦",
|
||||
sect => "§",
|
||||
uml => "¨",
|
||||
copy => "©",
|
||||
ordf => "ª",
|
||||
laquo => "«",
|
||||
not => "¬",
|
||||
shy => "­",
|
||||
reg => "®",
|
||||
macr => "¯",
|
||||
deg => "°",
|
||||
plusmn => "±",
|
||||
sup2 => "²",
|
||||
sup3 => "³",
|
||||
acute => "´",
|
||||
micro => "µ",
|
||||
para => "¶",
|
||||
middot => "·",
|
||||
cedil => "¸",
|
||||
sup1 => "¹",
|
||||
ordm => "º",
|
||||
raquo => "»",
|
||||
frac14 => "¼",
|
||||
frac12 => "½",
|
||||
frac34 => "¾",
|
||||
iquest => "¿",
|
||||
Agrave => "À",
|
||||
Aacute => "Á",
|
||||
Acirc => "Â",
|
||||
Atilde => "Ã",
|
||||
Auml => "Ä",
|
||||
Aring => "Å",
|
||||
AElig => "Æ",
|
||||
Ccedil => "Ç",
|
||||
Egrave => "È",
|
||||
Eacute => "É",
|
||||
Ecirc => "Ê",
|
||||
Euml => "Ë",
|
||||
Igrave => "Ì",
|
||||
Iacute => "Í",
|
||||
Icirc => "Î",
|
||||
Iuml => "Ï",
|
||||
ETH => "Ð",
|
||||
Ntilde => "Ñ",
|
||||
Ograve => "Ò",
|
||||
Oacute => "Ó",
|
||||
Ocirc => "Ô",
|
||||
Otilde => "Õ",
|
||||
Ouml => "Ö",
|
||||
times => "×",
|
||||
Oslash => "Ø",
|
||||
Ugrave => "Ù",
|
||||
Uacute => "Ú",
|
||||
Ucirc => "Û",
|
||||
Uuml => "Ü",
|
||||
Yacute => "Ý",
|
||||
THORN => "Þ",
|
||||
szlig => "ß",
|
||||
agrave => "à",
|
||||
aacute => "á",
|
||||
acirc => "â",
|
||||
atilde => "ã",
|
||||
auml => "ä",
|
||||
aring => "å",
|
||||
aelig => "æ",
|
||||
ccedil => "ç",
|
||||
egrave => "è",
|
||||
eacute => "é",
|
||||
ecirc => "ê",
|
||||
euml => "ë",
|
||||
igrave => "ì",
|
||||
iacute => "í",
|
||||
icirc => "î",
|
||||
iuml => "ï",
|
||||
eth => "ð",
|
||||
ntilde => "ñ",
|
||||
ograve => "ò",
|
||||
oacute => "ó",
|
||||
ocirc => "ô",
|
||||
otilde => "õ",
|
||||
ouml => "ö",
|
||||
divide => "÷",
|
||||
oslash => "ø",
|
||||
ugrave => "ù",
|
||||
uacute => "ú",
|
||||
ucirc => "û",
|
||||
uuml => "ü",
|
||||
yacute => "ý",
|
||||
thorn => "þ",
|
||||
yuml => "ÿ",
|
||||
);
|
||||
|
||||
my $entities = join('|', keys %entity);
|
||||
|
||||
sub encode_xml_element {
|
||||
my $text = shift;
|
||||
|
||||
my $encoded_text = '';
|
||||
|
||||
while ( $text =~ s/(.*?)(\<\!\[CDATA\[.*?\]\]\>)//s ) {
|
||||
$encoded_text .= encode_xml_element_text($1) . $2;
|
||||
}
|
||||
$encoded_text .= encode_xml_element_text($text);
|
||||
|
||||
return $encoded_text;
|
||||
}
|
||||
|
||||
sub encode_xml_element_text {
|
||||
my $text = shift;
|
||||
|
||||
$text =~ s/&(?!(#[0-9]+|#x[0-9a-fA-F]+|\w+);)/&/g;
|
||||
$text =~ s/&($entities);/$entity{$1}/g;
|
||||
$text =~ s/\</\<\;/g;
|
||||
$text =~ s/\>/\>\;/g;
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
83
lib/calcms/params.pm
Normal file
83
lib/calcms/params.pm
Normal file
@@ -0,0 +1,83 @@
|
||||
package params;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use CGI;
|
||||
use Apache2::Request;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get isJson);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
my $isJson=0;
|
||||
|
||||
sub isJson{
|
||||
return $isJson;
|
||||
}
|
||||
|
||||
sub get{
|
||||
#get the Apache2::RequestRec
|
||||
my $r=shift;
|
||||
|
||||
my $tmp_dir ='/var/tmp/';
|
||||
my $upload_limit=1000*1024;
|
||||
|
||||
my $cgi = undef;
|
||||
my $status = undef;
|
||||
my $params = {};
|
||||
|
||||
$isJson=0;
|
||||
|
||||
if (defined $r){
|
||||
#print STDERR "Apache2::Request\n";
|
||||
#get Apache2::Request
|
||||
my $req = Apache2::Request->new($r, POST_MAX => $upload_limit, TEMP_DIR => $tmp_dir);
|
||||
|
||||
for my $key ($req->param){
|
||||
$params->{scalar($key)}=scalar($req->param($key));
|
||||
}
|
||||
|
||||
#copy params to hash
|
||||
#my $body=$req->body();
|
||||
#if (defined $body){
|
||||
# for my $key (keys %$body){
|
||||
# $params->{scalar($key)}=scalar($req->param($key));
|
||||
# }
|
||||
#}
|
||||
$status = $req->parse; #parse
|
||||
}else{
|
||||
#print STDERR "CGI\n";
|
||||
$CGI::POST_MAX = $upload_limit;
|
||||
$CGI::TMPDIRECTORY=$tmp_dir;
|
||||
$cgi=new CGI();
|
||||
$status=$cgi->cgi_error()||$status;
|
||||
my %params=$cgi->Vars();
|
||||
$params=\%params;
|
||||
}
|
||||
$cgi=new CGI() unless(defined $cgi);
|
||||
|
||||
$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');
|
||||
print $cgi->header.$status."\n" if($status ne'');
|
||||
}
|
||||
#print STDERR Dumper($params);
|
||||
#print $cgi->header.Dumper($params).$status;
|
||||
|
||||
return ($cgi, $params, $status);
|
||||
}
|
||||
|
||||
sub debug{
|
||||
my $message=shift;
|
||||
#print "$msg<br/>\n" if ($debug>0);
|
||||
#print "$message<br>\n";
|
||||
#log::print($message."\n") if ($debug);
|
||||
}
|
||||
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
367
lib/calcms/playout.pm
Normal file
367
lib/calcms/playout.pm
Normal file
@@ -0,0 +1,367 @@
|
||||
#!/bin/perl
|
||||
|
||||
package playout;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use Date::Calc;
|
||||
use db;
|
||||
use time;
|
||||
use series_events;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get sync);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
# get playout entries
|
||||
sub get{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
return undef unless defined $condition->{studio_id};
|
||||
|
||||
my $date_range_include=0;
|
||||
$date_range_include=1 if $condition->{date_range_include}==1;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{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->{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 $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select date(start) start_date
|
||||
,date(end) end_date
|
||||
,dayname(start) weekday
|
||||
,start_date day
|
||||
,start
|
||||
,end
|
||||
,studio_id
|
||||
,project_id
|
||||
,duration
|
||||
,file
|
||||
,errors
|
||||
,channels
|
||||
,format
|
||||
,format_version
|
||||
,format_profile
|
||||
,format_settings
|
||||
,stream_size
|
||||
,bitrate
|
||||
,bitrate_mode
|
||||
,sampling_rate
|
||||
,writing_library
|
||||
,rms_left
|
||||
,rms_right
|
||||
,rms_image
|
||||
from calcms_playout
|
||||
$conditions
|
||||
order by start
|
||||
};
|
||||
|
||||
#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;
|
||||
|
||||
#print STDERR Dumper($config);
|
||||
#print STDERR 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};
|
||||
#print STDERR "sync\n";
|
||||
#print STDERR Dumper($updates);
|
||||
|
||||
# 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}
|
||||
];
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_playout
|
||||
where project_id=?
|
||||
and studio_id=?
|
||||
and start >=?
|
||||
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 "entries:".Dumper($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;
|
||||
|
||||
# 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;
|
||||
}
|
||||
}
|
||||
|
||||
# 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;
|
||||
|
||||
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'){
|
||||
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;
|
||||
|
||||
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'){
|
||||
if (($oldEntry->{$key}||'') ne ($newEntry->{$key}||'')){
|
||||
$oldEntry->{$key}=$newEntry->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
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 $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->{project_id}, $entry->{studio_id}, $entry->{start}
|
||||
];
|
||||
my $query=qq{
|
||||
update calcms_playout
|
||||
set end=?, duration=?, file=?, errors=?,
|
||||
start_date=?, end_date=?,
|
||||
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=?
|
||||
where project_id=? and studio_id=? and start=?
|
||||
};
|
||||
return db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
# insert playout entry
|
||||
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};
|
||||
|
||||
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}
|
||||
});
|
||||
|
||||
}
|
||||
|
||||
# delete playout entry
|
||||
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};
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
sub getEnd{
|
||||
my $start=shift;
|
||||
my $duration=shift;
|
||||
# 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(\@end_datetime);
|
||||
return time::array_to_datetime(\@end_datetime);
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
478
lib/calcms/project.pm
Normal file
478
lib/calcms/project.pm
Normal file
@@ -0,0 +1,478 @@
|
||||
#!/bin/perl
|
||||
|
||||
package project;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
use Date::Calc;
|
||||
use config;
|
||||
use log;
|
||||
use template;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
check get_columns get insert delete get_date_range
|
||||
get_studios assign_studio unassign_studio is_studio_assigned get_studio_assignments
|
||||
get_series_ids assign_series unassign_series is_series_assigned get_series_assignments
|
||||
get_with_dates get_sorted
|
||||
);
|
||||
#TODO: globally replace get_studios by get_studio_assignments
|
||||
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
# get project columns
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_projects');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $columns;
|
||||
}
|
||||
|
||||
# get projects
|
||||
sub get{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{name}) && ($condition->{name} ne '')){
|
||||
push @conditions, 'name=?';
|
||||
push @bind_values, $condition->{name};
|
||||
}
|
||||
|
||||
my $limit='';
|
||||
if ((defined $condition->{limit}) && ($condition->{limit} ne '')){
|
||||
$limit= 'limit '.$condition->{limit};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_projects
|
||||
$conditions
|
||||
order by start_date
|
||||
$limit
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
|
||||
my $projects=db::get($dbh, $query, \@bind_values);
|
||||
return $projects;
|
||||
}
|
||||
|
||||
sub get_date_range{
|
||||
my $config=shift;
|
||||
my $query=qq{
|
||||
select min(start_date) start_date, max(end_date) end_date
|
||||
from calcms_projects
|
||||
};
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $projects=db::get($dbh, $query);
|
||||
return $projects->[0];
|
||||
}
|
||||
|
||||
# insert project
|
||||
sub insert{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
my $columns=get_columns($config);
|
||||
my $project={};
|
||||
for my $column (keys %$columns){
|
||||
$project->{$column}=$entry->{$column} if defined $entry->{$column};
|
||||
}
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $id=db::insert($dbh, 'calcms_projects', $project);
|
||||
return $id;
|
||||
}
|
||||
|
||||
# delete project
|
||||
sub delete{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
db::put($dbh, 'delete from calcms_projects where project_id=?', [$entry->{project_id}]);
|
||||
}
|
||||
|
||||
# update project
|
||||
sub update{
|
||||
my $config=shift;
|
||||
my $project=shift;
|
||||
|
||||
my $columns=project::get_columns($config);
|
||||
my $entry={};
|
||||
for my $column (keys %$columns){
|
||||
$entry->{$column}=$project->{$column} if defined $project->{$column};
|
||||
}
|
||||
|
||||
my $values =join(",", map {$_.'=?'} (keys %$entry));
|
||||
my @bind_values =map {$entry->{$_}} (keys %$entry);
|
||||
push @bind_values,$entry->{project_id};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_projects
|
||||
set $values
|
||||
where project_id=?
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
my $dbh=db::connect($config);
|
||||
db::put($dbh, $query, \@bind_values);
|
||||
}
|
||||
|
||||
|
||||
# get studios of a project
|
||||
sub get_studios{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
return undef unless defined $options->{project_id};
|
||||
my $project_id=$options->{project_id};
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_project_studios
|
||||
where project_id=?
|
||||
};
|
||||
my $dbh=db::connect($config);
|
||||
my $project_studios=db::get($dbh,$query,[$project_id]);
|
||||
|
||||
return $project_studios;
|
||||
}
|
||||
|
||||
sub get_studio_assignments{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $options->{project_id}) && ($options->{project_id} ne '')){
|
||||
push @conditions, 'project_id=?';
|
||||
push @bind_values, $options->{project_id};
|
||||
}
|
||||
|
||||
if ((defined $options->{studio_id}) && ($options->{studio_id} ne '')){
|
||||
push @conditions, 'studio_id=?';
|
||||
push @bind_values, $options->{studio_id};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_project_studios
|
||||
$conditions
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $results=db::get($dbh, $query, \@bind_values);
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
# is studio assigned to project
|
||||
sub is_studio_assigned{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return 0 unless defined $entry->{project_id};
|
||||
return 0 unless defined $entry->{studio_id};
|
||||
|
||||
my $project_id=$entry->{project_id};
|
||||
my $studio_id= $entry->{studio_id};
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_project_studios
|
||||
where project_id=? and studio_id=?
|
||||
};
|
||||
my $bind_values=[$project_id, $studio_id];
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $project_studios=db::get($dbh, $query, $bind_values);
|
||||
return 1 if @$project_studios==1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
# assign studio to project
|
||||
sub assign_studio{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return undef unless defined $entry->{project_id};
|
||||
return undef unless defined $entry->{studio_id};
|
||||
my $project_id=$entry->{project_id};
|
||||
my $studio_id= $entry->{studio_id};
|
||||
|
||||
if (is_studio_assigned($entry)){
|
||||
print STDERR "studio $entry->{studio_id} already assigned to project $entry->{project_id}\n";
|
||||
return 1;
|
||||
}
|
||||
my $dbh=db::connect($config);
|
||||
my $id=db::insert($dbh, 'calcms_project_studios', $entry);
|
||||
return $id;
|
||||
}
|
||||
|
||||
# unassign studio from project
|
||||
sub unassign_studio{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return undef unless defined $entry->{project_id};
|
||||
return undef unless defined $entry->{studio_id};
|
||||
my $project_id=$entry->{project_id};
|
||||
my $studio_id= $entry->{studio_id};
|
||||
|
||||
my $sql='delete from calcms_project_studios where project_id=? and studio_id=?';
|
||||
my $bind_values=[$project_id, $studio_id];
|
||||
my $dbh=db::connect($config);
|
||||
return db::put($dbh, $sql, $bind_values);
|
||||
}
|
||||
|
||||
# get series by project and studio
|
||||
sub get_series{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
return undef unless defined $options->{project_id};
|
||||
return undef unless defined $options->{studio_id};
|
||||
my $project_id=$options->{project_id};
|
||||
my $studio_id= $options->{studio_id};
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_project_series
|
||||
where project_id=? and studio_id=?
|
||||
};
|
||||
my $bind_values=[$project_id, $studio_id];
|
||||
my $dbh=db::connect($config);
|
||||
my $project_series=db::get($dbh, $query, $bind_values);
|
||||
|
||||
return $project_series;
|
||||
}
|
||||
|
||||
sub get_series_assignments{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $options->{project_id}) && ($options->{project_id} ne '')){
|
||||
push @conditions, 'project_id=?';
|
||||
push @bind_values, $options->{project_id};
|
||||
}
|
||||
|
||||
if ((defined $options->{studio_id}) && ($options->{studio_id} ne '')){
|
||||
push @conditions, 'studio_id=?';
|
||||
push @bind_values, $options->{studio_id};
|
||||
}
|
||||
|
||||
if ((defined $options->{series_id}) && ($options->{series_id} ne '')){
|
||||
push @conditions, 'series_id=?';
|
||||
push @bind_values, $options->{series_id};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_project_series
|
||||
$conditions
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $results=db::get($dbh, $query, \@bind_values);
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
# is series assigned to project and studio
|
||||
sub is_series_assigned{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return 0 unless defined $entry->{project_id};
|
||||
return 0 unless defined $entry->{studio_id};
|
||||
return 0 unless defined $entry->{series_id};
|
||||
|
||||
my $project_id=$entry->{project_id};
|
||||
my $studio_id= $entry->{studio_id};
|
||||
my $series_id= $entry->{series_id};
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_project_series
|
||||
where project_id=? and studio_id=? and series_id=?
|
||||
};
|
||||
my $bind_values=[$project_id, $studio_id, $series_id];
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $project_series=db::get($dbh,$query, $bind_values);
|
||||
return 1 if @$project_series==1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
# assign series to project and studio
|
||||
sub assign_series{
|
||||
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};
|
||||
|
||||
my $project_id=$entry->{project_id};
|
||||
my $studio_id= $entry->{studio_id};
|
||||
my $series_id= $entry->{series_id};
|
||||
|
||||
if (is_series_assigned($entry)){
|
||||
print STDERR "series $series_id already assigned to project $project_id and studio $studio_id\n";
|
||||
return return undef;
|
||||
}
|
||||
my $dbh=db::connect($config);
|
||||
my $id=db::insert($dbh, 'calcms_project_series', $entry);
|
||||
print STDERR "assigned series $series_id to project $project_id and studio $studio_id\n";
|
||||
return $id;
|
||||
}
|
||||
|
||||
# unassign series from project
|
||||
# TODO: remove series _single_ if no event is assigned to
|
||||
sub unassign_series{
|
||||
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};
|
||||
|
||||
my $project_id=$entry->{project_id};
|
||||
my $studio_id= $entry->{studio_id};
|
||||
my $series_id= $entry->{series_id};
|
||||
|
||||
my $sql='delete from calcms_project_series where project_id=? and studio_id=? and series_id=?';
|
||||
my $bind_values=[$project_id, $studio_id, $series_id];
|
||||
my $dbh=db::connect($config);
|
||||
return db::put($dbh, $sql, $bind_values);
|
||||
}
|
||||
|
||||
sub get_with_dates{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
my $language = $config->{date}->{language} || 'en';
|
||||
my $projects=project::get($config, {});
|
||||
|
||||
foreach my $project (reverse sort { $a->{end_date} cmp $b->{end_date} } (@$projects) ){
|
||||
$project->{months} = get_months($config, $project, $language);
|
||||
$project->{user} = $ENV{REMOTE_USER};
|
||||
$project->{current} = 1 if ($project->{name} eq $config::config->{project});
|
||||
}
|
||||
|
||||
return $projects;
|
||||
}
|
||||
|
||||
#TODO: add config
|
||||
sub get_sorted{
|
||||
my $config=shift;
|
||||
my $projects=project::get($config, {});
|
||||
my @projects=reverse sort { $a->{end_date} cmp $b->{end_date} } (@$projects);
|
||||
|
||||
unshift @projects,{
|
||||
name => 'all',
|
||||
title => 'alle',
|
||||
priority => '0',
|
||||
start_date => $projects[-1]->{start_date},
|
||||
end_date => $projects[0]->{end_date},
|
||||
};
|
||||
return \@projects;
|
||||
}
|
||||
|
||||
# internal
|
||||
sub get_months{
|
||||
my $config=shift;
|
||||
my $project = shift;
|
||||
my $language = shift || $config->{date}->{language} || 'en';
|
||||
|
||||
my $start = $project->{start_date};
|
||||
my $end = $project->{end_date};
|
||||
|
||||
(my $start_year,my $start_month,my $start_day)=split(/\-/,$start);
|
||||
my $last_day = Date::Calc::Days_in_Month($start_year,$start_month);
|
||||
$start_day = 1 if ($start_day<1);
|
||||
$start_day = $last_day if ($start_day gt $last_day);
|
||||
|
||||
(my $end_year,my $end_month,my $end_day)=split(/\-/,$end);
|
||||
$last_day = Date::Calc::Days_in_Month($end_year,$end_month);
|
||||
$end_day = 1 if ($end_day<1);
|
||||
$end_day = $last_day if ($end_day gt $last_day);
|
||||
|
||||
my @months=();
|
||||
for my $year($start_year..$end_year){
|
||||
my $m1=1;
|
||||
my $m2=12;
|
||||
$m1=$start_month if $year eq $start_year;
|
||||
$m2=$end_month if $year eq $end_year;
|
||||
|
||||
for my $month($m1..$m2){
|
||||
my $d1=1;
|
||||
my $d2=Date::Calc::Days_in_Month($year,$month);
|
||||
$d1=$start_day if $month eq $start_month;
|
||||
$d2=$end_day if $month eq $end_month;
|
||||
push @months,{
|
||||
start => time::array_to_date($year,$month,$d1),
|
||||
end => time::array_to_date($year,$month,$d2),
|
||||
year => $year,
|
||||
month => $month,
|
||||
month_name => $time::names->{$language}->{months_abbr}->[$month-1],
|
||||
title => $project->{title},
|
||||
user => $ENV{REMOTE_USER}
|
||||
};
|
||||
}
|
||||
}
|
||||
@months=reverse @months;
|
||||
return \@months;
|
||||
}
|
||||
|
||||
# check project_id
|
||||
sub check{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
return "missing project_id at checking project" unless defined $options->{project_id};
|
||||
return "Please select a project" if($options->{project_id}eq'-1');
|
||||
return "Please select a project" if($options->{project_id}eq'');
|
||||
my $projects=project::get($config, { project_id=>$options->{project_id} } );
|
||||
return "Sorry. unknown project" unless defined $projects;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
8
lib/calcms/projects.pm
Normal file
8
lib/calcms/projects.pm
Normal file
@@ -0,0 +1,8 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
package projects;
|
||||
|
||||
print STDERR "projects.pm is not used anymore!\n";
|
||||
#do not delete last line!
|
||||
1;
|
||||
146
lib/calcms/roles.pm
Normal file
146
lib/calcms/roles.pm
Normal file
@@ -0,0 +1,146 @@
|
||||
package roles;
|
||||
use Apache2::Reload;
|
||||
require Exporter;
|
||||
my @ISA = qw(Exporter);
|
||||
my @EXPORT_OK = qw($roles get_user get_user_permissions get_template_parameters);
|
||||
my %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
our $roles={
|
||||
'admin' => {
|
||||
access_events => 1,
|
||||
access_images => 1,
|
||||
access_comments => 1,
|
||||
access_sync => 1,
|
||||
access_system => 1,
|
||||
read_event_all => 1,
|
||||
create_event => 1,
|
||||
delete_event => 1,
|
||||
update_comment => 1,
|
||||
create_image => 1,
|
||||
read_image_own => 1,
|
||||
read_image_all => 1,
|
||||
update_image_own => 1,
|
||||
update_image_all => 1,
|
||||
delete_image_own => 1,
|
||||
delete_image_all => 1,
|
||||
sync_own => 1,
|
||||
sync_all => 1,
|
||||
sync_select_range => 1,
|
||||
upload_playlist => 1,
|
||||
},
|
||||
'dev' => {
|
||||
access_events => 1,
|
||||
access_images => 1,
|
||||
access_comments => 1,
|
||||
access_sync => 1,
|
||||
access_system => 0,
|
||||
read_event_all => 1,
|
||||
create_event => 1,
|
||||
delete_event => 1,
|
||||
update_comment => 1,
|
||||
create_image => 1,
|
||||
read_image_own => 1,
|
||||
read_image_all => 1,
|
||||
update_image_own => 1,
|
||||
update_image_all => 1,
|
||||
delete_image_own => 1,
|
||||
delete_image_all => 1,
|
||||
sync_own => 0,
|
||||
sync_all => 1,
|
||||
sync_select_range => 1,
|
||||
upload_playlist => 1,
|
||||
},
|
||||
'editor' => {
|
||||
access_events => 1,
|
||||
access_images => 1,
|
||||
access_comments => 1,
|
||||
access_sync => 1,
|
||||
access_system => 0,
|
||||
read_event_all => 0,
|
||||
create_event => 1,
|
||||
delete_event => 0,
|
||||
update_comment => 0,
|
||||
create_image => 1,
|
||||
read_image_own => 1,
|
||||
read_image_all => 1,
|
||||
update_image_own => 1,
|
||||
update_image_all => 0,
|
||||
delete_image_own => 1,
|
||||
delete_image_all => 0,
|
||||
sync_own => 1,
|
||||
sync_all => 0,
|
||||
sync_select_range => 0,
|
||||
upload_playlist => 1,
|
||||
},
|
||||
'nobody' => {
|
||||
access_events => 0,
|
||||
access_images => 0,
|
||||
access_comments => 0,
|
||||
access_sync => 0,
|
||||
access_system => 0,
|
||||
read_event_all => 0,
|
||||
create_event => 0,
|
||||
delete_event => 0,
|
||||
update_comment => 0,
|
||||
create_image => 0,
|
||||
read_image_own => 0,
|
||||
read_image_all => 0,
|
||||
update_image_own => 0,
|
||||
update_image_all => 0,
|
||||
delete_image_own => 0,
|
||||
delete_image_all => 0,
|
||||
sync_own => 0,
|
||||
sync_all => 0,
|
||||
sync_select_range => 0,
|
||||
upload_playlist => 0,
|
||||
}
|
||||
};
|
||||
|
||||
sub get_user{
|
||||
my $user= $ENV{REMOTE_USER};
|
||||
my $users=$config::config->{users};
|
||||
return $user if (defined $users->{$user});
|
||||
return 'nobody';
|
||||
}
|
||||
|
||||
sub get_user_permissions{
|
||||
my $user= $ENV{REMOTE_USER}||'';
|
||||
return $roles::roles->{nobody} unless ($user=~/\S/);
|
||||
my $users=$config::config->{users};
|
||||
if (defined $users->{$user}){
|
||||
my $role=$users->{$user};
|
||||
if (defined $roles::roles->{$role}){
|
||||
return $roles::roles->{$role};
|
||||
}
|
||||
}
|
||||
return $roles::roles->{nobody};
|
||||
}
|
||||
|
||||
sub get_user_jobs{
|
||||
my $user= $ENV{REMOTE_USER}||'';
|
||||
return [] unless($user =~/\S/);
|
||||
my $result=[];
|
||||
my $jobs=$config::config->{jobs}->{job};
|
||||
|
||||
for my $job (@$jobs){
|
||||
for my $job_user (split /\,/,$job->{users}){
|
||||
push @$result,$job if ($user eq $job_user);
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub get_jobs{
|
||||
return $config::config->{jobs}->{job};
|
||||
}
|
||||
|
||||
sub get_template_parameters{
|
||||
my $user_permissions=shift;
|
||||
$user_permissions=roles::get_user_permissions() unless(defined $user_permissions);
|
||||
my @user_permissions=();
|
||||
for my $usecase (keys %$user_permissions){
|
||||
push @user_permissions, $usecase if ($user_permissions->{$usecase}eq'1');
|
||||
}
|
||||
return \@user_permissions;
|
||||
}
|
||||
|
||||
1208
lib/calcms/series.pm
Normal file
1208
lib/calcms/series.pm
Normal file
File diff suppressed because it is too large
Load Diff
555
lib/calcms/series_dates.pm
Normal file
555
lib/calcms/series_dates.pm
Normal file
@@ -0,0 +1,555 @@
|
||||
package series_dates;
|
||||
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use Date::Calc;
|
||||
use time;
|
||||
use db;
|
||||
use log;
|
||||
use studio_timeslot_dates;
|
||||
use series_schedule;
|
||||
|
||||
# schedule dates for series_schedule
|
||||
# table: calcms_series_dates
|
||||
# columns: id, studio_id, series_id, start(datetime), end(datetime)
|
||||
# TODO: delete column schedule_id
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get insert update delete get_dates get_series);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_series_dates');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $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{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{series_id}) && ($condition->{series_id} ne '')){
|
||||
push @conditions, 'series_id=?';
|
||||
push @bind_values, $condition->{series_id};
|
||||
}
|
||||
|
||||
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 '')){
|
||||
push @conditions, 'start_date>=?';
|
||||
push @bind_values, $condition->{from};
|
||||
}
|
||||
|
||||
if ((defined $condition->{till}) && ($condition->{till} ne '')){
|
||||
push @conditions, 'end_date<?';
|
||||
push @bind_values, $condition->{till};
|
||||
}
|
||||
|
||||
if ((defined $condition->{schedule_id}) && ($condition->{schedule_id} ne '')){
|
||||
push @conditions, 'id=?';
|
||||
push @bind_values, $condition->{schedule_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{exclude}) && ($condition->{exclude} ne '')){
|
||||
push @conditions, 'exclude=?';
|
||||
push @bind_values, $condition->{exclude};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select date(start) start_date
|
||||
,date(end) end_date
|
||||
,dayname(start) weekday
|
||||
,start_date day
|
||||
,start
|
||||
,end
|
||||
,id schedule_id
|
||||
,series_id
|
||||
,studio_id
|
||||
,project_id
|
||||
,exclude
|
||||
|
||||
from calcms_series_dates
|
||||
$conditions
|
||||
order by start
|
||||
};
|
||||
#print STDERR $query."\n";
|
||||
#print STDERR Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
for my $entry (@$entries){
|
||||
$entry->{weekday}=substr($entry->{weekday},0,2);
|
||||
}
|
||||
|
||||
return $entries;
|
||||
}
|
||||
|
||||
#check if event is scheduled (on permission check)
|
||||
sub is_event_scheduled{
|
||||
my $request=shift;
|
||||
my $options=shift;
|
||||
|
||||
return 0 unless defined $options->{project_id};
|
||||
return 0 unless defined $options->{studio_id};
|
||||
return 0 unless defined $options->{series_id};
|
||||
return 0 unless defined $options->{start_at};
|
||||
|
||||
my $config = $request->{config};
|
||||
my $schedules=series_dates::get(
|
||||
$config, {
|
||||
project_id => $options->{project_id},
|
||||
studio_id => $options->{studio_id},
|
||||
series_id => $options->{series_id},
|
||||
start_at => $options->{start_at}
|
||||
}
|
||||
);
|
||||
return 0 if(@$schedules!=1);
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
#get all series for given studio_id, time range and search
|
||||
sub get_series{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $date_range_include=0;
|
||||
$date_range_include=1 if $condition->{date_range_include}==1;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
push @conditions, 'd.series_id=s.id';
|
||||
# push @conditions, 'd.studio_id=s.studio_id';
|
||||
|
||||
if ((defined $condition->{project_id}) && ($condition->{project_id} ne '')){
|
||||
push @conditions, 'd.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{studio_id}) && ($condition->{studio_id} ne '')){
|
||||
push @conditions, 'd.studio_id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{series_id}) && ($condition->{series_id} ne '')){
|
||||
push @conditions, 'd.series_id=?';
|
||||
push @bind_values, $condition->{series_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{start_at}) && ($condition->{start_at} ne '')){
|
||||
push @conditions, 'd.start=?';
|
||||
push @bind_values, $condition->{start_at};
|
||||
}
|
||||
|
||||
if ((defined $condition->{from}) && ($condition->{from} ne '')){
|
||||
if ($date_range_include==1){
|
||||
push @conditions, 'd.end_date>=?';
|
||||
push @bind_values, $condition->{from};
|
||||
}else{
|
||||
push @conditions, 'd.start_date>=?';
|
||||
push @bind_values, $condition->{from};
|
||||
}
|
||||
}
|
||||
|
||||
if ((defined $condition->{till}) && ($condition->{till} ne '')){
|
||||
if ($date_range_include==1){
|
||||
push @conditions, 'd.start_date<=?';
|
||||
push @bind_values, $condition->{till};
|
||||
}else{
|
||||
push @conditions, 'd.end_date<?';
|
||||
push @bind_values, $condition->{till};
|
||||
}
|
||||
}
|
||||
|
||||
if ((defined $condition->{schedule_id}) && ($condition->{schedule_id} ne '')){
|
||||
push @conditions, 'd.id=?';
|
||||
push @bind_values, $condition->{schedule_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{exclude}) && ($condition->{exclude} ne '')){
|
||||
push @conditions, 'd.exclude=?';
|
||||
push @bind_values, $condition->{exclude};
|
||||
}
|
||||
|
||||
my $search_cond='';
|
||||
if ((defined $condition->{search}) && ($condition->{search} ne'')){
|
||||
my $search=lc $condition->{search};
|
||||
$search=~s/[^a-z0-9\_\.\-\:\!öäüßÖÄÜ \&]/%/;
|
||||
$search=~s/\%+/\%/;
|
||||
$search=~s/^[\%\s]+//;
|
||||
$search=~s/[\%\s]+$//;
|
||||
if ($search ne ''){
|
||||
$search='%'.$search.'%';
|
||||
my @attr=('s.title', 's.series_name', 's.excerpt', 's.category', 's.content');
|
||||
push @conditions, "(".join(" or ", map {'lower('.$_.') like ?'} @attr ).")";
|
||||
for my $attr (@attr){
|
||||
push @bind_values,$search;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select date(d.start) start_date
|
||||
,date(d.end) end_date
|
||||
,dayname(d.start) weekday
|
||||
,d.start_date day
|
||||
,d.start
|
||||
,d.end
|
||||
,d.id schedule_id
|
||||
,d.series_id
|
||||
,d.series_schedule_id
|
||||
,d.exclude
|
||||
,d.studio_id
|
||||
,d.project_id
|
||||
,s.series_name
|
||||
,s.title
|
||||
,s.has_single_events
|
||||
from calcms_series_dates d, calcms_series s
|
||||
$conditions
|
||||
order by start
|
||||
};
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
|
||||
for my $entry (@$entries){
|
||||
$entry->{weekday} = substr($entry->{weekday},0,2);
|
||||
}
|
||||
|
||||
# add series schedule
|
||||
$entries=series_dates::addSeriesScheduleAttributes($config, $entries);
|
||||
|
||||
return $entries;
|
||||
}
|
||||
|
||||
sub addSeriesScheduleAttributes{
|
||||
my $config=shift;
|
||||
my $entries=shift;
|
||||
|
||||
my $scheduleIds={};
|
||||
# get series schedule ids used at entries
|
||||
for my $entry (@$entries){
|
||||
$scheduleIds->{$entry->{series_schedule_id}}=1;
|
||||
}
|
||||
my @scheduleIds=keys %$scheduleIds;
|
||||
return $entries if scalar(@scheduleIds)==0;
|
||||
|
||||
# get schedules with schedule ids
|
||||
my $schedules=series_schedule::get($config, {
|
||||
schedule_ids => \@scheduleIds
|
||||
});
|
||||
|
||||
# get schedules by id
|
||||
my $scheduleById={};
|
||||
for my $schedule (@$schedules){
|
||||
$scheduleById->{$schedule->{schedule_id}}=$schedule;
|
||||
}
|
||||
|
||||
for my $entry (@$entries){
|
||||
$entry->{frequency} = $scheduleById->{$entry->{series_schedule_id}}->{frequency};
|
||||
$entry->{period_type} = $scheduleById->{$entry->{series_schedule_id}}->{period_type};
|
||||
}
|
||||
|
||||
return $entries;
|
||||
}
|
||||
|
||||
|
||||
#update series dates for all schedules of a series and studio_id
|
||||
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} ;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
#delete all dates for series (by studio and series id)
|
||||
series_dates::delete($config, $entry);
|
||||
|
||||
my $day_start=$config->{date}->{day_starting_hour};
|
||||
|
||||
#get all schedules for series ordered by exclude, date
|
||||
my $schedules=series_schedule::get($config, {
|
||||
project_id => $entry->{project_id},
|
||||
studio_id => $entry->{studio_id},
|
||||
series_id => $entry->{series_id},
|
||||
});
|
||||
|
||||
#add scheduled series dates and remove exluded dates
|
||||
my $series_dates={};
|
||||
|
||||
#TODO:set schedules exclude to 0 if not 1
|
||||
#insert all normal dates (not excludes)
|
||||
for my $schedule (@$schedules){
|
||||
my $dates=get_schedule_dates($schedule, {exclude => 0});
|
||||
for my $date (@$dates){
|
||||
$date->{exclude}=0;
|
||||
$series_dates->{$date->{start}}=$date;
|
||||
#print STDERR Dumper($date)."\n" if ($date->{start} eq'2014-02-05 19:00:00');
|
||||
}
|
||||
}
|
||||
|
||||
#insert / overwrite all exlude dates
|
||||
for my $schedule (@$schedules){
|
||||
my $dates=get_schedule_dates($schedule, {exclude => 1});
|
||||
for my $date (@$dates){
|
||||
$date->{exclude}=1;
|
||||
$series_dates->{$date->{start}}=$date;
|
||||
#print STDERR Dumper($date)."\n" if ($date->{start} eq'2014-02-05 19:00:00');
|
||||
}
|
||||
}
|
||||
|
||||
#print STDERR Dumper($series_dates->{'2014-02-05 19:00:00'});
|
||||
|
||||
my $request={
|
||||
config => $config
|
||||
};
|
||||
|
||||
my $i=0;
|
||||
my $j=0;
|
||||
for my $date (keys %$series_dates){
|
||||
my $series_date=$series_dates->{$date};
|
||||
#insert date
|
||||
my $entry={
|
||||
project_id => $entry->{project_id},
|
||||
studio_id => $entry->{studio_id},
|
||||
series_id => $entry->{series_id},
|
||||
series_schedule_id => $series_date->{series_schedule_id},
|
||||
start => $series_date->{start},
|
||||
end => $series_date->{end},
|
||||
exclude => $series_date->{exclude},
|
||||
};
|
||||
if(studio_timeslot_dates::can_studio_edit_events($config, $entry)==1){ # by studio_id, start, end
|
||||
$entry->{start_date}= time::add_hours_to_datetime($entry->{start}, -$day_start);
|
||||
$entry->{end_date}= time::add_hours_to_datetime($entry->{end}, -$day_start);
|
||||
db::insert($dbh, 'calcms_series_dates', $entry);
|
||||
#print STDERR "$entry->{start_date}\n";
|
||||
$i++;
|
||||
}else{
|
||||
$j++;
|
||||
#print STDERR Dumper($entry);
|
||||
}
|
||||
}
|
||||
#print STDERR "$i series_dates updates\n";
|
||||
return $j." dates out of studio times, ".$i;
|
||||
}
|
||||
|
||||
sub get_schedule_dates{
|
||||
my $schedule=shift;
|
||||
my $options=shift;
|
||||
|
||||
my $is_exclude=$options->{exclude}||0;
|
||||
my $dates=[];
|
||||
return $dates if (($is_exclude eq'1') && ($schedule->{exclude}ne'1'));
|
||||
return $dates if (($is_exclude eq'0') && ($schedule->{exclude}eq'1'));
|
||||
|
||||
if ($schedule->{period_type}eq'single'){
|
||||
$dates=get_single_date($schedule->{start}, $schedule->{duration}) ;
|
||||
}elsif($schedule->{period_type}eq'days'){
|
||||
$dates=get_dates($schedule->{start}, $schedule->{end}, $schedule->{duration}, $schedule->{frequency}) ;
|
||||
}elsif($schedule->{period_type}eq'week_of_month'){
|
||||
$dates=get_week_of_month_dates($schedule->{start}, $schedule->{end}, $schedule->{duration}, $schedule->{week_of_month}, $schedule->{weekday}, $schedule->{month}, $schedule->{nextDay});
|
||||
}else{
|
||||
print STDERR "unknown schedule period_type\n";
|
||||
}
|
||||
|
||||
# set series schedule id
|
||||
for my $date (@$dates){
|
||||
$date->{series_schedule_id}=$schedule->{schedule_id};
|
||||
}
|
||||
return $dates;
|
||||
}
|
||||
|
||||
|
||||
sub get_week_of_month_dates{
|
||||
my $start =shift; # datetime string
|
||||
my $end =shift; # datetime string
|
||||
my $duration =shift; # in minutes
|
||||
my $week =shift; # every nth week of month
|
||||
my $weekday =shift; # weekday [1..7]
|
||||
my $frequency =shift; # every 1st,2nd,3th time
|
||||
my $nextDay =shift; # add 24 hours to start, (for night hours at last weekday of month)
|
||||
|
||||
return undef if $start eq'';
|
||||
return undef if $end eq'';
|
||||
return undef if $duration eq'';
|
||||
return undef if $week eq'';
|
||||
return undef if $weekday eq'';
|
||||
return undef if $frequency eq'';
|
||||
return undef if $frequency==0;
|
||||
|
||||
my $start_dates=time::get_nth_weekday_in_month($start, $end, $week, $weekday-1);
|
||||
|
||||
if ((defined $nextDay) && ($nextDay>0)){
|
||||
for (my $i=0;$i<@$start_dates;$i++){
|
||||
$start_dates->[$i]=time::add_hours_to_datetime($start_dates->[$i],24);
|
||||
}
|
||||
}
|
||||
|
||||
my $results=[];
|
||||
|
||||
my $c=-1;
|
||||
for my $start_datetime (@$start_dates){
|
||||
$c++;
|
||||
my @start = @{time::datetime_to_array($start_datetime)};
|
||||
next unless @start>=6;
|
||||
next if (($c % $frequency)!=0);
|
||||
|
||||
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, $duration, 0 # delta days, hours, minutes, seconds
|
||||
);
|
||||
my $end_datetime=time::array_to_datetime(\@end_datetime);
|
||||
|
||||
push @$results, {
|
||||
start => $start_datetime,
|
||||
end => $end_datetime
|
||||
};
|
||||
}
|
||||
return $results;
|
||||
}
|
||||
|
||||
#add duration to a single date
|
||||
sub get_single_date{
|
||||
my $start_datetime = shift;
|
||||
my $duration = shift;
|
||||
|
||||
my @start = @{time::datetime_to_array($start_datetime)};
|
||||
return unless @start>=6;
|
||||
|
||||
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, $duration, 0 # delta days, hours, minutes, seconds
|
||||
);
|
||||
my $date={
|
||||
start => $start_datetime,
|
||||
end => time::array_to_datetime(\@end_datetime)
|
||||
};
|
||||
return [$date];
|
||||
}
|
||||
|
||||
#calculate all dates between start_datetime and end_date with duration(minutes) and frequency(days)
|
||||
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";
|
||||
|
||||
my @start = @{time::datetime_to_array($start_datetime)};
|
||||
return unless @start>=6;
|
||||
my @start_date = ($start[0], $start[1], $start[2]);
|
||||
my $start_time = sprintf('%02d:%02d:%02d', $start[3], $start[4], $start[5]);
|
||||
|
||||
#print STDERR "$start_datetime,$end_date,$duration,$frequency\n";
|
||||
|
||||
#return on single date
|
||||
my $date={};
|
||||
$date->{start}= sprintf("%04d-%02d-%02d",@start_date).' '.$start_time;
|
||||
return undef if $duration eq '';
|
||||
|
||||
return undef if (($frequency eq '')||($end_date eq''));
|
||||
|
||||
#continue on recurring date
|
||||
my @end = @{time::datetime_to_array($end_date)};
|
||||
return unless @end>=3;
|
||||
my @end_date = ($end[0], $end[1], $end[2]);
|
||||
|
||||
my $today=time::time_to_date();
|
||||
my ($year, $month, $day)=split(/\-/,$today);
|
||||
|
||||
my $dates=[];
|
||||
return $dates if ($end_date lt $today);
|
||||
return $dates if ($frequency<1);
|
||||
|
||||
my $j = Date::Calc::Delta_Days(@start_date, @end_date);
|
||||
my $c=0;
|
||||
for (my $i = 0; $i <= $j; $i+=$frequency ){
|
||||
my @date = Date::Calc::Add_Delta_Days($start[0], $start[1], $start[2], $i);
|
||||
my $date={};
|
||||
$date->{start}=sprintf("%04d-%02d-%02d",@date).' '.$start_time;
|
||||
|
||||
#if($date->{start} gt $today){
|
||||
my @end_datetime = Date::Calc::Add_Delta_DHMS(
|
||||
$date[0], $date[1], $date[2], # start date
|
||||
$start[3], $start[4], $start[5], # start time
|
||||
0, 0, $duration, 0 # delta days, hours, minutes, seconds
|
||||
);
|
||||
$date->{end}=time::array_to_datetime(\@end_datetime);
|
||||
push @$dates,$date;
|
||||
#}
|
||||
last if ($c>200);
|
||||
$c++;
|
||||
}
|
||||
return $dates;
|
||||
}
|
||||
|
||||
#remove all series_dates for studio_id and series_id
|
||||
sub delete{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return unless defined $entry->{project_id};
|
||||
return unless defined $entry->{studio_id};
|
||||
return unless defined $entry->{series_id};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_series_dates
|
||||
where project_id=? and studio_id=? and series_id=?
|
||||
};
|
||||
my $bind_values=[$entry->{project_id}, $entry->{studio_id}, $entry->{series_id}];
|
||||
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
|
||||
db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
467
lib/calcms/series_events.pm
Normal file
467
lib/calcms/series_events.pm
Normal file
@@ -0,0 +1,467 @@
|
||||
package series_events;
|
||||
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
use Data::Dumper;
|
||||
use Date::Calc;
|
||||
use markup;
|
||||
|
||||
use db;
|
||||
use log;
|
||||
use time;
|
||||
use uac;
|
||||
use events;
|
||||
use series;
|
||||
use series_dates;
|
||||
use studios;
|
||||
use studio_timeslot_dates;
|
||||
use event_history;
|
||||
|
||||
# check permissions, insert and update events related to series
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
check_permission
|
||||
save_content
|
||||
save_event_time
|
||||
insert_event
|
||||
delete_event
|
||||
set_playout_status
|
||||
);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
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{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
return undef unless(defined $entry->{id});
|
||||
|
||||
for my $attr (keys %$entry){
|
||||
$entry->{$attr}=~s/^\s+//g;
|
||||
$entry->{$attr}=~s/\s+$//g;
|
||||
}
|
||||
|
||||
#print STDERR Dumper(\$entry->{content});
|
||||
for my $attr ('content', 'topic'){
|
||||
if (defined $entry->{$attr}){
|
||||
$entry->{'html_'.$attr}=markup::creole_to_html($entry->{$attr});
|
||||
#$entry->{'html_'.$attr}=~s/([^\>])\n+([^\<])/$1<br\/><br\/>$2/g;
|
||||
#$entry->{'html_'.$attr}=~s/^\s*(<p>)?//g;
|
||||
#$entry->{'html_'.$attr}=~s/(<\/p>)?\s*$//g;
|
||||
}
|
||||
}
|
||||
|
||||
#print STDERR Dumper(\$entry->{html_content});
|
||||
#print STDERR "ok2\n";
|
||||
#return;
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
#return;
|
||||
#update only existing atributes
|
||||
|
||||
#TODO: double check series_name (needed for reassignment but not for editing...)
|
||||
my @keys=();
|
||||
for my $key ('series_name', 'title', 'excerpt', 'content', 'html_content',
|
||||
'user_title', 'user_excerpt', 'topic', 'html_topic',
|
||||
'episode', 'image', 'podcast_url', 'archive_url',
|
||||
'live', 'published', 'playout', 'archived', 'rerun', 'disable_event_sync',
|
||||
'modified_by'
|
||||
){
|
||||
push @keys, $key if defined $entry->{$key};
|
||||
}
|
||||
$entry->{episode}=undef if((defined $entry->{episode}) && ($entry->{episode}eq'0'));
|
||||
|
||||
my $values =join(",", map {$_.'=?'} (@keys));
|
||||
my @bind_values =map {$entry->{$_}} (@keys);
|
||||
|
||||
push @bind_values,$entry->{id};
|
||||
my $query=qq{
|
||||
update calcms_events
|
||||
set $values
|
||||
where id=?
|
||||
};
|
||||
|
||||
#print STDERR $query.Dumper(\@bind_values);
|
||||
db::put($dbh, $query, \@bind_values);
|
||||
return $entry;
|
||||
}
|
||||
|
||||
# save event time by id
|
||||
# do not check project, studio, series
|
||||
# for history handling all changed columns are returned
|
||||
sub save_event_time{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return undef unless(defined $entry->{id});
|
||||
return undef unless(defined $entry->{duration});
|
||||
return undef unless(defined $entry->{start_date});
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $event={
|
||||
id => $entry->{id},
|
||||
start => $entry->{start_date},
|
||||
end => time::add_minutes_to_datetime($entry->{start_date}, $entry->{duration})
|
||||
};
|
||||
|
||||
my $day_start=$config->{date}->{day_starting_hour};
|
||||
my $event_hour=int((split(/[\-\:\sT]/,$event->{start}))[3]);
|
||||
|
||||
my @update_columns=();
|
||||
my $bind_values=[];
|
||||
push @update_columns,'start=?';
|
||||
push @$bind_values,$event->{start};
|
||||
|
||||
push @update_columns, 'end=?';
|
||||
push @$bind_values, $event->{end};
|
||||
|
||||
# add start date
|
||||
my $start_date= time::add_hours_to_datetime($event->{start}, -$day_start);
|
||||
push @update_columns, 'start_date=?';
|
||||
push @$bind_values, $start_date;
|
||||
$event->{start_date} =$start_date;
|
||||
|
||||
# add end date
|
||||
my $end_date= time::add_hours_to_datetime($event->{end}, -$day_start);
|
||||
push @update_columns, 'end_date=?';
|
||||
push @$bind_values, $end_date;
|
||||
$event->{end_date} = $end_date;
|
||||
|
||||
my $update_columns=join(",\n", @update_columns);
|
||||
my $update_sql=qq{
|
||||
update calcms_events
|
||||
set $update_columns
|
||||
where id=?
|
||||
};
|
||||
push @$bind_values, $event->{id};
|
||||
#print STDERR $update_sql."\n".Dumper($bind_values)."\n";
|
||||
db::put($dbh, $update_sql, $bind_values);
|
||||
return $event;
|
||||
}
|
||||
|
||||
sub set_playout_status{
|
||||
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->{start};
|
||||
return undef unless defined $entry->{playout};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
# check if event is assigned to project and studio
|
||||
my $sql=qq{
|
||||
select se.event_id event_id
|
||||
from calcms_series_events se, calcms_events e
|
||||
where
|
||||
se.event_id=e.id
|
||||
and e.start=?
|
||||
and se.project_id=?
|
||||
and se.studio_id=?
|
||||
};
|
||||
my $bind_values=[$entry->{start}, $entry->{project_id}, $entry->{studio_id}];
|
||||
#print STDERR Dumper($sql).Dumper($bind_values);
|
||||
my $events=db::get($dbh, $sql, $bind_values);
|
||||
#print STDERR Dumper($events);
|
||||
return undef if scalar(@$events)!=1;
|
||||
my $event_id=$events->[0]->{event_id};
|
||||
$sql=qq{
|
||||
update calcms_events
|
||||
set playout=?
|
||||
where id=?
|
||||
and start=?
|
||||
};
|
||||
$bind_values=[$entry->{playout}, $event_id, $entry->{start}];
|
||||
#print STDERR $sql."\n".Dumper($bind_values)."\n";
|
||||
my $result=db::put($dbh, $sql, $bind_values);
|
||||
return $result;
|
||||
}
|
||||
|
||||
# is event assigned to project, studio and series?
|
||||
sub is_event_assigned{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return 0 unless defined $entry->{project_id};
|
||||
return 0 unless defined $entry->{studio_id};
|
||||
return 0 unless defined $entry->{series_id};
|
||||
return 0 unless defined $entry->{event_id};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $sql=q{
|
||||
select * from calcms_series_events
|
||||
where project_id=? and studio_id=? and series_id=? and event_id=?
|
||||
};
|
||||
my $bind_values=[$entry->{project_id}, $entry->{studio_id}, $entry->{series_id}, $entry->{event_id}];
|
||||
my $results=db::get($dbh, $sql, $bind_values);
|
||||
|
||||
return 1 if @$results>=1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub delete_event{
|
||||
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->{event_id};
|
||||
return undef unless defined $entry->{user};
|
||||
|
||||
#is event assigned to project, studio and series?
|
||||
unless(is_event_assigned($config, $entry)==1){
|
||||
print STDERR "cannot delete event with project_id=$entry->{project_id}, studio_id=$entry->{studio_id}, series_id=$entry->{series_id}, event_id=$entry->{event_id}";
|
||||
return 0;
|
||||
}
|
||||
|
||||
event_history::insert_by_event_id($config, $entry);
|
||||
|
||||
#delete the association
|
||||
series::unassign_event($config, $entry);
|
||||
|
||||
# delete the event
|
||||
my $dbh=db::connect($config);
|
||||
my $sql=q{
|
||||
delete from calcms_events
|
||||
where id=?
|
||||
};
|
||||
my $bind_values=[$entry->{event_id}];
|
||||
db::put($dbh, $sql, $bind_values);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
#check permissions
|
||||
# options: conditions (studio_id, series_id,...)
|
||||
# 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{
|
||||
my $request=shift;
|
||||
my $options=shift;
|
||||
|
||||
return "missing permission at check" unless defined $options->{permission};
|
||||
return "missing check_for at check" unless defined $options->{check_for};
|
||||
return "missing user at check" unless defined $request->{user};
|
||||
return "missing project_id at check" unless defined $options->{project_id};
|
||||
return "missing studio_id at check" unless defined $options->{studio_id};
|
||||
return "missing series_id at check" unless defined $options->{series_id};
|
||||
|
||||
my $permissions = $request->{permissions};
|
||||
my $config = $request->{config};
|
||||
|
||||
my $studio_check=studios::check($config, $options);
|
||||
return $studio_check if($studio_check ne '1');
|
||||
print STDERR "check studio ok\n";
|
||||
|
||||
my $project_check=project::check($config, $options);
|
||||
return $project_check if($project_check ne '1');
|
||||
print STDERR "check project ok\n";
|
||||
|
||||
#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');
|
||||
}
|
||||
return 'missing permission to '.$options->{permission} if $found==0;
|
||||
delete $options->{permission};
|
||||
|
||||
#convert check list to hash
|
||||
my $check={};
|
||||
for my $permission (@{$options->{check_for}}){
|
||||
$check->{$permission}=1;
|
||||
}
|
||||
delete $options->{check_for};
|
||||
|
||||
# is project assigned to studio
|
||||
return "studio is not assigned to project" unless project::is_studio_assigned($config, $options)==1;
|
||||
|
||||
#get studio names
|
||||
my $studios=studios::get($config, {
|
||||
project_id => $options->{project_id},
|
||||
studio_id => $options->{studio_id}
|
||||
});
|
||||
return "unknown studio" unless defined $studios;
|
||||
return "unknown studio" unless (@$studios==1);
|
||||
my $studio=$studios->[0];
|
||||
my $studio_name=$studio->{name}||'';
|
||||
|
||||
#get series names
|
||||
my $series=series::get($config, {
|
||||
project_id => $options->{project_id},
|
||||
studio_id => $options->{studio_id},
|
||||
series_id => $options->{series_id}
|
||||
});
|
||||
my $series_name=$series->[0]->{series_name}||'';
|
||||
$series_name.=' - '.$series->[0]->{title} if $series->[0]->{series_name} ne '';
|
||||
|
||||
#check all items from checklist
|
||||
if((defined $check->{user})&&(uac::is_user_assigned_to_studio($request, $options)==0)){
|
||||
return "User '$request->{user}' is not assigned to studio $studio_name ($options->{studio_id})";
|
||||
}
|
||||
|
||||
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})";
|
||||
}
|
||||
|
||||
# check series and can user update events
|
||||
if((defined $check->{series})&&(series::can_user_update_events($request, $options)==0)){
|
||||
return "unknown series" unless defined $series;
|
||||
return "User $request->{user} cannot update events for series '$series_name' ($options->{series_id})";
|
||||
}
|
||||
|
||||
# check series and can user create events
|
||||
if((defined $check->{create_events})&&(series::can_user_create_events($request, $options)==0)){
|
||||
return "unknown series" unless defined $series;
|
||||
return "User $request->{user} cannot create events for series '$series_name' ($options->{series_id})";
|
||||
}
|
||||
|
||||
if((defined $check->{studio_timeslots})&&(studio_timeslot_dates::can_studio_edit_events($config, $options)==0)){
|
||||
return "requested time is not assigned to studio '$studio_name' ($options->{studio_id})";
|
||||
}
|
||||
|
||||
#check if event is assigned to user,project,studio,series,location
|
||||
if(defined $check->{events}){
|
||||
return "missing event_id" unless defined $options->{event_id};
|
||||
my $result=series::is_event_assigned_to_user($request, $options);
|
||||
return $result if $result ne '1';
|
||||
}
|
||||
|
||||
# prevent editing events that are over for more than 14 days
|
||||
if(defined $check->{event_age}){
|
||||
if (series::is_event_older_than_days($config, {
|
||||
project_id => $options->{project_id},
|
||||
studio_id => $options->{studio_id},
|
||||
series_id => $options->{series_id},
|
||||
event_id => $options->{event_id},
|
||||
max_age => 14
|
||||
})==1){
|
||||
return "show is over for more than 2 weeks" unless(
|
||||
(defined $permissions->{update_event_after_week})
|
||||
&& ($permissions->{update_event_after_week} eq '1')
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
#check if schedule event exists for given date
|
||||
if(defined $check->{schedule}){
|
||||
return "unknown series" unless defined $series;
|
||||
return "missing start_at at check_permission" unless defined $options->{start_date};
|
||||
#TODO: check "is_event_scheduled" if start_at could be moved to start_date
|
||||
$options->{start_at}=$options->{start_date};
|
||||
return "No event scheduled for series '$series_name' ($options->{series_id})" if(series_dates::is_event_scheduled($request, $options)==0);
|
||||
}
|
||||
|
||||
return '1';
|
||||
}
|
||||
|
||||
#not handled, yet:
|
||||
# responsible, status, rating, podcast_url, media_url, visible, time_of_day, recurrence, reference, created_at
|
||||
# category, time_of_day,
|
||||
|
||||
#insert event
|
||||
sub insert_event{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
my $project_id = $options->{project_id};
|
||||
my $studio = $options->{studio};
|
||||
my $serie = $options->{serie};
|
||||
my $params = $options->{event};
|
||||
my $user = $options->{user};
|
||||
|
||||
return 0 unless defined $studio;
|
||||
return 0 unless defined $serie;
|
||||
return 0 unless defined $params;
|
||||
return 0 unless defined $user;
|
||||
return 0 unless defined $studio->{location};
|
||||
|
||||
my $projects=project::get($config, {project_id=>$project_id});
|
||||
if(@$projects==0){
|
||||
print STDERR "project not found at insert event\n";
|
||||
return 0;
|
||||
}
|
||||
my $projectName=$projects->[0]->{name};
|
||||
my $event={
|
||||
project => $projectName,
|
||||
location => $studio->{location}, # location from studio
|
||||
};
|
||||
#print '<pre>';
|
||||
$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'){
|
||||
$event->{$attr}=$serie->{$attr} if defined $serie->{$attr};
|
||||
}
|
||||
|
||||
#overwrite series values from parameters
|
||||
for my $attr ('program', 'series_name', 'title', 'user_title', 'excerpt', 'user_except', 'content', 'topic', 'image', 'episode', 'podcast_url', 'archive_url'){
|
||||
$event->{$attr}=$params->{$attr} if defined $params->{$attr};
|
||||
}
|
||||
$event->{'html_content'} = markup::creole_to_html($event->{'content'}) if defined $event->{'content'};
|
||||
$event->{'html_topic'} = markup::creole_to_html($event->{'topic'}) if defined $event->{'topic'};
|
||||
|
||||
#add event status
|
||||
for my $attr ('live', 'published', 'playout', 'archived', 'rerun', 'disable_event_sync'){
|
||||
$event->{$attr}=$params->{$attr}||0;
|
||||
}
|
||||
|
||||
if($serie->{has_single_events}eq'1'){
|
||||
delete $event->{series_name};
|
||||
delete $event->{episode};
|
||||
}
|
||||
|
||||
$event->{modified_at} = time::time_to_datetime(time());
|
||||
$event->{created_at} = time::time_to_datetime(time());
|
||||
$event->{modified_by} = $user;
|
||||
|
||||
#print STDERR Dumper($event);
|
||||
my $dbh=db::connect($config);
|
||||
my $event_id= db::insert($dbh, 'calcms_events', $event);
|
||||
|
||||
#add to history
|
||||
$event->{project_id}= $project_id;
|
||||
$event->{studio_id} = $studio->{id};
|
||||
$event->{series_id} = $serie->{series_id};
|
||||
$event->{event_id} = $event_id;
|
||||
event_history::insert($config, $event);
|
||||
return $event_id;
|
||||
}
|
||||
|
||||
|
||||
#set start, end, start-date, end_date to an event
|
||||
sub add_event_dates{
|
||||
my $config =shift;
|
||||
my $event =shift;
|
||||
my $params =shift;
|
||||
|
||||
#start and end datetime
|
||||
$event->{start} = $params->{start_date};
|
||||
$event->{end} = time::add_minutes_to_datetime($params->{start_date}, $params->{duration});
|
||||
|
||||
#set program days
|
||||
my $day_start=$config->{date}->{day_starting_hour};
|
||||
$event->{start_date} = time::date_cond(time::add_hours_to_datetime($event->{start}, -$day_start));
|
||||
$event->{end_date} = time::date_cond(time::add_hours_to_datetime($event->{end}, -$day_start));
|
||||
return $event;
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
183
lib/calcms/series_schedule.pm
Normal file
183
lib/calcms/series_schedule.pm
Normal file
@@ -0,0 +1,183 @@
|
||||
package series_schedule;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use series_dates;
|
||||
|
||||
# table: calcms_series_schedule
|
||||
# columns: id, studio_id, series_id,
|
||||
# start (datetime),
|
||||
# duration (minutes),
|
||||
# frequency (days),
|
||||
# end (date),
|
||||
# weekday (1..7)
|
||||
# week_of_month (1..5)
|
||||
# month
|
||||
# nextDay (add 24 hours to start)
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get insert update delete);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#map schedule id to id
|
||||
sub get{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{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_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->{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};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_series_schedule
|
||||
$conditions
|
||||
order by exclude, start
|
||||
};
|
||||
#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};
|
||||
}
|
||||
#print STDERR Dumper($entries);
|
||||
return $entries;
|
||||
}
|
||||
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
#schedule id to id
|
||||
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};
|
||||
|
||||
$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);
|
||||
|
||||
push @bind_values,$entry->{project_id};
|
||||
push @bind_values,$entry->{studio_id};
|
||||
push @bind_values,$entry->{id};
|
||||
|
||||
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";
|
||||
}
|
||||
|
||||
#map schedule id to id
|
||||
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};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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}];
|
||||
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
|
||||
db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
32
lib/calcms/startup.pl
Normal file
32
lib/calcms/startup.pl
Normal file
@@ -0,0 +1,32 @@
|
||||
use lib qw(/home/calcms/lib/calcms/);
|
||||
|
||||
return 1;
|
||||
#use B::TerseSize
|
||||
|
||||
#load mod_perl modules
|
||||
#use Apache2;
|
||||
#use ModPerl::RegistryPrefork;
|
||||
#use Apache::compat;
|
||||
|
||||
#on upload CGI open of tmpfile: Permission denied
|
||||
#use CGI;
|
||||
|
||||
#load common used modules
|
||||
#use Data::Dumper;
|
||||
#use DBI;
|
||||
use Apache::DBI;
|
||||
#$Apache::DBI::DEBUG = 2;
|
||||
|
||||
use Time::Local;
|
||||
use Date::Calc;
|
||||
use Calendar::Simple qw(date_span);
|
||||
|
||||
use config;
|
||||
use log;
|
||||
use time;
|
||||
use db;
|
||||
use cache;
|
||||
use template;
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
434
lib/calcms/studio_timeslot_dates.pm
Normal file
434
lib/calcms/studio_timeslot_dates.pm
Normal file
@@ -0,0 +1,434 @@
|
||||
package studio_timeslot_dates;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use Date::Calc;
|
||||
use time;
|
||||
|
||||
# schedule dates for calcms_studio_schedule
|
||||
# table: calcms_studio_timeslot_dates
|
||||
# columns: id, studio_id, start(datetime), end(datetime)
|
||||
# TODO: delete column schedule_id
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get insert update delete get_dates);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_studio_timeslot_dates');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $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{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $date_range_include=0;
|
||||
$date_range_include=1 if $condition->{date_range_include}==1;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{schedule_id}) && ($condition->{schedule_id} ne '')){
|
||||
push @conditions, 'schedule_id=?';
|
||||
push @bind_values, $condition->{schedule_id};
|
||||
}
|
||||
|
||||
# from and till range from an event should beween start and end of the studio's permission
|
||||
if ((defined $condition->{start}) && ($condition->{start} ne '')){
|
||||
push @conditions, 'start<=?';
|
||||
push @bind_values, $condition->{start};
|
||||
}
|
||||
|
||||
if ((defined $condition->{end}) && ($condition->{end} ne '')){
|
||||
push @conditions, 'end>=?';
|
||||
push @bind_values, $condition->{end};
|
||||
}
|
||||
|
||||
# check only a given date date range (without time)
|
||||
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};
|
||||
}
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select date(start) start_date
|
||||
,date(end) end_date
|
||||
,dayname(start) start_weekday
|
||||
,dayname(end) end_weekday
|
||||
,start_date day
|
||||
,start
|
||||
,end
|
||||
,schedule_id
|
||||
,studio_id
|
||||
|
||||
from calcms_studio_timeslot_dates
|
||||
$conditions
|
||||
order by start
|
||||
};
|
||||
#print STDERR $query."\n";
|
||||
#print STDERR Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
for my $entry (@$entries){
|
||||
$entry->{start_weekday}=substr($entry->{start_weekday},0,2);
|
||||
$entry->{end_weekday}=substr($entry->{end_weekday},0,2);
|
||||
}
|
||||
#print STDERR Dumper($entries);
|
||||
return $entries;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#get all studio_timeslot_schedules for studio_id and update studio_timeslot_dates
|
||||
sub update{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return undef unless(defined $entry->{schedule_id});
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
#delete all dates for schedule id
|
||||
studio_timeslot_dates::delete($config, $entry);
|
||||
|
||||
my $day_start=$config->{date}->{day_starting_hour};
|
||||
|
||||
#get the schedule with schedule id ordered by date
|
||||
my $schedules=studio_timeslot_schedule::get($config, {
|
||||
schedule_id => $entry->{schedule_id}
|
||||
});
|
||||
#add scheduled dates
|
||||
my $i=0;
|
||||
my $dates={};
|
||||
for my $schedule (@$schedules){
|
||||
#calculate dates from start to end_date
|
||||
my $dateList=get_dates($schedule->{start}, $schedule->{end}, $schedule->{end_date}, $schedule->{frequency});
|
||||
#print STDERR Dumper($dateList);
|
||||
for my $date (@$dateList){
|
||||
#set studio i from
|
||||
$date->{project_id} = $schedule->{project_id};
|
||||
$date->{studio_id} = $schedule->{studio_id};
|
||||
$date->{schedule_id} = $schedule->{schedule_id};
|
||||
$dates->{$date->{start}.$date->{studio_id}}=$date;
|
||||
}
|
||||
}
|
||||
|
||||
for my $date (keys %$dates){
|
||||
my $timeslot_date=$dates->{$date};
|
||||
#insert date
|
||||
my $entry={
|
||||
project_id => $timeslot_date->{project_id},
|
||||
studio_id => $timeslot_date->{studio_id},
|
||||
schedule_id => $timeslot_date->{schedule_id},
|
||||
start => $timeslot_date->{start},
|
||||
end => $timeslot_date->{end},
|
||||
};
|
||||
$entry->{start_date}= time::add_hours_to_datetime($entry->{start}, -$day_start);
|
||||
$entry->{end_date}= time::add_hours_to_datetime($entry->{end}, -$day_start);
|
||||
db::insert($dbh, 'calcms_studio_timeslot_dates', $entry);
|
||||
#print STDERR "$entry->{start_date}\n";
|
||||
$i++;
|
||||
}
|
||||
#print STDERR "$i studio_timeslot_dates updates\n";
|
||||
return $i;
|
||||
}
|
||||
|
||||
# calculate all start/end datetimes between start_date and stop_date with a frequency(days)
|
||||
# returns list of hashs with start and end
|
||||
sub get_dates{
|
||||
my $start_datetime = shift; # start
|
||||
my $end_datetime = shift; # start
|
||||
my $stop_date = shift; # limit recurring events
|
||||
my $frequency = shift; # in days
|
||||
|
||||
my @start = @{time::datetime_to_array($start_datetime)};
|
||||
return unless @start>=6;
|
||||
my @start_date = ($start[0], $start[1], $start[2]);
|
||||
my $start_date = sprintf("%04d-%02d-%02d",@start_date);
|
||||
my $start_time = sprintf('%02d:%02d:%02d', $start[3], $start[4], $start[5]);
|
||||
|
||||
my @end = @{time::datetime_to_array($end_datetime)};
|
||||
return unless @end>=6;
|
||||
my @end_date = ($end[0], $end[1], $end[2]);
|
||||
my $end_date = sprintf("%04d-%02d-%02d",@end_date);
|
||||
my $end_time = sprintf('%02d:%02d:%02d', $end[3], $end[4], $end[5]);
|
||||
|
||||
my @stop = @{time::date_to_array($stop_date)};
|
||||
return unless @end>=3;
|
||||
my @stop_date = ($stop[0], $stop[1], $stop[2]);
|
||||
$stop_date = sprintf("%04d-%02d-%02d",@stop_date);
|
||||
|
||||
my $date={};
|
||||
$date->{start}= $start_date.' '.$start_time;
|
||||
$date->{end} = $end_date.' '.$end_time;
|
||||
|
||||
my $dates=[];
|
||||
return $dates if ($date->{end} le $date->{start});
|
||||
|
||||
return $dates if ($stop_date lt $end_date);
|
||||
|
||||
my $j = Date::Calc::Delta_Days(@start_date, @stop_date);
|
||||
return $dates if $j<0;
|
||||
|
||||
# split full time events into single days
|
||||
if($frequency<1){
|
||||
#start day
|
||||
my @next_date = Date::Calc::Add_Delta_Days($start[0], $start[1], $start[2], 1);
|
||||
my $next_date = sprintf("%04d-%02d-%02d",@next_date);
|
||||
push @$dates,{
|
||||
start => $start_date.' '.$start_time,
|
||||
end => $next_date .' 00:00:00',
|
||||
};
|
||||
my $c=0;
|
||||
for (my $i = 1; $i < $j; $i++){
|
||||
my @start_date = Date::Calc::Add_Delta_Days($start[0], $start[1], $start[2], $i);
|
||||
my $start_date = sprintf("%04d-%02d-%02d",@start_date);
|
||||
my @next_date = Date::Calc::Add_Delta_Days($start[0], $start[1], $start[2], $i+1);
|
||||
my $next_date = sprintf("%04d-%02d-%02d",@next_date);
|
||||
push @$dates,{
|
||||
start => $start_date.' 00:00:00',
|
||||
end => $next_date.' 00:00:00',
|
||||
};
|
||||
last if ($c>1000);
|
||||
$c++;
|
||||
}
|
||||
#end day
|
||||
push @$dates,{
|
||||
start => $end_date.' 00:00:00',
|
||||
end => $end_date.' '.$end_time,
|
||||
} if($end_time ne '00:00:00');
|
||||
return $dates;
|
||||
}
|
||||
|
||||
# multiple time events
|
||||
my $c=0;
|
||||
for (my $i = 0; $i <= $j; $i+=$frequency ){
|
||||
#add frequency to start and end date
|
||||
my @start_date = Date::Calc::Add_Delta_Days($start[0], $start[1], $start[2], $i);
|
||||
my @end_date = Date::Calc::Add_Delta_Days($end[0], $end[1], $end[2], $i);
|
||||
#print STDERR Dumper(\@start_date);
|
||||
#print STDERR Dumper(\@end_date);
|
||||
my $start_date=sprintf("%04d-%02d-%02d",@start_date);
|
||||
my $end_date =sprintf("%04d-%02d-%02d",@end_date);
|
||||
push @$dates,{
|
||||
start => $start_date.' '.$start_time,
|
||||
end => $end_date.' '.$end_time,
|
||||
};
|
||||
last if ($c>1000);
|
||||
$c++;
|
||||
}
|
||||
return $dates;
|
||||
}
|
||||
|
||||
#remove all studio_timeslot_dates for studio_id and schedule_id
|
||||
sub delete{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
#print STDERR "delete:".Dumper($entry);
|
||||
return unless(defined $entry->{project_id});
|
||||
return unless(defined $entry->{studio_id});
|
||||
return unless(defined $entry->{schedule_id});
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_studio_timeslot_dates
|
||||
where schedule_id=?
|
||||
};
|
||||
my $bind_values=[$entry->{schedule_id}];
|
||||
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
|
||||
db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
# time based filter to check if studio is assigned to an studio at a given time range
|
||||
# return 1 if there is a schedule date starting before start and ending after end
|
||||
sub can_studio_edit_events{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
#print Dumper($condition);
|
||||
|
||||
#return 0 unless defined $condition->{project_id};
|
||||
return 0 unless defined $condition->{studio_id};
|
||||
return 0 unless defined $condition->{start};
|
||||
return 0 unless defined $condition->{end};
|
||||
|
||||
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->{start}) && ($condition->{start} ne '')){
|
||||
push @conditions, 'start<=?';
|
||||
push @bind_values, $condition->{start};
|
||||
}
|
||||
|
||||
if ((defined $condition->{end}) && ($condition->{end} ne '')){
|
||||
push @conditions, 'end>=?';
|
||||
push @bind_values, $condition->{end};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $query=qq{
|
||||
select count(*) permission
|
||||
from calcms_studio_timeslot_dates
|
||||
$conditions
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
#print STDERR Dumper($entries);
|
||||
return 0 if scalar(@$entries) == 0;
|
||||
return 1 if $entries->[0]->{permission}>0;
|
||||
|
||||
if ($entries->[0]->{permission}==0){
|
||||
my $timeslot=getMergedDays($config, $condition);
|
||||
return 0 unless defined $timeslot;
|
||||
if (
|
||||
($condition->{start} ge $timeslot->{start})
|
||||
&& ($condition->{end} le $timeslot->{end})
|
||||
){
|
||||
#print STDERR "($condition->{start} ge $timeslot->{start}) ".($condition->{start} ge $timeslot->{start});
|
||||
#print STDERR "($condition->{end} le $timeslot->{end}) ".($condition->{end} le $timeslot->{end});
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
# merge two subsequent days if first day ends at same time as next day starts
|
||||
# returns hashref with start and end of merged slot
|
||||
# returns undef if not slot could be found
|
||||
sub getMergedDays{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
#print Dumper($condition);
|
||||
|
||||
#return 0 unless defined $condition->{project_id};
|
||||
return 0 unless defined $condition->{studio_id};
|
||||
return 0 unless defined $condition->{start};
|
||||
return 0 unless defined $condition->{end};
|
||||
|
||||
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};
|
||||
}
|
||||
|
||||
# set start to next day at 00:00
|
||||
my $start=undef;
|
||||
if ($condition->{start}=~/(\d\d\d\d\-\d\d\-\d\d)/){
|
||||
$start=$1.' 00:00';
|
||||
$start=time::add_days_to_datetime($start, 1);
|
||||
push @bind_values, $start;
|
||||
}
|
||||
|
||||
# set end to end days at 00:00
|
||||
my $end=undef;
|
||||
if ($condition->{end}=~/(\d\d\d\d\-\d\d\-\d\d)/){
|
||||
$end=$1.' 00:00';
|
||||
push @bind_values, $end;
|
||||
}
|
||||
return undef unless defined $start;
|
||||
return undef unless defined $end;
|
||||
|
||||
push @conditions, '(start=? or end=?)';
|
||||
|
||||
my $conditions='';
|
||||
$conditions='where '.join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
# get all days starting on first day or ending at next day
|
||||
my $dbh=db::connect($config);
|
||||
my $query=qq{
|
||||
select start, end
|
||||
from calcms_studio_timeslot_dates
|
||||
$conditions
|
||||
order by start
|
||||
};
|
||||
# print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
# print STDERR Dumper($entries);
|
||||
|
||||
if (scalar(@$entries)==2){
|
||||
if ($entries->[0]->{end} eq $entries->[1]->{start}){
|
||||
$entries={
|
||||
start => $entries->[0]->{start},
|
||||
end => $entries->[1]->{end}
|
||||
};
|
||||
# print STDERR "found".Dumper($entries)."\n";
|
||||
return $entries;
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
144
lib/calcms/studio_timeslot_schedule.pm
Normal file
144
lib/calcms/studio_timeslot_schedule.pm
Normal file
@@ -0,0 +1,144 @@
|
||||
package studio_timeslot_schedule;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use studio_timeslot_dates;
|
||||
|
||||
# table: calcms_studio_timeslot_schedule
|
||||
# columns: id, project_id, studio_id, start(datetime), end(datetime), end_date(date),
|
||||
# frequency(days), duration(minutes), create_events(days), publish_events(days)
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get insert update delete);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_studio_timeslot_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;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{schedule_id}) && ($condition->{schedule_id} ne '')){
|
||||
push @conditions, 'id=?';
|
||||
push @bind_values, $condition->{schedule_id};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_studio_timeslot_schedule
|
||||
$conditions
|
||||
order by start
|
||||
};
|
||||
#print $query."\n";
|
||||
#print Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
for my $entry (@$entries){
|
||||
$entry->{schedule_id}=$entry->{id};
|
||||
delete $entry->{id};
|
||||
}
|
||||
return $entries;
|
||||
}
|
||||
|
||||
sub insert{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return unless(defined $entry->{project_id});
|
||||
return unless(defined $entry->{studio_id});
|
||||
return unless(defined $entry->{start});
|
||||
return unless(defined $entry->{end});
|
||||
return unless(defined $entry->{frequency});
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
return db::insert($dbh, 'calcms_studio_timeslot_schedule', $entry);
|
||||
}
|
||||
|
||||
#schedule id to id
|
||||
sub update{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return unless(defined $entry->{project_id});
|
||||
return unless(defined $entry->{studio_id});
|
||||
return unless(defined $entry->{schedule_id});
|
||||
return unless(defined $entry->{start});
|
||||
return unless(defined $entry->{end});
|
||||
return unless(defined $entry->{frequency});
|
||||
|
||||
$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);
|
||||
push @bind_values,$entry->{id};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_studio_timeslot_schedule
|
||||
set $values
|
||||
where id=?
|
||||
};
|
||||
db::put($dbh, $query, \@bind_values);
|
||||
#print "done\n";
|
||||
|
||||
$entry->{schedule_id}=$entry->{id};
|
||||
delete $entry->{id};
|
||||
|
||||
}
|
||||
|
||||
#map schedule id to id
|
||||
sub delete{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return unless(defined $entry->{schedule_id});
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_studio_timeslot_schedule
|
||||
where id=?
|
||||
};
|
||||
my $bind_values=[$entry->{schedule_id}];
|
||||
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
|
||||
db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
158
lib/calcms/studios.pm
Normal file
158
lib/calcms/studios.pm
Normal file
@@ -0,0 +1,158 @@
|
||||
#!/bin/perl
|
||||
|
||||
use CGI;
|
||||
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
|
||||
use CGI::Session qw(-ip-match);
|
||||
use CGI::Cookie;
|
||||
#$CGI::Session::IP_MATCH=1;
|
||||
|
||||
package studios;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get get_by_id insert update delete check check_studio);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_studios');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $columns;
|
||||
}
|
||||
|
||||
sub get{
|
||||
my $config=shift;
|
||||
my $condition=shift||{};
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $condition->{studio_id}) && ($condition->{studio_id} ne '')){
|
||||
push @conditions, 's.id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{name}) && ($condition->{name} ne '')){
|
||||
push @conditions, 's.name=?';
|
||||
push @bind_values, $condition->{name};
|
||||
}
|
||||
|
||||
my $limit='';
|
||||
if ((defined $condition->{limit}) && ($condition->{limit} ne '')){
|
||||
$limit= 'limit '.$condition->{limit};
|
||||
}
|
||||
|
||||
my $query='';
|
||||
unless ((defined $condition->{project_id}) && ($condition->{project_id} ne '')){
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
$query=qq{
|
||||
select *
|
||||
from calcms_studios s
|
||||
$conditions
|
||||
$limit
|
||||
};
|
||||
}else{
|
||||
push @conditions, 's.id=ps.studio_id';
|
||||
|
||||
push @conditions, 'ps.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
my $conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
$query=qq{
|
||||
select *
|
||||
from calcms_studios s, calcms_project_studios ps
|
||||
$conditions
|
||||
$limit
|
||||
};
|
||||
}
|
||||
my $dbh=db::connect($config);
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
my $studios=db::get($dbh, $query,\@bind_values);
|
||||
return $studios;
|
||||
}
|
||||
|
||||
sub insert{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
$entry->{created_at} = time::time_to_datetime(time());
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $id=db::insert($dbh, 'calcms_studios', $entry);
|
||||
return $id;
|
||||
}
|
||||
|
||||
|
||||
sub update{
|
||||
my $config=shift;
|
||||
my $studio=shift;
|
||||
|
||||
$studio->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $columns=get_columns($config);
|
||||
my $entry={};
|
||||
for my $column (keys %$columns){
|
||||
$entry->{$column}=$studio->{$column} if defined $studio->{$column};
|
||||
}
|
||||
|
||||
my $values =join(",", map {$_.'=?'} (keys %$entry));
|
||||
my @bind_values =map {$entry->{$_}} (keys %$entry);
|
||||
push @bind_values,$entry->{id};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_studios
|
||||
set $values
|
||||
where id=?
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
db::put($dbh, $query, \@bind_values);
|
||||
}
|
||||
|
||||
sub delete{
|
||||
my $config=shift;
|
||||
my $studio=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
db::put($dbh, 'delete from calcms_studios where id=?', [$studio->{id}]);
|
||||
}
|
||||
|
||||
#TODO rename to check
|
||||
sub check_studio{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
return check($config, $options);
|
||||
}
|
||||
|
||||
sub check{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
return "missing studio_id" unless defined $options->{studio_id};
|
||||
return "Please select a studio" if($options->{studio_id}eq'-1');
|
||||
return "Please select a studio" if($options->{studio_id}eq'');
|
||||
my $studios=studios::get($config, {studio_id => $options->{studio_id}});
|
||||
return "Sorry. unknown studio" unless defined $studios;
|
||||
return "Sorry. unknown studio" unless @$studios==1;
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
|
||||
24
lib/calcms/tags.pm
Normal file
24
lib/calcms/tags.pm
Normal file
@@ -0,0 +1,24 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
package tags;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_tags);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub get_tags{
|
||||
my $dbh=shift;
|
||||
my $query=qq{
|
||||
select name, count(name) sum from calcms_tags
|
||||
group by name
|
||||
order by sum desc
|
||||
};
|
||||
my $tags=db::get($dbh,$query);
|
||||
return $tags;
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
227
lib/calcms/template.pm
Normal file
227
lib/calcms/template.pm
Normal file
@@ -0,0 +1,227 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
|
||||
package template;
|
||||
use Data::Dumper;
|
||||
use HTML::Template::Compiled;
|
||||
use HTML::Template::Compiled::Plugin::XMLEscape;
|
||||
use JSON;
|
||||
use Cwd;
|
||||
|
||||
use config;
|
||||
use params;
|
||||
use project;
|
||||
use log;
|
||||
use roles;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
#our @EXPORT = qw(all);
|
||||
our @EXPORT_OK = qw(check process exit_on_missing_permission clear_cache);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub process{
|
||||
# my $output=$_[0];
|
||||
my $filename=$_[1];
|
||||
my $params=$_[2];
|
||||
|
||||
my $config=$config::config;
|
||||
for my $key (keys %{$config::config->{locations}}){
|
||||
$params->{$key} =$config::config->{locations}->{$key} if ($key=~/\_url$/);
|
||||
}
|
||||
|
||||
# add current project
|
||||
unless (defined $params->{project_title}){
|
||||
my $projects = project::get_with_dates($config, { name => $config->{project} });
|
||||
if (@$projects==1){
|
||||
my $project= $projects->[0];
|
||||
foreach my $key (keys %$project){
|
||||
$params->{'project_'.$key}=$project->{$key};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$params->{user}=$ENV{REMOTE_USER} unless defined $params->{user};
|
||||
|
||||
my $user_permissions=roles::get_user_permissions();
|
||||
for my $permission (keys %$user_permissions){
|
||||
$params->{$permission}=$user_permissions->{$permission} if ($user_permissions->{$permission} eq '1');
|
||||
}
|
||||
|
||||
$params->{jobs}=roles::get_user_jobs();
|
||||
|
||||
log::write($config, 'template',$params) if ($config::config->{system}->{debug}>0);
|
||||
# my $html_template = HTML::Template->new(
|
||||
# filename => $filename,
|
||||
# die_on_bad_params =>0,
|
||||
## cache =>1,
|
||||
## cache_debug => 1
|
||||
# );
|
||||
|
||||
|
||||
if (($filename =~/json\-p/) || (params::isJson)){
|
||||
my $header="Content-type:application/json; charset=utf-8\n\n";
|
||||
my $json=to_json($params, {pretty => 1});
|
||||
# $json=$header.$params->{json_callback}.'['.$json.']';
|
||||
$json=$header.$params->{json_callback}.$json;
|
||||
if((defined $_[0]) && ($_[0]eq'print')){
|
||||
print $json."\n";
|
||||
}else{
|
||||
$_[0]= $json."\n";
|
||||
}
|
||||
return;
|
||||
}
|
||||
#print STDERR $filename."\n";
|
||||
log::error($config, "cannot find template $filename ") unless -e $filename;
|
||||
log::error($config, "cannot read template $filename ") unless -r $filename;
|
||||
|
||||
my $default_escape='0';
|
||||
$default_escape='JS' if ($filename=~/\.js$/);
|
||||
$default_escape='JS' if ($filename=~/\.json$/);
|
||||
$default_escape='HTML_ALL' if ($filename=~/\.html$/);
|
||||
|
||||
my $html_template=undef;
|
||||
|
||||
unless ($filename=~/\.xml$/){
|
||||
$html_template = HTML::Template::Compiled->new(
|
||||
filename => $filename,
|
||||
die_on_bad_params => 0,
|
||||
case_sensitive => 0,
|
||||
loop_context_vars => 0,
|
||||
global_vars => 0,
|
||||
tagstyle => '-asp -comment',
|
||||
default_escape => $default_escape,
|
||||
cache => 0,
|
||||
utf8 => 1,
|
||||
);
|
||||
}else{
|
||||
$html_template = HTML::Template::Compiled->new(
|
||||
filename => $filename,
|
||||
die_on_bad_params => 0,
|
||||
case_sensitive => 1,
|
||||
loop_context_vars => 0,
|
||||
global_vars => 0,
|
||||
tagstyle => '-asp -comment',
|
||||
default_escape => 'XML',
|
||||
plugin => [qw(HTML::Template::Compiled::Plugin::XMLEscape)],
|
||||
utf8 => 1
|
||||
);
|
||||
}
|
||||
|
||||
#$params=
|
||||
setRelativeUrls($params,0) unless (defined $params->{extern}) && ($params->{extern} eq '1');
|
||||
|
||||
# HTML::Template::Compiled->preload($cache_dir);
|
||||
$html_template->param($params);
|
||||
if((defined $_[0]) && ($_[0]eq'print')){
|
||||
print $html_template->output;
|
||||
}else{
|
||||
$_[0]=$html_template->output;
|
||||
}
|
||||
}
|
||||
|
||||
# set relative urls in nested params structure
|
||||
sub setRelativeUrls{
|
||||
my $params=shift;
|
||||
my $depth=shift || 0;
|
||||
|
||||
#print STDERR "setRelativeUrls depth:$depth ".ref($params)."\n";
|
||||
|
||||
return unless defined $params;
|
||||
|
||||
if ($depth>10){
|
||||
print STDERR "prevent deep recursion in template::setRelativeUrls()\n";
|
||||
return ;
|
||||
}
|
||||
|
||||
# set recursive for hash
|
||||
if (ref($params) eq 'HASH'){
|
||||
for my $key (keys %$params){
|
||||
#next unless ($key eq 'icon') || ($key eq 'thumb');
|
||||
my $val=$params->{$key};
|
||||
next unless defined $val;
|
||||
if (ref($val) eq ''){
|
||||
# make link relative
|
||||
$params->{$key} =~s/^https?\:(\/\/[^\/]+)/$1/;
|
||||
}elsif ( (ref($val) eq 'HASH') || (ref($val) eq 'ARRAY') ){
|
||||
setRelativeUrls($params->{$key}, $depth+1);
|
||||
}
|
||||
}
|
||||
return $params;
|
||||
}
|
||||
|
||||
# set recursive for arrays
|
||||
if (ref($params) eq 'ARRAY'){
|
||||
for my $i (0..@$params){
|
||||
my $val=$params->[$i];
|
||||
next unless defined $val;
|
||||
if ( (ref($val) eq 'HASH') || (ref($val) eq 'ARRAY') ){
|
||||
setRelativeUrls($params->[$i], $depth+1);
|
||||
}
|
||||
}
|
||||
return $params;
|
||||
}
|
||||
|
||||
return $params;
|
||||
}
|
||||
|
||||
#requires read config
|
||||
sub check{
|
||||
my $template=shift||'';
|
||||
my $default=shift;
|
||||
|
||||
if($template =~/json\-p/){
|
||||
$template=~s/[^a-zA-Z0-9\-\_\.]//g;
|
||||
$template=~s/\.{2,99}/\./g;
|
||||
return $template;
|
||||
}
|
||||
|
||||
my $config=$config::config;
|
||||
if ($template eq''){
|
||||
$template=$default;
|
||||
}else{
|
||||
$template=~s/^\.\///gi;
|
||||
#template does use ';' in filename
|
||||
log::error($config, 'invalid template!') if ($template=~/;/);
|
||||
#template does use '..' in filename
|
||||
log::error($config, 'invalid template!') if ($template=~/\.\./);
|
||||
}
|
||||
#print STDERR $config::config->{cache}->{compress}."<.compres default:$template\n";
|
||||
$template=(split(/\//,$template))[-1];
|
||||
my $cwd=getcwd();
|
||||
|
||||
$template.='.html' unless ($template=~/\./);
|
||||
if (($config::config->{cache}->{compress}eq'1') && (-e $cwd.'/templates/compressed/'.$template)){
|
||||
$template=$cwd.'/templates/compressed/'.$template;
|
||||
}elsif (-e $cwd.'/templates/'.$template){
|
||||
$template=$cwd.'/templates/'.$template;
|
||||
}else{
|
||||
log::error($config, "template not found: '$cwd/$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 $permission=shift;
|
||||
my $user_permissions=roles::get_user_permissions();
|
||||
if ($user_permissions->{$permission} ne '1'){
|
||||
print STDERR "missing permission to $permission\n";
|
||||
template::process('print', template::check('default.html'), {error => 'sorry, missing permission!'});
|
||||
die();
|
||||
#exit;
|
||||
}
|
||||
}
|
||||
|
||||
sub clear_cache{
|
||||
HTML::Template::Compiled->clear_cache();
|
||||
# return;
|
||||
# my $html_template = HTML::Template::Compiled->new();
|
||||
# $html_template->clear_cache();
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
586
lib/calcms/time.pm
Normal file
586
lib/calcms/time.pm
Normal file
@@ -0,0 +1,586 @@
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Time::Local;
|
||||
use DateTime;
|
||||
use Date::Calc;
|
||||
use Date::Manip;
|
||||
use POSIX qw(strftime);
|
||||
use config;
|
||||
|
||||
package time;
|
||||
use Data::Dumper;
|
||||
use utf8;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
format_datetime format_time
|
||||
date_format time_format
|
||||
datetime_to_time time_to_datetime time_to_date
|
||||
datetime_to_date
|
||||
add_days_to_datetime add_hours_to_datetime add_minutes_to_datetime
|
||||
add_days_to_date
|
||||
datetime_to_array date_to_array array_to_date array_to_datetime array_to_time array_to_time_hm
|
||||
date_cond time_cond check_date check_time check_datetime check_year_month
|
||||
datetime_to_rfc822 get_datetime datetime_to_utc datetime_to_utc_datetime
|
||||
get_duration get_duration_seconds
|
||||
get_durations get_names get_all_names get_weekdays weekday_index
|
||||
$names
|
||||
);
|
||||
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
our $names={
|
||||
'de' =>{
|
||||
months =>['Januar','Februar','März','April','Mai','Juni','Juli','August','September','Oktober','November','Dezember'],
|
||||
months_abbr =>['Jan','Feb','Mär','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Dez'],
|
||||
weekdays =>['Montag','Dienstag','Mittwoch','Donnerstag','Freitag','Samstag','Sonntag'],
|
||||
weekdays_abbr =>['Mo','Di','Mi','Do','Fr','Sa','So'],
|
||||
},
|
||||
'en' =>{
|
||||
months =>['January','February','March','April','May','June','Jule','August','September','October','November','December'],
|
||||
months_abbr =>['Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'],
|
||||
weekdays =>['Monday','Tuesday','Wednesday','Thursday','Friday','Saturday','Sunday'],
|
||||
weekdays_abbr =>['Mo','Tu','We','Th','Fr','Sa','Su'],
|
||||
},
|
||||
};
|
||||
|
||||
our $durations=[
|
||||
0, 5,10,15,20,30,40,45,50,60,70,75,80,90,100,105,110,115,120,135,150,165,180,195,210,225,240,300,360,420,480,540,600,660,720,1440
|
||||
];
|
||||
|
||||
sub get_names{
|
||||
my $language=shift||'en';
|
||||
return $time::names->{$language};
|
||||
}
|
||||
|
||||
sub get_all_names{
|
||||
return $time::names;
|
||||
}
|
||||
|
||||
sub get_durations{
|
||||
return $time::durations;
|
||||
}
|
||||
|
||||
#TODO: build from datenames
|
||||
our $weekday_index={
|
||||
'0' => 0,
|
||||
'1' => 1,
|
||||
'2' => 2,
|
||||
'3' => 3,
|
||||
'4' => 4,
|
||||
'5' => 5,
|
||||
'6' => 6,
|
||||
'Mo'=> 0,
|
||||
'Tu'=> 1,
|
||||
'Di'=> 1,
|
||||
'We'=> 2,
|
||||
'Mi'=> 2,
|
||||
'Th'=> 3,
|
||||
'Do'=> 3,
|
||||
'Fr'=> 4,
|
||||
'Sa'=> 5,
|
||||
'Su'=> 6,
|
||||
'So'=> 6
|
||||
};
|
||||
|
||||
sub get_weekdays{
|
||||
return{
|
||||
0 => 0,
|
||||
1 => 1,
|
||||
2 => 2,
|
||||
3 => 3,
|
||||
4 => 4,
|
||||
5 => 5,
|
||||
6 => 6,
|
||||
'Mo'=>0,
|
||||
'Tu'=>1,
|
||||
'Di'=>1,
|
||||
'We'=>2,
|
||||
'Mi'=>2,
|
||||
'Th'=>3,
|
||||
'Do'=>3,
|
||||
'Fr'=>4,
|
||||
'Sa'=>5,
|
||||
'Su'=>6,
|
||||
'So'=>6
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
#deprecated, for wordpress sync
|
||||
sub format_datetime{
|
||||
my $datetime=shift;
|
||||
return $datetime if ($datetime eq '');
|
||||
return add_hours_to_datetime($datetime,0);
|
||||
};
|
||||
|
||||
#deprecated
|
||||
sub format_time{
|
||||
my $t=$_[0];
|
||||
|
||||
my $year =$t->[5]+1900;
|
||||
my $month =$t->[4]+1;
|
||||
$month ='0'.$month if(length($month)==1);
|
||||
|
||||
my $day =$t->[3];
|
||||
$day ='0'.$day if(length($day)==1);
|
||||
|
||||
|
||||
my $hour =$t->[2];
|
||||
$hour ='0'.$hour if(length($hour)==1);
|
||||
|
||||
my $minute =$t->[1];
|
||||
$minute ='0'.$minute if(length($minute)==1);
|
||||
|
||||
return [$day,$month,$year,$hour,$minute];
|
||||
};
|
||||
|
||||
|
||||
# convert datetime to unix time
|
||||
sub datetime_to_time{
|
||||
my $datetime=$_[0];
|
||||
# print $datetime."\n";
|
||||
if ($datetime=~/(\d\d\d\d)\-(\d+)\-(\d+)[T\s](\d+)\:(\d+)(\:(\d+))?/){
|
||||
my $year=$1;
|
||||
my $month=$2-1;
|
||||
my $day=$3;
|
||||
my $hour=$4;
|
||||
my $minute=$5;
|
||||
my $second=$8||0;
|
||||
return Time::Local::timelocal($second,$minute,$hour,$day,$month,$year);
|
||||
|
||||
}else{
|
||||
print STDERR "datetime_to_time: no valid date time found! ($datetime )\n";
|
||||
return -1;
|
||||
}
|
||||
};
|
||||
|
||||
#get rfc822 datetime string from datetime string
|
||||
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{
|
||||
my $datetime=shift;
|
||||
my $time_zone=shift;
|
||||
$datetime=get_datetime($datetime, $time_zone);
|
||||
return $datetime->epoch();
|
||||
}
|
||||
|
||||
# get full utc datetime including timezone offset
|
||||
sub datetime_to_utc_datetime{
|
||||
my $datetime=shift;
|
||||
my $time_zone=shift;
|
||||
$datetime=get_datetime($datetime, $time_zone);
|
||||
return $datetime->format_cldr("yyyy-MM-ddTHH:mm:ssZZZZZ");
|
||||
}
|
||||
|
||||
|
||||
|
||||
#add hours to datetime string
|
||||
sub add_hours_to_datetime{
|
||||
my $datetime=shift;
|
||||
my $hours=shift;
|
||||
return time_to_datetime(datetime_to_time($datetime)+(3600*$hours));
|
||||
};
|
||||
|
||||
#add minutes to datetime string
|
||||
sub add_minutes_to_datetime{
|
||||
my $datetime=shift;
|
||||
my $minutes=shift;
|
||||
return time_to_datetime(datetime_to_time($datetime)+(60*$minutes));
|
||||
};
|
||||
|
||||
#add days to datetime string
|
||||
sub add_days_to_datetime{
|
||||
my $datetime=shift;
|
||||
my $days=shift;
|
||||
my $time=datetime_to_array($datetime);
|
||||
#print STDERR Dumper($time);
|
||||
($time->[0], $time->[1], $time->[2]) =Date::Calc::Add_Delta_Days($time->[0]+0, $time->[1]+0, $time->[2]+0, $days);
|
||||
return array_to_datetime($time);
|
||||
}
|
||||
|
||||
sub add_days_to_date{
|
||||
my $datetime=shift;
|
||||
my $days=shift;
|
||||
my $date=date_to_array($datetime);
|
||||
($date->[0], $date->[1], $date->[2]) =Date::Calc::Add_Delta_Days($date->[0]+0, $date->[1]+0, $date->[2]+0, $days);
|
||||
return array_to_date($date);
|
||||
}
|
||||
|
||||
# convert unix time to datetime format
|
||||
sub time_to_datetime{
|
||||
my $time=shift;
|
||||
$time=time() unless((defined $time) && ($time ne''));
|
||||
my @t=localtime($time);
|
||||
return sprintf('%04d-%02d-%02d %02d:%02d:%02d', $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]);
|
||||
};
|
||||
|
||||
# convert unix time to date format
|
||||
sub time_to_date{
|
||||
my $time=shift;
|
||||
$time=time() unless((defined $time) && ($time ne''));
|
||||
my @t=localtime($time);
|
||||
return sprintf('%04d-%02d-%02d', $t[5]+1900, $t[4]+1, $t[3]);
|
||||
};
|
||||
|
||||
# convert datetime to a array of date/time values
|
||||
sub datetime_to_array{
|
||||
my $datetime=$_[0]||'';
|
||||
if ($datetime=~/(\d\d\d\d)\-(\d+)\-(\d+)([T\s]+(\d+)\:(\d+)(\:(\d+))?)?/){
|
||||
my $year=$1;
|
||||
my $month=$2;
|
||||
my $day=$3;
|
||||
my $hour=$5||'00';
|
||||
my $minute=$6||'00';
|
||||
my $second=$8||'00';
|
||||
return [$year,$month,$day,$hour,$minute,$second];
|
||||
}
|
||||
return undef;
|
||||
};
|
||||
|
||||
# convert datetime to date
|
||||
sub datetime_to_date{
|
||||
my $datetime=$_[0]||'';
|
||||
if ($datetime=~/(\d\d\d\d)\-(\d+)\-(\d+)/){
|
||||
my $year=$1;
|
||||
my $month=$2;
|
||||
my $day=$3;
|
||||
return sprintf("%04d-%02d-%02d",$year,$month,$day);
|
||||
}
|
||||
return undef;
|
||||
};
|
||||
|
||||
#convert datetime array or single value to datetime string
|
||||
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]);
|
||||
}
|
||||
my $month =shift;
|
||||
my $day =shift;
|
||||
my $hour =shift||'0';
|
||||
my $minute =shift||'0';
|
||||
my $second =shift||'0';
|
||||
return sprintf("%04d-%02d-%02d %02d:%02d:%02d", $date, $month, $day, $hour, $minute, $second);
|
||||
}
|
||||
|
||||
#convert date array or single values to date string
|
||||
sub array_to_date{
|
||||
my $date =shift;
|
||||
if(ref($date)eq'ARRAY'){
|
||||
return sprintf("%04d-%02d-%02d", $date->[0], $date->[1], $date->[2]);
|
||||
}
|
||||
my $month=shift;
|
||||
my $day =shift;
|
||||
return sprintf("%04d-%02d-%02d", $date, $month, $day);
|
||||
}
|
||||
|
||||
sub array_to_time{
|
||||
my $date =shift;
|
||||
if(ref($date)eq'ARRAY'){
|
||||
return sprintf("%02d:%02d:%02d", $date->[3], $date->[4], $date->[5]);
|
||||
}
|
||||
my $minute = shift||0;
|
||||
my $second = shift||0;
|
||||
return sprintf("%02d:%02d:%02d", $date, $minute, $second);
|
||||
}
|
||||
|
||||
sub array_to_time_hm{
|
||||
my $date =shift;
|
||||
if(ref($date)eq'ARRAY'){
|
||||
return sprintf("%02d:%02d", $date->[3], $date->[4]);
|
||||
}
|
||||
my $minute = shift||0;
|
||||
return sprintf("%02d:%02d", $date, $minute);
|
||||
}
|
||||
|
||||
|
||||
# get number of days between two days
|
||||
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{
|
||||
my $datetime=$_[0];
|
||||
if ($datetime=~/(\d\d\d\d)\-(\d+)\-(\d+)/){
|
||||
my $year = $1;
|
||||
my $month = $2;
|
||||
my $day = $3;
|
||||
return Date::Calc::Day_of_Year($year,$month,$day);
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# get duration in minutes
|
||||
sub get_duration{
|
||||
my $start = shift;
|
||||
my $end = shift;
|
||||
my $timezone= shift;
|
||||
$start=time::get_datetime($start, $timezone);
|
||||
$end =time::get_datetime($end, $timezone);
|
||||
my $duration=$end->epoch()-$start->epoch();
|
||||
return $duration/60;
|
||||
}
|
||||
|
||||
# get duration in seconds
|
||||
sub get_duration_seconds{
|
||||
my $start = shift;
|
||||
my $end = shift;
|
||||
my $timezone= shift||'UTC';
|
||||
$start=time::get_datetime($start, $timezone);
|
||||
$end =time::get_datetime($end, $timezone);
|
||||
my $duration=$end->epoch()-$start->epoch();
|
||||
return $duration;
|
||||
}
|
||||
|
||||
# convert date string to a array of date values
|
||||
sub date_to_array{
|
||||
my $datetime=$_[0];
|
||||
if ($datetime=~/(\d\d\d\d)\-(\d+)\-(\d+)/){
|
||||
my $year = $1;
|
||||
my $month = $2;
|
||||
my $day = $3;
|
||||
return [$year,$month,$day];
|
||||
}
|
||||
return undef;
|
||||
};
|
||||
|
||||
# parse date string and return date string
|
||||
# pass 'today', return '' on parse error
|
||||
sub date_cond{
|
||||
my $date=shift;
|
||||
|
||||
return '' if ($date eq'');
|
||||
if ($date=~/(\d\d\d\d)\-(\d\d?)\-(\d\d?)/){
|
||||
my $year = $1;
|
||||
my $month = $2;
|
||||
my $day = $3;
|
||||
return sprintf("%04d-%02d-%02d", $year, $month, $day);
|
||||
}
|
||||
return 'today' if ($date eq 'today');
|
||||
return '';
|
||||
};
|
||||
|
||||
#parse time and return time string hh:mm:ss
|
||||
#return hh:00 if time is 'now'
|
||||
sub time_cond{
|
||||
my $time = shift;
|
||||
|
||||
return '' if ($time eq'');
|
||||
if ($time=~/(\d\d?)\:(\d\d?)(\:(\d\d))?/){
|
||||
my $hour=$1;
|
||||
my $minute=$2;
|
||||
my $second=$4||'00';
|
||||
return sprintf("%02d:%02d:%02d", $hour, $minute, $second);
|
||||
}
|
||||
if ($time eq 'now'){
|
||||
my $date=datetime_to_array(time_to_datetime(time()));
|
||||
my $hour=$date->[3]-2;
|
||||
$hour=0 if ($hour<0);
|
||||
$time=sprintf("%02d:00",$hour);
|
||||
return $time;
|
||||
}
|
||||
return '';
|
||||
};
|
||||
|
||||
#parse date and time string and return yyyy-mm-ddThh:mm:ss
|
||||
sub datetime_cond{
|
||||
my $datetime = shift;
|
||||
|
||||
return '' if ($datetime eq'');
|
||||
(my $date,my $time)=split /[ T]/,$datetime;
|
||||
$date=time::date_cond($date);
|
||||
return '' if ($date eq'');
|
||||
$time=time::time_cond($time);
|
||||
return '' if ($time eq'');
|
||||
|
||||
return $date.'T'.$time;
|
||||
}
|
||||
|
||||
sub check_date{
|
||||
my $date=shift;
|
||||
|
||||
return "" if((!defined $date) || ($date eq ''));
|
||||
if($date=~/(\d\d\d\d)\-(\d\d?)\-(\d\d?)/){
|
||||
return $1.'-'.$2.'-'.$3;
|
||||
}elsif($date=~/(\d\d?)\.(\d\d?)\.(\d\d\d\d)/){
|
||||
return $3.'-'.$2.'-'.$1;
|
||||
}
|
||||
return $date if ($date eq'today' || $date eq'tomorrow' || $date eq'yesterday');
|
||||
return -1;
|
||||
#error("no valid date format given!");
|
||||
};
|
||||
|
||||
sub check_time{
|
||||
my $time=shift;
|
||||
return "" if((!defined $time) || ($time eq ''));
|
||||
return $time if(($time eq 'now') || ($time eq 'future'));
|
||||
if($time=~/(\d\d?)\:(\d\d?)/){
|
||||
return $1.':'.$2
|
||||
}
|
||||
return -1;
|
||||
};
|
||||
|
||||
sub check_datetime{
|
||||
my $date=shift;
|
||||
|
||||
return "" if((!defined $date) || ($date eq ''));
|
||||
if($date=~/(\d\d\d\d)\-(\d\d?)\-(\d\d?)[T ](\d\d?)\:(\d\d?)/){
|
||||
return sprintf("%04d-%02d-%02dT%02d:%02d",$1,$2,$3,$4,$5);
|
||||
}
|
||||
return -1;
|
||||
};
|
||||
|
||||
sub check_year_month{
|
||||
my $date=shift;
|
||||
return -1 unless(defined $date);
|
||||
return $date if($date eq '');
|
||||
if($date=~/(\d\d\d\d)\-(\d\d?)/){
|
||||
return $1.'-'.$2.'-'.$3;
|
||||
}
|
||||
return -1;
|
||||
};
|
||||
|
||||
#TODO: remove config dependency
|
||||
sub date_time_format{
|
||||
my $datetime=shift;
|
||||
my $language=shift || $config::config->{date}->{language} || 'en';
|
||||
if (defined $datetime && $datetime=~/(\d\d\d\d)\-(\d\d?)\-(\d\d?)[\sT](\d\d?\:\d\d?)/){
|
||||
my $time=$4;
|
||||
my $day=$3;
|
||||
my $month=$2;
|
||||
my $year=$1;
|
||||
|
||||
$month=$time::names->{$language}->{months_abbr}->[$month-1]||'';
|
||||
return "$day. $month $year $time";
|
||||
}
|
||||
return $datetime;
|
||||
}
|
||||
|
||||
#format datetime to date string
|
||||
#TODO: remove config dependency
|
||||
sub date_format{
|
||||
my $datetime=shift;
|
||||
my $language=shift || $config::config->{date}->{language} || 'en';
|
||||
|
||||
if (defined $datetime && $datetime=~/(\d\d\d\d)\-(\d\d?)\-(\d\d?)/){
|
||||
my $day=$3;
|
||||
my $month=$2;
|
||||
my $year=$1;
|
||||
$month=$time::names->{$language}->{months_abbr}->[$month-1]||'';
|
||||
return "$day. $month $year";
|
||||
}
|
||||
return $datetime;
|
||||
};
|
||||
|
||||
#format datetime to time string
|
||||
sub time_format{
|
||||
my $datetime=shift;
|
||||
if (defined $datetime && $datetime=~/(\d\d?\:\d\d?)/){
|
||||
return $1;
|
||||
}
|
||||
return $datetime;
|
||||
};
|
||||
|
||||
#get offset from given time_zone
|
||||
sub utc_offset{
|
||||
my $time_zone=shift;
|
||||
|
||||
$a=DateTime->now();
|
||||
$a->set_time_zone($time_zone);
|
||||
return $a->strftime("%z");
|
||||
}
|
||||
|
||||
#get weekday from (yyyy,mm,dd)
|
||||
sub weekday{
|
||||
my ($year,$month,$day)=@_;
|
||||
my $time = Time::Local::timelocal(0,0,0,$day,$month-1,$year);
|
||||
return (localtime($time))[6];
|
||||
}
|
||||
|
||||
#get current date, related to starting day_starting_hour
|
||||
#TODO: remove config dependency
|
||||
sub get_event_date{
|
||||
my $config=shift;
|
||||
$config=$config::config unless defined $config;
|
||||
|
||||
my $datetime=time::time_to_datetime(time());
|
||||
my $hour=(time::datetime_to_array($datetime))->[3];
|
||||
#today: between 0:00 and starting_hour show last day
|
||||
if ($hour < $config->{date}->{day_starting_hour}){
|
||||
my $date=time::datetime_to_array(time::add_hours_to_datetime($datetime,-24));
|
||||
return $date->[0].'-'.$date->[1].'-'.$date->[2];
|
||||
}else{
|
||||
#today: between starting_hour and end of day show current day
|
||||
my $date=time::datetime_to_array(time::time_to_datetime(time()));
|
||||
return $date->[0]."-".$date->[1]."-".$date->[2];
|
||||
}
|
||||
}
|
||||
|
||||
#get datetime object from datetime string
|
||||
sub get_datetime{
|
||||
my $datetime=shift;
|
||||
my $timezone=shift;
|
||||
|
||||
return unless defined $datetime;
|
||||
return if $datetime eq '';
|
||||
my @l = @{time::datetime_to_array($datetime)};
|
||||
return undef if scalar(@l)==0;
|
||||
|
||||
# catch invalid datees
|
||||
$datetime=undef;
|
||||
eval{
|
||||
$datetime=DateTime->new(
|
||||
year =>$l[0],
|
||||
month =>$l[1],
|
||||
day =>$l[2],
|
||||
hour =>$l[3],
|
||||
minute =>$l[4],
|
||||
second =>$l[5],
|
||||
time_zone=> $timezone
|
||||
);
|
||||
};
|
||||
return undef unless defined $datetime;
|
||||
$datetime->set_locale('de_DE');
|
||||
return $datetime;
|
||||
}
|
||||
|
||||
#get list of nth weekday in month from start to end
|
||||
sub get_nth_weekday_in_month{
|
||||
my $start=shift; # datetime string
|
||||
my $end=shift; # datetime string
|
||||
my $nth=shift; # every nth week of month
|
||||
my $weekday=shift; # weekday [0..6,'Mo'-'Su','Mo'-'Fr']
|
||||
|
||||
my $weekdays=time::get_weekdays();
|
||||
$weekday=$weekdays->{$weekday+1};
|
||||
|
||||
my $dates=[];
|
||||
if ($start=~/(\d\d\d\d)-(\d\d)-(\d\d)[ T](\d\d)\:(\d\d)/){
|
||||
my $hour=int($4);
|
||||
my $min=int($5);
|
||||
my $sec=0;
|
||||
my @date = Date::Manip::ParseRecur("0:1*$nth:$weekday:$hour:$min:$sec", "", $start, $end);
|
||||
for my $date (@date){
|
||||
if ($date=~/(\d\d\d\d)(\d\d)(\d\d)(\d\d)\:(\d\d)\:(\d\d)/){
|
||||
push @$dates,"$1-$2-$3 $4:$5:$6";
|
||||
}
|
||||
}
|
||||
}
|
||||
return $dates;
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
818
lib/calcms/uac.pm
Normal file
818
lib/calcms/uac.pm
Normal file
@@ -0,0 +1,818 @@
|
||||
#!/bin/perl
|
||||
|
||||
use CGI;
|
||||
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
|
||||
use CGI::Session qw(-ip-match);
|
||||
use CGI::Cookie;
|
||||
#$CGI::Session::IP_MATCH=1;
|
||||
|
||||
package uac;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use auth;
|
||||
use db;
|
||||
use template;
|
||||
use project;
|
||||
use studios;
|
||||
#use series;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
get_user get_users update_user insert_user delete_user
|
||||
get_roles insert_role update_role get_role_columns
|
||||
get_studios_by_user get_users_by_studio
|
||||
get_projects_by_user
|
||||
get_user_role get_studio_roles
|
||||
assign_user_role remove_user_role
|
||||
get_user_permissions get_user_presets
|
||||
prepare_request set_template_permissions
|
||||
permission_denied
|
||||
);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
# get user by name
|
||||
sub get_user{
|
||||
my $config=shift;
|
||||
my $user=shift;
|
||||
|
||||
my $query=qq{
|
||||
select id, name, full_name, email, disabled, modified_at, created_at
|
||||
from calcms_users
|
||||
where name=?
|
||||
};
|
||||
my $bind_values=[$user];
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $users=db::get($dbh, $query,$bind_values);
|
||||
if (@$users!=1){
|
||||
print STDERR "cannot find user '$user'\n";
|
||||
return undef;
|
||||
}
|
||||
return $users->[0];
|
||||
}
|
||||
|
||||
# get all users
|
||||
sub get_users{
|
||||
my $config=shift;
|
||||
|
||||
my $query=qq{
|
||||
select id, name, full_name, email, disabled, modified_at, created_at
|
||||
from calcms_users
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $users=db::get($dbh, $query);
|
||||
return $users;
|
||||
}
|
||||
|
||||
#TODO: get_users_by_project
|
||||
|
||||
# get all users of a given studio id
|
||||
# used at series (previously named get_studio_users)
|
||||
sub get_users_by_studio{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
return unless (defined $condition->{studio_id});
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $condition->{project_id}) && ($condition->{project_id} ne '')){
|
||||
push @conditions, 'ur.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{studio_id}) && ($condition->{studio_id} ne '')){
|
||||
push @conditions, 'ur.studio_id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" and ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select distinct(u.id), u.name, u.full_name
|
||||
from calcms_user_roles ur, calcms_users u
|
||||
where ur.user_id=u.id
|
||||
$conditions
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $users=db::get($dbh, $query, \@bind_values);
|
||||
return $users;
|
||||
}
|
||||
|
||||
# get projects a user is assigned by name
|
||||
sub get_projects_by_user{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $condition->{project_id}) && ($condition->{project_id} ne '')){
|
||||
push @conditions, 'ur.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{studio_id}) && ($condition->{studio_id} ne '')){
|
||||
push @conditions, 'ur.studio_id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{user}) && ($condition->{user} ne '')){
|
||||
push @conditions, 'u.name=?';
|
||||
push @bind_values, $condition->{user};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" and ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select distinct p.*, ur.project_id project_id
|
||||
from calcms_user_roles ur, calcms_users u, calcms_projects p
|
||||
where ur.user_id=u.id and p.project_id=ur.project_id
|
||||
$conditions
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $users=db::get($dbh, $query, \@bind_values);
|
||||
return $users;
|
||||
}
|
||||
|
||||
# get all studios a user is assigned to by role
|
||||
# used at series (previously named get_user_studios)
|
||||
sub get_studios_by_user{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $condition->{project_id}) && ($condition->{project_id} ne '')){
|
||||
push @conditions, 'ur.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{studio_id}) && ($condition->{studio_id} ne '')){
|
||||
push @conditions, 'ur.studio_id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{user}) && ($condition->{user} ne '')){
|
||||
push @conditions, 'u.name=?';
|
||||
push @bind_values, $condition->{user};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" and ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select distinct s.*, ur.project_id project_id
|
||||
from calcms_user_roles ur, calcms_users u, calcms_studios s
|
||||
where ur.user_id=u.id and s.id=ur.studio_id
|
||||
$conditions
|
||||
};
|
||||
my $dbh=db::connect($config);
|
||||
my $users=db::get($dbh, $query, \@bind_values);
|
||||
return $users;
|
||||
}
|
||||
|
||||
sub insert_user{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
$entry->{created_at} = time::time_to_datetime(time());
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
db::insert($dbh, 'calcms_users', $entry);
|
||||
}
|
||||
|
||||
sub update_user{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $values =join(",", map {$_.'=?'} (keys %$entry));
|
||||
my @bind_values =map {$entry->{$_}} (keys %$entry);
|
||||
push @bind_values,$entry->{id};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_users
|
||||
set $values
|
||||
where id=?
|
||||
};
|
||||
|
||||
my $dbh =db::connect($config);
|
||||
db::put($dbh, $query, \@bind_values);
|
||||
}
|
||||
|
||||
sub delete_user{
|
||||
my $config=shift;
|
||||
my $id=shift;
|
||||
return unless (defined $id && ($id=~/^\d+$/));
|
||||
|
||||
my $query=qq{
|
||||
delete from calcms_users
|
||||
where id=?
|
||||
};
|
||||
my $dbh =db::connect($config);
|
||||
db::put($dbh, $query, [$id]);
|
||||
}
|
||||
|
||||
|
||||
# get all roles used by all users of a studio
|
||||
# available conditions: project_id, studio_id
|
||||
sub get_studio_roles{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
return [] if ($condition->{studio_id} eq '');
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $condition->{project_id}) && ($condition->{project_id} ne '')){
|
||||
push @conditions, 'ur.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{studio_id}) && ($condition->{studio_id} ne '')){
|
||||
push @conditions, 'ur.studio_id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" and ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select r.*, ur.studio_id, ur.project_id
|
||||
from calcms_roles r, calcms_user_roles ur
|
||||
where r.id=ur.role_id
|
||||
$conditions
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $roles=db::get($dbh, $query, \@bind_values);
|
||||
return $roles;
|
||||
}
|
||||
|
||||
# get role columns (for external use only)
|
||||
sub get_role_columns{
|
||||
my $config=shift;
|
||||
my $dbh=db::connect($config);
|
||||
my $columns=db::get_columns_hash($dbh, 'calcms_roles');
|
||||
return $columns
|
||||
}
|
||||
|
||||
# get roles
|
||||
# filter: studio_id project_id
|
||||
sub get_roles{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $columns=db::get_columns_hash($dbh, 'calcms_roles');
|
||||
|
||||
for my $column (keys %$columns){
|
||||
if (defined $condition->{$column}){
|
||||
push @conditions, $column.'=?';
|
||||
push @bind_values, $condition->{$column};
|
||||
}
|
||||
}
|
||||
my $conditions='';
|
||||
$conditions=' where '.join(' and ',@conditions) if(@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select r.*
|
||||
from calcms_roles r
|
||||
$conditions
|
||||
};
|
||||
|
||||
my $roles=db::get($dbh, $query, \@bind_values);
|
||||
|
||||
return $roles;
|
||||
}
|
||||
|
||||
#insert role to database, set created_at and modified_at
|
||||
sub insert_role{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
$entry->{created_at} = time::time_to_datetime(time());
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $columns=db::get_columns_hash($dbh, 'calcms_roles');
|
||||
;
|
||||
my $role={};
|
||||
for my $column (keys %$columns){
|
||||
$role->{$column}=$entry->{$column} if defined $entry->{$column};
|
||||
}
|
||||
db::insert($dbh, 'calcms_roles', $role);
|
||||
}
|
||||
|
||||
#update role, set modified_at
|
||||
sub update_role{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $dbh =db::connect($config);
|
||||
my $columns=db::get_columns_hash($dbh, 'calcms_roles');
|
||||
my $values =join(",", map {$_.'=?'} (keys %$columns));
|
||||
my @bind_values =map {$entry->{$_}} (keys %$columns);
|
||||
push @bind_values,$entry->{id};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_roles
|
||||
set $values
|
||||
where id=?
|
||||
};
|
||||
# print $query."<br>\n".Dumper(\@bind_values)."<br>\ņ";
|
||||
|
||||
db::put($dbh, $query, \@bind_values);
|
||||
}
|
||||
|
||||
# delete role from database
|
||||
sub delete_role{
|
||||
my $config=shift;
|
||||
my $id=shift;
|
||||
|
||||
return unless (defined $id && ($id=~/^\d+$/));
|
||||
|
||||
my $query=qq{
|
||||
delete from calcms_roles
|
||||
where id=?
|
||||
};
|
||||
my $dbh =db::connect($config);
|
||||
db::put($dbh, $query, [$id]);
|
||||
}
|
||||
|
||||
# get all roles for given conditions: project_id, studio_id, user_id, name
|
||||
# includes global admin user role
|
||||
sub get_user_roles{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if (defined $condition->{user}){
|
||||
push @conditions, 'u.name=?';
|
||||
push @bind_values, $condition->{user};
|
||||
}
|
||||
if (defined $condition->{user_id}){
|
||||
push @conditions, 'ur.user_id=?';
|
||||
push @bind_values, $condition->{user_id};
|
||||
}
|
||||
if (defined $condition->{studio_id}){
|
||||
push @conditions, 'ur.studio_id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
if (defined $condition->{project_id}){
|
||||
push @conditions, 'ur.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions= " and ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select distinct r.*
|
||||
from calcms_users u, calcms_user_roles ur, calcms_roles r
|
||||
where ur.user_id=u.id and ur.role_id=r.id
|
||||
$conditions
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $user_roles=db::get($dbh, $query, \@bind_values);
|
||||
|
||||
#return roles, if the contain an admin role
|
||||
for my $role(@$user_roles){
|
||||
return $user_roles if $role->{role}eq'Admin';
|
||||
}
|
||||
|
||||
#get all admin roles
|
||||
delete $condition->{studio_id} if defined $condition->{studio_id};
|
||||
delete $condition->{project_id} if defined $condition->{project_id};
|
||||
my $admin_roles=get_admin_user_roles($config, $condition);
|
||||
|
||||
#add admin roles to user roles
|
||||
my @user_roles=(@$admin_roles, @$user_roles);
|
||||
$user_roles=\@user_roles;
|
||||
|
||||
return $user_roles;
|
||||
}
|
||||
|
||||
#return admin user roles for given conditions: project_id, studio_id, user, user_id
|
||||
sub get_admin_user_roles{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $condition->{user}) && ($condition->{user} ne '')){
|
||||
push @conditions, 'u.name=?';
|
||||
push @bind_values, $condition->{user};
|
||||
}
|
||||
if ((defined $condition->{user_id}) && ($condition->{user_id} ne '')){
|
||||
push @conditions, 'ur.user_id=?';
|
||||
push @bind_values, $condition->{user_id};
|
||||
}
|
||||
if ((defined $condition->{studio_id}) && ($condition->{studio_id} ne '')){
|
||||
push @conditions, 'ur.studio_id=?';
|
||||
push @bind_values, $condition->{studio_id};
|
||||
}
|
||||
if ((defined $condition->{project_id}) && ($condition->{project_id} ne '')){
|
||||
push @conditions, 'ur.project_id=?';
|
||||
push @bind_values, $condition->{project_id};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" and ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select distinct r.*, ur.studio_id, ur.project_id
|
||||
from calcms_users u, calcms_user_roles ur, calcms_roles r
|
||||
where ur.user_id=u.id and ur.role_id=r.id and r.role='Admin'
|
||||
$conditions
|
||||
limit 1
|
||||
};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $user_roles=db::get($dbh, $query, \@bind_values);
|
||||
return $user_roles;
|
||||
}
|
||||
|
||||
# read permissions for given conditions and add to user_permissions
|
||||
# return user_permissions
|
||||
# studio_id, user_id, name
|
||||
sub get_user_permissions{
|
||||
my $config=shift;
|
||||
my $conditions=shift;
|
||||
my $user_permissions=shift;
|
||||
|
||||
my $user_roles = get_user_roles($config, $conditions);
|
||||
my $admin_roles = get_admin_user_roles($config, $conditions);
|
||||
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);
|
||||
|
||||
my $max_level=0;
|
||||
# aggregate max permissions
|
||||
# should be limited by project and studio
|
||||
for my $user_role (@user_roles){
|
||||
if ($user_role->{level}>$max_level){
|
||||
$user_permissions->{level} = $user_role->{level};
|
||||
$user_permissions->{id} = $user_role->{id};
|
||||
$user_permissions->{role} = $user_role->{role};
|
||||
$user_permissions->{studio_id} = $user_role->{studio_id};
|
||||
$user_permissions->{project_id}= $user_role->{project_id};
|
||||
$max_level = $user_role->{level};
|
||||
}
|
||||
for my $permission (keys %$user_role){
|
||||
if (($permission ne 'level') && ($permission ne 'id') && ($permission ne 'role') && ($permission ne 'studio_id') && ($permission ne 'project_id')){
|
||||
$user_permissions->{$permission}=1 if ((defined $user_role->{$permission}) && ($user_role->{$permission} ne '0'));
|
||||
}
|
||||
}
|
||||
}
|
||||
return $user_permissions;
|
||||
}
|
||||
|
||||
#get user id by user name
|
||||
sub get_user_id{
|
||||
my $config=shift;
|
||||
my $user=shift;
|
||||
|
||||
return undef unless (defined $user);
|
||||
|
||||
my $query=qq{
|
||||
select id
|
||||
from calcms_users
|
||||
where binary name=?
|
||||
};
|
||||
my $dbh=db::connect($config);
|
||||
my $users=db::get($dbh, $query, [$user]);
|
||||
return undef if (@$users==0);
|
||||
return $users->[0]->{id};
|
||||
}
|
||||
|
||||
#get role id by role name
|
||||
sub get_role_id{
|
||||
my $config=shift;
|
||||
my $role=shift;
|
||||
|
||||
return undef unless (defined $role);
|
||||
|
||||
my $query=qq{
|
||||
select id
|
||||
from calcms_roles
|
||||
where role=?
|
||||
};
|
||||
my $dbh=db::connect($config);
|
||||
my $roles=db::get($dbh, $query, [$role]);
|
||||
return undef if (@$roles==0);
|
||||
return $roles->[0]->{id};
|
||||
}
|
||||
|
||||
# assign a role to an user (for a studio)
|
||||
sub assign_user_role{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
#print STDERR Dumper($options);
|
||||
return undef unless defined $options->{project_id};
|
||||
return undef unless defined $options->{studio_id};
|
||||
return undef unless defined $options->{user_id};
|
||||
return undef unless defined $options->{role_id};
|
||||
|
||||
#return if already exists
|
||||
my $query=qq{
|
||||
select *
|
||||
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}]);
|
||||
return undef if (@$user_roles>0);
|
||||
|
||||
#insert entry
|
||||
my $entry={
|
||||
project_id => $options->{project_id},
|
||||
studio_id => $options->{studio_id},
|
||||
user_id => $options->{user_id},
|
||||
role_id => $options->{role_id},
|
||||
created_at => time::time_to_datetime(time())
|
||||
};
|
||||
|
||||
return db::insert($dbh, 'calcms_user_roles', $entry);
|
||||
}
|
||||
|
||||
# unassign a user from a role of (for a studio)
|
||||
sub remove_user_role{
|
||||
my $config=shift;
|
||||
my $options=shift;
|
||||
|
||||
return undef unless defined $options->{project_id};
|
||||
return undef unless defined $options->{studio_id};
|
||||
return undef unless defined $options->{user_id};
|
||||
return undef unless defined $options->{role_id};
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_user_roles
|
||||
where project_id=? and studio_id=? and user_id=? and role_id=?
|
||||
};
|
||||
my $bind_values=[ $options->{project_id}, $options->{studio_id}, $options->{user_id}, $options->{role_id} ];
|
||||
#print STDERR Dumper($query).Dumper($bind_values);
|
||||
my $dbh=db::connect($config);
|
||||
my $result=db::put($dbh, $query, $bind_values);
|
||||
# successfully return even if no entry exists
|
||||
return 1;
|
||||
}
|
||||
|
||||
#checks
|
||||
sub is_user_assigned_to_studio{
|
||||
my $request=shift;
|
||||
my $options=shift;
|
||||
|
||||
my $config = $request->{config};
|
||||
|
||||
return 0 unless defined $request->{user};
|
||||
return 0 unless defined $options->{studio_id};
|
||||
return 0 unless defined $options->{project_id};
|
||||
|
||||
my $options2={
|
||||
user => $request->{user},
|
||||
studio_id => $options->{studio_id},
|
||||
project_id => $options->{project_id}
|
||||
};
|
||||
|
||||
my $user_studios=uac::get_studios_by_user($config, $options2);
|
||||
return 1 if(@$user_studios==1);
|
||||
return 0;
|
||||
}
|
||||
|
||||
# print errors at get_user_presets and check for project id and studio id
|
||||
# call after header is printed
|
||||
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;
|
||||
}
|
||||
|
||||
my $project_check=project::check($config, { project_id => $params->{project_id} } );
|
||||
if($project_check ne '1'){
|
||||
uac::print_error($project_check);
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $studio_check=studios::check($config, { studio_id => $params->{studio_id} } );
|
||||
if($studio_check ne '1'){
|
||||
uac::print_error($studio_check);
|
||||
return undef;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# 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{
|
||||
my $config = shift;
|
||||
my $options = shift;
|
||||
|
||||
my $user = $options->{user}||'';
|
||||
my $error = undef;
|
||||
return {error=>"no user selected"} if ($user eq'');
|
||||
|
||||
my $project_id = $options->{project_id}||'';
|
||||
my $studio_id = $options->{studio_id}||'';
|
||||
$config->{access}->{write}=0;
|
||||
|
||||
#get
|
||||
my $admin_roles = get_admin_user_roles($config, {user=>$user});
|
||||
|
||||
#get all projects by user
|
||||
my $projects = uac::get_projects_by_user($config, {user=>$user});
|
||||
return {error=>"no project is assigned to user"} if(@$projects==0);
|
||||
|
||||
$projects=project::get($config) if(@$admin_roles>0);
|
||||
my @projects=reverse sort {$a->{end_date} cmp $b->{end_date}} (@$projects);
|
||||
$projects=\@projects;
|
||||
|
||||
if ($project_id ne'' && $project_id ne'-1'){
|
||||
my $projectFound=0;
|
||||
for my $project(@$projects){
|
||||
if ($project->{project_id} eq $project_id){
|
||||
$projectFound=1;
|
||||
last;
|
||||
};
|
||||
}
|
||||
return {error=>"project is not assigned to user"} if($projectFound==0);
|
||||
}else{
|
||||
$project_id=$projects->[0]->{project_id};
|
||||
}
|
||||
#print STDERR "project:$project_id\n";
|
||||
|
||||
#check if studios are assigned to project
|
||||
my $studios = project::get_studios($config, {project_id => $project_id});
|
||||
$error="no studio is assigned to project" if (@$studios==0);
|
||||
|
||||
if(@$admin_roles==0){
|
||||
#get all studios by user
|
||||
$studios=uac::get_studios_by_user($config, {user=>$user, project_id=>$project_id});
|
||||
$error="no studio is assigned to user" if (@$studios==0);
|
||||
if (($studio_id ne '')&&($studio_id ne '-1')){
|
||||
my $studioFound=0;
|
||||
for my $studio(@$studios){
|
||||
if ($studio->{id} eq $studio_id){
|
||||
$studioFound=1;
|
||||
last;
|
||||
};
|
||||
}
|
||||
$error="studio is not assigned to user" if($studioFound==0);
|
||||
}else{
|
||||
$studio_id =$studios->[0]->{id};
|
||||
}
|
||||
}else{
|
||||
#for admin get studios by project
|
||||
$studios = studios::get($config, {project_id => $project_id});
|
||||
if (($studio_id ne '')&&($studio_id ne '-1')){
|
||||
my $studioFound=0;
|
||||
for my $studio(@$studios){
|
||||
if ($studio->{id} eq $studio_id){
|
||||
$studioFound=1;
|
||||
last;
|
||||
};
|
||||
}
|
||||
$error="studio is not assigned to project" if($studioFound==0);
|
||||
}else{
|
||||
$studio_id =$studios->[0]->{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){
|
||||
# $projects=project::get($config);
|
||||
# }
|
||||
|
||||
#set studios and projects as selected, TODO:do in JS
|
||||
my $selectedProject={};
|
||||
for my $project(@$projects){
|
||||
if ($project_id eq $project->{project_id}){
|
||||
$project->{selected}='selected="selected"';
|
||||
$selectedProject=$project;
|
||||
last;
|
||||
};
|
||||
}
|
||||
|
||||
my $selectedStudio={};
|
||||
for my $studio(@$studios){
|
||||
if ($studio_id eq $studio->{id}){
|
||||
$studio->{selected}='selected="selected"';
|
||||
$selectedStudio=$studio;
|
||||
last;
|
||||
};
|
||||
}
|
||||
|
||||
my $logout_url=(split(/\//, $0))[-1];
|
||||
|
||||
#print STDERR "ok\n";
|
||||
my $result={
|
||||
user => $user,
|
||||
logout_url => $logout_url,
|
||||
|
||||
project_id => $project_id, # from parameter or default
|
||||
projects => $projects,
|
||||
project => $selectedProject,
|
||||
|
||||
studio_id => $studio_id, # from parameter or default
|
||||
studios => $studios,
|
||||
studio => $selectedStudio,
|
||||
|
||||
permissions => $permissions, # from parameter or default
|
||||
config => $config
|
||||
};
|
||||
$result->{error}=$error if defined $error;
|
||||
return $result;
|
||||
}
|
||||
|
||||
#set user preset properties to request
|
||||
sub prepare_request{
|
||||
my $request=shift;
|
||||
my $user_presets=shift;
|
||||
|
||||
for my $key (keys %$user_presets){
|
||||
$request->{$key}=$user_presets->{$key};
|
||||
}
|
||||
#enrich menu parameters
|
||||
for my $key ('studio_id', 'project_id', 'studio', 'project', 'studios', 'projects', 'user', 'logout_url'){
|
||||
$request->{params}->{checked}->{presets}->{$key}=$user_presets->{$key};
|
||||
}
|
||||
return $request;
|
||||
}
|
||||
|
||||
#TODO: shift to permissions sub entry
|
||||
sub set_template_permissions{
|
||||
my $permissions = shift;
|
||||
my $params = shift;
|
||||
|
||||
for my $usecase (keys %$permissions){
|
||||
$params->{'allow'}->{$usecase}=1 if ($permissions->{$usecase}eq'1');
|
||||
}
|
||||
return $params;
|
||||
}
|
||||
|
||||
#print error message
|
||||
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> '
|
||||
.$_[0]
|
||||
.'</div>'."\n";
|
||||
}
|
||||
|
||||
sub print_warn{
|
||||
print '<div class="warn head">'
|
||||
.'<span class="ui-icon ui-icon-info" style="float:left"></span> '
|
||||
.$_[0]
|
||||
.'</div>'."\n";
|
||||
}
|
||||
|
||||
sub print_error{
|
||||
print '<div class="error" head>'
|
||||
.'<span class="ui-icon ui-icon-alert" style="float:left"></span> '
|
||||
.$_[0].
|
||||
'</div>'."\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
214
lib/calcms/user_settings.pm
Normal file
214
lib/calcms/user_settings.pm
Normal file
@@ -0,0 +1,214 @@
|
||||
package user_settings;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use series_dates;
|
||||
|
||||
# table: calcms_user_settings
|
||||
# columns: user, colors
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(getColors getColorCss get insert update delete get_columns defaultColors);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
our $defaultColors=[
|
||||
{
|
||||
name => 'color_event',
|
||||
css => '#content .event',
|
||||
color => '#c5e1a5'
|
||||
},{
|
||||
name => 'color_schedule',
|
||||
css => '#content .schedule',
|
||||
color => '#dde4e6',
|
||||
},{
|
||||
name => 'color_published',
|
||||
css => '#content .event.published',
|
||||
color => '#a5d6a7',
|
||||
},{
|
||||
name => 'color_no_series',
|
||||
css => '#content .event.no_series',
|
||||
color => '#fff59d',
|
||||
},{
|
||||
name => 'color_marked',
|
||||
css => '#content .event.marked',
|
||||
color => '#81d4fa',
|
||||
},{
|
||||
name => 'color_event_error',
|
||||
css => '#content.conflicts .event.error',
|
||||
color => '#ffab91',
|
||||
},{
|
||||
name => 'color_schedule_error',
|
||||
css => '#content.conflicts .schedule.error',
|
||||
color => '#ffcc80'
|
||||
},{
|
||||
name => 'color_work',
|
||||
css => '#content .work',
|
||||
color => '#b39ddb'
|
||||
},{
|
||||
name => 'color_playout',
|
||||
css => '#content .play',
|
||||
color => '#90caf9'
|
||||
}
|
||||
];
|
||||
|
||||
sub getColors{
|
||||
my $config=shift;
|
||||
my $conditions=shift;
|
||||
return unless defined $conditions->{user};
|
||||
my $user=$conditions->{user};
|
||||
|
||||
#get defaultColors
|
||||
my $colors=[];
|
||||
my $colorMap={};
|
||||
for my $defaultColor (@$defaultColors){
|
||||
my $color= {
|
||||
name => $defaultColor->{name},
|
||||
css => $defaultColor->{css},
|
||||
color => $defaultColor->{color},
|
||||
};
|
||||
push @$colors,$color;
|
||||
$colorMap->{$color->{css}}=$color;
|
||||
}
|
||||
|
||||
my $settings = user_settings::get($config, {user => $user });
|
||||
$settings->{colors} |='';
|
||||
#overwrite colors from user settings
|
||||
for my $line (split(/\n+/, $settings->{colors})){
|
||||
my ($key,$value)=split(/\=/,$line);
|
||||
$key=~s/^\s+//;
|
||||
$key=~s/\s+$//;
|
||||
$value=~s/^\s+//;
|
||||
$value=~s/\s+$//;
|
||||
$colorMap->{$key}->{color}=$value if (($key ne '')&&($value ne '')&&(defined $colorMap->{$key}));
|
||||
}
|
||||
return $colors;
|
||||
}
|
||||
|
||||
sub getColorCss{
|
||||
my $config=shift;
|
||||
my $conditions=shift;
|
||||
return unless defined $conditions->{user};
|
||||
|
||||
my $shift=20;
|
||||
my $limit=220;
|
||||
|
||||
my $colors=getColors($config, $conditions);
|
||||
my $style="<style>\n";
|
||||
for my $color (@$colors){
|
||||
$style.= $color->{css}."{\n\tbackground-color:".$color->{color}.";\n}\n";
|
||||
my $c=$color->{color};
|
||||
if ($c=~/#([a-fA-F0-9][a-fA-F0-9])([a-fA-F0-9][a-fA-F0-9])([a-fA-F0-9][a-fA-F0-9])/){
|
||||
my $r=hex($1);
|
||||
my $g=hex($2);
|
||||
my $b=hex($3);
|
||||
if ($r>$limit){$r-=$shift;}else{$r+=$shift;}
|
||||
if ($g>$limit){$g-=$shift;}else{$g+=$shift;}
|
||||
if ($b>$limit){$b-=$shift;}else{$b+=$shift;}
|
||||
$c=sprintf("#%x%x%x",$r,$g,$b);
|
||||
$style.= $color->{css}.":hover{\n\tbackground-color:".$c.";\n}\n";
|
||||
}
|
||||
}
|
||||
$style.="</style>\n";
|
||||
return $style;
|
||||
}
|
||||
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_user_settings');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $columns;
|
||||
}
|
||||
|
||||
sub get{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my @conditions=();
|
||||
my @bind_values=();
|
||||
|
||||
if ((defined $condition->{user}) && ($condition->{user} ne '')){
|
||||
push @conditions, 'user=?';
|
||||
push @bind_values, $condition->{user};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_user_settings
|
||||
$conditions
|
||||
};
|
||||
#print $query."\n";
|
||||
#print Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
return $entries->[0]||undef;
|
||||
}
|
||||
|
||||
sub insert{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return unless(defined $entry->{user});
|
||||
return unless(defined $entry->{colors});
|
||||
my $dbh=db::connect($config);
|
||||
return db::insert($dbh, 'calcms_user_settings', $entry);
|
||||
}
|
||||
|
||||
sub update{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return unless(defined $entry->{user});
|
||||
return unless(defined $entry->{colors});
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $values =join(",", map {$_.'=?'} (keys %$entry));
|
||||
my @bind_values =map {$entry->{$_}} (keys %$entry);
|
||||
push @bind_values,$entry->{user};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_user_settings
|
||||
set $values
|
||||
where user=?
|
||||
};
|
||||
db::put($dbh, $query, \@bind_values);
|
||||
print "done\n";
|
||||
}
|
||||
|
||||
sub delete{
|
||||
my $config=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return unless(defined $entry->{user});
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_user_settings
|
||||
where user=?
|
||||
};
|
||||
my $bind_values=[$entry->{user}];
|
||||
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
|
||||
db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
247
lib/calcms/user_stats.pm
Normal file
247
lib/calcms/user_stats.pm
Normal file
@@ -0,0 +1,247 @@
|
||||
#!/bin/perl
|
||||
|
||||
package user_stats;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get update insert get_stats increase);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_user_stats');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $columns;
|
||||
}
|
||||
|
||||
sub get{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{series_id}) && ($condition->{series_id} ne '')){
|
||||
push @conditions, 'series_id=?';
|
||||
push @bind_values, $condition->{series_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{user}) && ($condition->{user} ne '')){
|
||||
push @conditions, 'user=?';
|
||||
push @bind_values, $condition->{user};
|
||||
}
|
||||
|
||||
my $limit='';
|
||||
if ((defined $condition->{limit}) && ($condition->{limit} ne '')){
|
||||
$limit= 'limit '.$condition->{limit};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select *
|
||||
from calcms_user_stats
|
||||
$conditions
|
||||
order by modified_at desc
|
||||
$limit
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
|
||||
my $results=db::get($dbh, $query, \@bind_values);
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub get_stats{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{series_id}) && ($condition->{series_id} ne '')){
|
||||
push @conditions, 'series_id=?';
|
||||
push @bind_values, $condition->{series_id};
|
||||
}
|
||||
|
||||
if ((defined $condition->{user}) && ($condition->{user} ne '')){
|
||||
push @conditions, 'user=?';
|
||||
push @bind_values, $condition->{user};
|
||||
}
|
||||
|
||||
my $limit='';
|
||||
if ((defined $condition->{limit}) && ($condition->{limit} ne '')){
|
||||
$limit= 'limit '.$condition->{limit};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select user, project_id, studio_id,
|
||||
max(modified_at) modified_at,
|
||||
sum(create_events) create_events,
|
||||
sum(update_events) update_events,
|
||||
sum(delete_events) delete_events,
|
||||
sum(create_series) create_series,
|
||||
sum(update_series) update_series,
|
||||
sum(delete_series) delete_series
|
||||
from calcms_user_stats
|
||||
$conditions
|
||||
group by user, project_id, studio_id
|
||||
$limit
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
|
||||
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'){
|
||||
$result->{score}+=$result->{$column};
|
||||
}
|
||||
}
|
||||
my @results=reverse sort {$a->{score} <=> $b->{score}} @$results;
|
||||
return \@results;
|
||||
}
|
||||
|
||||
sub insert{
|
||||
my $config=shift;
|
||||
my $stats=shift;
|
||||
|
||||
return undef unless defined $stats->{project_id};
|
||||
return undef unless defined $stats->{studio_id};
|
||||
return undef unless defined $stats->{series_id};
|
||||
return undef unless defined $stats->{user};
|
||||
|
||||
#TODO:filter for existing attributes
|
||||
my $columns=get_columns($config);
|
||||
my $entry={};
|
||||
for my $column (keys %$columns){
|
||||
$entry->{$column}=$stats->{$column} if defined $stats->{$column};
|
||||
}
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $id=db::insert($dbh, 'calcms_user_stats', $entry);
|
||||
return $id;
|
||||
}
|
||||
|
||||
# update project
|
||||
sub update{
|
||||
my $config=shift;
|
||||
my $stats=shift;
|
||||
|
||||
return undef unless defined $stats->{project_id};
|
||||
return undef unless defined $stats->{studio_id};
|
||||
return undef unless defined $stats->{series_id};
|
||||
return undef unless defined $stats->{user};
|
||||
|
||||
my $columns=get_columns($config);
|
||||
my $entry={};
|
||||
for my $column (keys %$columns){
|
||||
$entry->{$column}=$stats->{$column} if defined $stats->{$column};
|
||||
}
|
||||
$entry->{modified_at}= time::time_to_datetime(time());
|
||||
|
||||
my $values =join(",", map {$_.'=?'} (keys %$entry));
|
||||
my @bind_values =map {$entry->{$_}} (keys %$entry);
|
||||
push @bind_values, $entry->{user};
|
||||
push @bind_values, $entry->{project_id};
|
||||
push @bind_values, $entry->{studio_id};
|
||||
push @bind_values, $entry->{series_id};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_user_stats
|
||||
set $values
|
||||
where user=? and project_id=? and studio_id=? and series_id=?
|
||||
};
|
||||
#print STDERR Dumper($query).Dumper(\@bind_values);
|
||||
my $dbh=db::connect($config);
|
||||
return db::put($dbh, $query, \@bind_values);
|
||||
}
|
||||
|
||||
sub increase{
|
||||
my $config=shift;
|
||||
my $usecase=shift;
|
||||
my $options=shift;
|
||||
|
||||
#print STDERR Dumper($usecase)." ".Dumper($options);
|
||||
|
||||
return undef unless defined $usecase;
|
||||
return undef unless defined $options->{project_id};
|
||||
return undef unless defined $options->{studio_id};
|
||||
return undef unless defined $options->{series_id};
|
||||
return undef unless defined $options->{user};
|
||||
|
||||
#print STDERR "ok\n";
|
||||
|
||||
my $columns=get_columns($config);
|
||||
#print STDERR "columns:".Dumper($columns);
|
||||
return undef unless defined $columns->{$usecase};
|
||||
|
||||
my $entries= get($config,$options);
|
||||
#print STDERR "exist:".Dumper($columns);
|
||||
|
||||
if (@$entries==0){
|
||||
my $entry={
|
||||
project_id => $options->{project_id},
|
||||
studio_id => $options->{studio_id},
|
||||
series_id => $options->{series_id},
|
||||
user => $options->{user},
|
||||
$usecase => 1,
|
||||
};
|
||||
#print STDERR "user_stats::insert\n";
|
||||
return insert($config, $entry);
|
||||
}elsif (@$entries==1){
|
||||
my $entry=$entries->[0];
|
||||
$entry->{$usecase}++ if defined
|
||||
#print STDERR "user_stats::update\n";
|
||||
return update($config, $entry);
|
||||
}else{
|
||||
print STDERR "user_stats: to few options given: $usecase,".Dumper($options)."\n";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
385
lib/calcms/work_dates.pm
Normal file
385
lib/calcms/work_dates.pm
Normal file
@@ -0,0 +1,385 @@
|
||||
package work_dates;
|
||||
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use Date::Calc;
|
||||
use time;
|
||||
use db;
|
||||
use log;
|
||||
use studio_timeslot_dates;
|
||||
use work_schedule;
|
||||
|
||||
# schedule dates for work_schedule
|
||||
# table: calcms_work_dates
|
||||
# columns: id, studio_id, schedule_id, start(datetime), end(datetime)
|
||||
# TODO: delete column schedule_id
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get insert update delete get_dates);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_work_dates');
|
||||
my $columns={};
|
||||
for my $col (@$cols){
|
||||
$columns->{$col}=1;
|
||||
}
|
||||
return $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{
|
||||
my $config=shift;
|
||||
my $condition=shift;
|
||||
|
||||
my $date_range_include=0;
|
||||
$date_range_include=1 if $condition->{date_range_include}==1;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{schedule_id}) && ($condition->{schedule_id} ne '')){
|
||||
push @conditions, 'schedule_id=?';
|
||||
push @bind_values, $condition->{schedule_id};
|
||||
}
|
||||
|
||||
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->{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->{exclude}) && ($condition->{exclude} ne '')){
|
||||
push @conditions, 'exclude=?';
|
||||
push @bind_values, $condition->{exclude};
|
||||
}
|
||||
|
||||
my $conditions='';
|
||||
$conditions=" where ".join(" and ",@conditions) if (@conditions>0);
|
||||
|
||||
my $query=qq{
|
||||
select date(start) start_date
|
||||
,date(end) end_date
|
||||
,dayname(start) weekday
|
||||
,start_date day
|
||||
,start
|
||||
,end
|
||||
,schedule_id
|
||||
,studio_id
|
||||
,project_id
|
||||
,exclude
|
||||
,type
|
||||
,title
|
||||
|
||||
from calcms_work_dates
|
||||
$conditions
|
||||
order by start
|
||||
};
|
||||
#print STDERR $query."\n";
|
||||
#print STDERR Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
for my $entry (@$entries){
|
||||
$entry->{weekday}=substr($entry->{weekday},0,2);
|
||||
}
|
||||
|
||||
return $entries;
|
||||
}
|
||||
|
||||
|
||||
#update work dates for all schedules of a work and studio_id
|
||||
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->{schedule_id} ;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
#delete all existing work dates (by project, studio and schedule id)
|
||||
work_dates::delete($config, $entry);
|
||||
|
||||
my $day_start=$config->{date}->{day_starting_hour};
|
||||
|
||||
#get all schedules for schedule id ordered by exclude, date
|
||||
my $schedules=work_schedule::get($config, {
|
||||
project_id => $entry->{project_id},
|
||||
studio_id => $entry->{studio_id},
|
||||
schedule_id => $entry->{schedule_id},
|
||||
});
|
||||
|
||||
#add scheduled work dates and remove exluded dates
|
||||
my $work_dates={};
|
||||
|
||||
#TODO:set schedules exclude to 0 if not 1
|
||||
#insert all normal dates (not excludes)
|
||||
for my $schedule (@$schedules){
|
||||
my $dates=get_schedule_dates($schedule, {exclude => 0});
|
||||
for my $date (@$dates){
|
||||
$date->{exclude}=0;
|
||||
$work_dates->{$date->{start}}=$date;
|
||||
#print STDERR Dumper($date)."\n" if ($date->{start} eq'2014-02-05 19:00:00');
|
||||
}
|
||||
}
|
||||
|
||||
#insert / overwrite all exlude dates
|
||||
for my $schedule (@$schedules){
|
||||
my $dates=get_schedule_dates($schedule, {exclude => 1});
|
||||
for my $date (@$dates){
|
||||
$date->{exclude}=1;
|
||||
$work_dates->{$date->{start}}=$date;
|
||||
#print STDERR Dumper($date)."\n" if ($date->{start} eq'2014-02-05 19:00:00');
|
||||
}
|
||||
}
|
||||
|
||||
#print STDERR Dumper($work_dates->{'2014-02-05 19:00:00'});
|
||||
|
||||
my $request={
|
||||
config => $config
|
||||
};
|
||||
|
||||
my $i=0;
|
||||
my $j=0;
|
||||
for my $date (keys %$work_dates){
|
||||
my $work_date=$work_dates->{$date};
|
||||
#insert date
|
||||
my $entry={
|
||||
project_id => $entry->{project_id},
|
||||
studio_id => $entry->{studio_id},
|
||||
schedule_id => $entry->{schedule_id},
|
||||
title => $entry->{title},
|
||||
type => $entry->{type},
|
||||
schedule_id => $entry->{schedule_id},
|
||||
start => $work_date->{start},
|
||||
end => $work_date->{end},
|
||||
exclude => $work_date->{exclude}
|
||||
};
|
||||
if(studio_timeslot_dates::can_studio_edit_events($config, $entry)==1){ # by studio_id, start, end
|
||||
$entry->{start_date}= time::add_hours_to_datetime($entry->{start}, -$day_start);
|
||||
$entry->{end_date}= time::add_hours_to_datetime($entry->{end}, -$day_start);
|
||||
db::insert($dbh, 'calcms_work_dates', $entry);
|
||||
#print STDERR "$entry->{start_date}\n";
|
||||
$i++;
|
||||
}else{
|
||||
$j++;
|
||||
#print STDERR Dumper($entry);
|
||||
}
|
||||
}
|
||||
#print STDERR "$i work_dates updates\n";
|
||||
return $j." dates out of studio times, ".$i;
|
||||
}
|
||||
|
||||
sub get_schedule_dates{
|
||||
my $schedule=shift;
|
||||
my $options=shift;
|
||||
|
||||
my $is_exclude=$options->{exclude}||0;
|
||||
my $dates=[];
|
||||
return $dates if (($is_exclude eq'1') && ($schedule->{exclude}ne'1'));
|
||||
return $dates if (($is_exclude eq'0') && ($schedule->{exclude}eq'1'));
|
||||
|
||||
if ($schedule->{period_type}eq'single'){
|
||||
$dates=get_single_date($schedule->{start}, $schedule->{duration}) ;
|
||||
}elsif($schedule->{period_type}eq'days'){
|
||||
$dates=get_dates($schedule->{start}, $schedule->{end}, $schedule->{duration}, $schedule->{frequency}) ;
|
||||
}elsif($schedule->{period_type}eq'week_of_month'){
|
||||
$dates=get_week_of_month_dates($schedule->{start}, $schedule->{end}, $schedule->{duration}, $schedule->{week_of_month}, $schedule->{weekday}, $schedule->{month});
|
||||
}else{
|
||||
print STDERR "unknown schedule period_type\n";
|
||||
}
|
||||
return $dates;
|
||||
}
|
||||
|
||||
|
||||
sub get_week_of_month_dates{
|
||||
my $start =shift; # datetime string
|
||||
my $end =shift; # datetime string
|
||||
my $duration =shift; # in minutes
|
||||
my $week =shift; # every nth week of month
|
||||
my $weekday =shift; # weekday [1..7]
|
||||
my $frequency =shift; # every 1st,2nd,3th time
|
||||
|
||||
return undef if $start eq'';
|
||||
return undef if $end eq'';
|
||||
return undef if $duration eq'';
|
||||
return undef if $week eq'';
|
||||
return undef if $weekday eq'';
|
||||
return undef if $frequency eq'';
|
||||
return undef if $frequency==0;
|
||||
|
||||
my $start_dates=time::get_nth_weekday_in_month($start, $end, $week, $weekday-1);
|
||||
|
||||
my $results=[];
|
||||
|
||||
my $c=-1;
|
||||
for my $start_datetime (@$start_dates){
|
||||
$c++;
|
||||
my @start = @{time::datetime_to_array($start_datetime)};
|
||||
next unless @start>=6;
|
||||
next if (($c % $frequency)!=0);
|
||||
|
||||
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, $duration, 0 # delta days, hours, minutes, seconds
|
||||
);
|
||||
my $end_datetime=time::array_to_datetime(\@end_datetime);
|
||||
|
||||
push @$results, {
|
||||
start => $start_datetime,
|
||||
end => $end_datetime
|
||||
};
|
||||
}
|
||||
return $results;
|
||||
}
|
||||
|
||||
#add duration to a single date
|
||||
sub get_single_date{
|
||||
my $start_datetime = shift;
|
||||
my $duration = shift;
|
||||
|
||||
my @start = @{time::datetime_to_array($start_datetime)};
|
||||
return unless @start>=6;
|
||||
|
||||
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, $duration, 0 # delta days, hours, minutes, seconds
|
||||
);
|
||||
my $date={
|
||||
start => $start_datetime,
|
||||
end => time::array_to_datetime(\@end_datetime)
|
||||
};
|
||||
return [$date];
|
||||
}
|
||||
|
||||
#calculate all dates between start_datetime and end_date with duration(minutes) and frequency(days)
|
||||
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";
|
||||
|
||||
my @start = @{time::datetime_to_array($start_datetime)};
|
||||
return unless @start>=6;
|
||||
my @start_date = ($start[0], $start[1], $start[2]);
|
||||
my $start_time = sprintf('%02d:%02d:%02d', $start[3], $start[4], $start[5]);
|
||||
|
||||
#print STDERR "$start_datetime,$end_date,$duration,$frequency\n";
|
||||
|
||||
#return on single date
|
||||
my $date={};
|
||||
$date->{start}= sprintf("%04d-%02d-%02d",@start_date).' '.$start_time;
|
||||
return undef if $duration eq '';
|
||||
|
||||
return undef if (($frequency eq '')||($end_date eq''));
|
||||
|
||||
#continue on recurring date
|
||||
my @end = @{time::datetime_to_array($end_date)};
|
||||
return unless @end>=3;
|
||||
my @end_date = ($end[0], $end[1], $end[2]);
|
||||
|
||||
my $today=time::time_to_date();
|
||||
my ($year, $month, $day)=split(/\-/,$today);
|
||||
|
||||
#do not show dates one month back
|
||||
my $not_before= sprintf("%04d-%02d-%02d", Date::Calc::Add_Delta_Days($year, $month, $day, -30));
|
||||
|
||||
my $dates=[];
|
||||
return $dates if ($end_date lt $today);
|
||||
return $dates if ($frequency<1);
|
||||
|
||||
my $j = Date::Calc::Delta_Days(@start_date, @end_date);
|
||||
my $c=0;
|
||||
for (my $i = 0; $i <= $j; $i+=$frequency ){
|
||||
my @date = Date::Calc::Add_Delta_Days($start[0], $start[1], $start[2], $i);
|
||||
my $date={};
|
||||
$date->{start}=sprintf("%04d-%02d-%02d",@date).' '.$start_time;
|
||||
|
||||
my @end_datetime = Date::Calc::Add_Delta_DHMS(
|
||||
$date[0], $date[1], $date[2], # start date
|
||||
$start[3], $start[4], $start[5], # start time
|
||||
0, 0, $duration, 0 # delta days, hours, minutes, seconds
|
||||
);
|
||||
$date->{end}=time::array_to_datetime(\@end_datetime);
|
||||
|
||||
last if ($c>200);
|
||||
$c++;
|
||||
|
||||
next if $date->{end} lt $not_before;
|
||||
push @$dates,$date;
|
||||
|
||||
}
|
||||
return $dates;
|
||||
}
|
||||
|
||||
#remove all work_dates for studio_id and schedule_id
|
||||
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->{schedule_id};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_work_dates
|
||||
where project_id=? and studio_id=? and schedule_id=?
|
||||
};
|
||||
my $bind_values=[$entry->{project_id}, $entry->{studio_id}, $entry->{schedule_id}];
|
||||
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
|
||||
return db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
156
lib/calcms/work_schedule.pm
Normal file
156
lib/calcms/work_schedule.pm
Normal file
@@ -0,0 +1,156 @@
|
||||
package work_schedule;
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use series_dates;
|
||||
|
||||
# table: calcms_work_schedule
|
||||
# columns: id, studio_id, series_id,
|
||||
# start (datetime),
|
||||
# duration (minutes),
|
||||
# frequency (days),
|
||||
# end (date),
|
||||
# weekday (1..7)
|
||||
# week_of_month (1..5)
|
||||
# month
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(get_columns get insert update delete);
|
||||
our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
|
||||
|
||||
sub debug;
|
||||
|
||||
sub get_columns{
|
||||
my $config=shift;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
my $cols=db::get_columns($dbh, 'calcms_work_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;
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
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->{schedule_id}) && ($condition->{schedule_id} ne '')){
|
||||
push @conditions, 'schedule_id=?';
|
||||
push @bind_values, $condition->{schedule_id};
|
||||
}
|
||||
|
||||
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->{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 $query=qq{
|
||||
select *
|
||||
from calcms_work_schedule
|
||||
$conditions
|
||||
order by exclude, start
|
||||
};
|
||||
#print STDERR $query."\n".Dumper(\@bind_values);
|
||||
|
||||
my $entries=db::get($dbh, $query, \@bind_values);
|
||||
return $entries;
|
||||
}
|
||||
|
||||
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->{start};
|
||||
my $dbh=db::connect($config);
|
||||
return db::insert($dbh, 'calcms_work_schedule', $entry);
|
||||
}
|
||||
|
||||
#schedule id to id
|
||||
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->{schedule_id};
|
||||
return undef unless defined $entry->{start};
|
||||
|
||||
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->{schedule_id};
|
||||
|
||||
my $query=qq{
|
||||
update calcms_work_schedule
|
||||
set $values
|
||||
where project_id=? and studio_id=? and schedule_id=?
|
||||
};
|
||||
return db::put($dbh, $query, \@bind_values);
|
||||
print "done\n";
|
||||
}
|
||||
|
||||
#map schedule id to id
|
||||
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->{schedule_id};
|
||||
|
||||
my $dbh=db::connect($config);
|
||||
|
||||
my $query=qq{
|
||||
delete
|
||||
from calcms_work_schedule
|
||||
where project_id=? and studio_id=? and schedule_id=?
|
||||
};
|
||||
my $bind_values=[$entry->{project_id}, $entry->{studio_id}, $entry->{schedule_id}];
|
||||
#print '<pre>$query'.$query.Dumper($bind_values).'</pre>';
|
||||
return db::put($dbh, $query, $bind_values);
|
||||
}
|
||||
|
||||
sub error{
|
||||
my $msg=shift;
|
||||
print "ERROR: $msg<br/>\n";
|
||||
}
|
||||
|
||||
#do not delete last line!
|
||||
1;
|
||||
Reference in New Issue
Block a user