<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># Copyright 1999-2006, Fred Steinberg, Brown Bear Software

package Operation;
use strict;
require CGI;
use Calendar::Defines;
use Calendar::Preferences;
use Calendar::Permissions;
use Calendar::MasterDB;
use Calendar::I18N;

# Default constructor for Operations
sub new {
    my $class = shift;
    my ($paramHash, $authLevel, $user) = @_;
    my $self = {};
    bless $self, $class;

    $self-&gt;{params} = $paramHash;
    $self-&gt;{AuthLevel} = $authLevel;
    $self-&gt;{user} = $user;
    $self-&gt;db;                  # open database; overridden for MasterDB guys
    $self-&gt;prefs;               # read the prefs
    $self-&gt;I18N;                # initialize language stuff

    # If requested, use overriden params from cookie
    if ($self-&gt;{params}-&gt;{CookieParams} || $self-&gt;{params}-&gt;{IsPopup}) {
        my $cgi = CGI-&gt;new;
        my $valString = $cgi-&gt;cookie ('CalciumDisplayParams');
        if ($valString) {
            my @pairs = split /;/, $valString;
            foreach (@pairs) {
                my ($name, $val) = split /=/;
                next if ($name eq 'IsPopup');
                $self-&gt;{params}-&gt;{$name} = $val;
            }
        }
    }

    # hacking away here
    if ($user) {
        my $auth = $user-&gt;internallyAuthenticated;
        my $theUser = User-&gt;getUser ($user-&gt;name); # get from DB, ugh.
        if ($theUser) {         # might not exist in db if htaccess used
            $self-&gt;{user} = $theUser;
            $self-&gt;prefs-&gt;Timezone ($self-&gt;{user}-&gt;timezone);
            $self-&gt;{user}-&gt;{internalAuthentication} = $auth;
        }
    } else {
        # check for tz cookie, else get from cal defaults
        my $zoneOffset = CGI-&gt;new-&gt;cookie ('CalciumAnonOffset');
        $zoneOffset = $self-&gt;prefs-&gt;DefaultTimezone if (!defined $zoneOffset);
        $self-&gt;prefs-&gt;Timezone ($zoneOffset);
    }

    $self;
}

# See if the user is permitted to perform
sub authenticate {
    my $self = shift;
    return 1 if $self-&gt;permission-&gt;permitted ($self-&gt;getUsername,
                                              $self-&gt;{AuthLevel});
}

sub calendarName {
    my $self = shift;
    defined $self-&gt;{params} ? $self-&gt;{params}-&gt;{CalendarName} : undef;
}

sub getUsername {
    my $self = shift;
    $self-&gt;{user} ? $self-&gt;{user}-&gt;name : undef;
}

sub getUser {
    my $self = shift;
    $self-&gt;{user};
}

sub opName {
    my $self = shift;
    defined $self-&gt;{params} ? $self-&gt;{params}-&gt;{Op} : undef;
}

# Just a Convenience routine to save typing, make code readable.
sub getParams {
    my $self = shift;
    my @cgiParams = @_;
    my @retList;
    foreach (@cgiParams) {
        push @retList,
                (defined $self-&gt;{params} ? $self-&gt;{params}-&gt;{$_} : undef);
    }
    wantarray ? @retList : $retList[0];
}

sub clearParams {
    my ($self, @params) = @_;
    return unless $self-&gt;{params};
    foreach (@params) {
        delete $self-&gt;{params}-&gt;{$_};
    }
}

# Return hashref
sub rawParams {
    return shift-&gt;{params};
}

# Return name-&gt;value hashref for params that match regex
sub get_matching_params {
    my ($self, $regex) = @_;
    my %ret_hash = map {$_ =&gt; $self-&gt;{params}-&gt;{$_}}     # get name =&gt; value
                     grep {/$regex/}                     # ...only for matching
                       keys %{$self-&gt;{params}};          # ...param names
    return \%ret_hash;
}

# Pash list, hashref, or arrayref
sub mungeParams {
    my ($selfOrClass, @params) = @_;
    return '' unless defined $params[0];
    if (ref $params[0] eq 'ARRAY') {
        @params = @{$params[0]};
    } elsif (ref $params[0] eq 'HASH') {
        @params = %{$params[0]};
    }
    return join ($;, @params);
}
# Return list
sub unmungeParams {
    my ($selfOrClass, $munged) = @_;
    # make sure even number, for assigning to hash
    my @params = split (/$;/, ($munged || ''));
    push @params, undef
        if (@params != int (@params / 2) * 2);
    return @params;
#    return split (/$;/, ($munged || ''));
}

# Perform should be overriden to do whatever needs doing, eh wot?
sub perform {
    die "Shazam! Nothing to perform for this operation!\n";
}


sub makeURL {
    my $self = shift;
    my $params = shift;
    my $cgi  = CGI-&gt;new;
    my $name = $self-&gt;calendarName;
    my ($url, $plainURL);
    if ($params-&gt;{FullURL}) {
        $url = $cgi-&gt;url ();
        delete $params-&gt;{FullURL};
        $plainURL++;
    } elsif (($ENV{SERVER_PROTOCOL} || '') eq 'INCLUDED') {
        $url = $cgi-&gt;url;
        $url =~ s/^included:/http:/;
    } else {
        $url = $cgi-&gt;url (-relative =&gt; 1);
#        $url = $cgi-&gt;url;
    }
    if ($params-&gt;{PlainURL}) {
        delete $params-&gt;{PlainURL};
        $plainURL++;
    }
    $url .= '?';
    if ($name &amp;&amp; !exists $params-&gt;{CalendarName}) {
        $url .= "CalendarName=$name&amp;";
    }
    while (my ($name, $value) = each %$params) {
        next if (!defined $value); # so can use undef to omit defaults
        $url .= "$name=" . _escape($value) . '&amp;';
    }
    # Add common display arguments
    unless (defined $plainURL) {
        foreach ($self-&gt;displayParamNames) {
            next if exists $params-&gt;{$_};         # not if supplied as an arg
            my $value = $self-&gt;{params}-&gt;{$_};
            next unless $value;    # not if we don't have it
            $value = _escape ($value) if /TextFilter|FilterCategories/;
            $url .= "$_=$value&amp;";  # otherwise, add it
        }
    }
    chop $url;              # remove last ? or &amp;
    $url ||= $cgi-&gt;url;     # in case using index.cgi; empty URLs won't work
    $url;
}
sub _escape {    # from CGI.pm 2.xx
    my $arg = shift;
    return $arg unless $arg;
    $arg=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
    return $arg;
}

# This one makes a full URL, including hostname and port, and ignores all
# params excpet those passed in and the Calendar Name.
sub makeFullURL {
    my $self = shift;
    my $params = shift;
    my $cgi  = CGI-&gt;new;
    my $name = $self-&gt;calendarName;
    my $url = $cgi-&gt;url ();
    $url .= '?';
    if ($name &amp;&amp; !exists $params-&gt;{CalendarName}) {
        $url .= "CalendarName=$name&amp;";
    }
}

# Create and Parse Display Specs param. Parse returns a list.
# Pass in a preferences object if you want to use fallbacks
sub ParseDisplaySpecs {
    my $self = shift;
    my $prefs = shift;
    my ($amount, $navType, $type) = ($self-&gt;{params}-&gt;{Amount}  || '',
                                     $self-&gt;{params}-&gt;{NavType} || '',
                                     $self-&gt;{params}-&gt;{Type}    || '');

    if ($amount !~ /(Year|Month|Week|Day|Quarter|Period)/i) {
        $amount = $prefs ? $prefs-&gt;DisplayAmount : 'Month';
        $self-&gt;{params}-&gt;{Amount} = $amount;
    }

    if ($navType !~ /(Absolute|Relative|Both|Neither)/i) {
        $navType = $prefs ? $prefs-&gt;NavigationBar : 'Absolute';
        $self-&gt;{params}-&gt;{NavType} = $navType;
    }

    if ($type !~ /(Block|List|Condensed|Planner|TimePlan)/i) {
        $type = $prefs ? $prefs-&gt;BlockOrList : 'Block';
        $self-&gt;{params}-&gt;{Type} = $type;
    }

    ($amount, $navType, $type);
}

# Return filter categories, regex, and which text to look at
sub ParseFilterSpecs {
    my $self = shift;
    my ($filterText, $filterIn, $filterIgnoreCase, $filterUseRegex,
        $filterCategories) = $self-&gt;getParams (qw (TextFilter FilterIn
                                                   IgnoreCase UseRegex
                                                   FilterCategories));
    if ($filterText) {
        $filterText = quotemeta ($filterText) unless $filterUseRegex;
        $filterText = "(?i)$filterText" if $filterIgnoreCase;
        $filterIn = 'both'  if ($filterIn =~ /both/i);
        $filterIn = 'text'  if ($filterIn =~ /event/i);
        $filterIn = 'popup' if ($filterIn =~ /popup/i);
    }
    if ($filterCategories) {
        $filterCategories = [split /$;/, $filterCategories];
    }
    return ($filterCategories, $filterText, $filterIn);
}

# Return text for hidden CGI form elements for passing Display Specs around
sub hiddenDisplaySpecs {
    my $self = shift;
    my $cgi = CGI-&gt;new;
    my $html = '';
    foreach my $param ($self-&gt;displayParamNames) {
        my $val = $self-&gt;{params}-&gt;{$param};
        next unless defined $val;
        $html .= $cgi-&gt;hidden (-name     =&gt; $param,
                               -override =&gt; 1,
                               -default  =&gt; $val);
    }
    $html;
}

sub displayParamNames {
    return qw (Amount NavType Type
               TextFilter FilterIn IgnoreCase UseRegex FilterCategories
               DayViewStart DayViewHours DayViewIncrement YearViewColor
               Date UseLang IsPopup);
}

sub displayParamCookie {
    my $self = shift;
    my @displayParams;
    my @vals = $self-&gt;getParams ($self-&gt;displayParamNames);
    foreach ($self-&gt;displayParamNames) {
        my $val = shift @vals;
        next unless defined $val;
        next if ($_ eq 'IsPopup');
        push @displayParams, "$_=$val";
    }
    my $paramCookie = CGI-&gt;new-&gt;cookie (-name  =&gt; 'CalciumDisplayParams',
                                        -value =&gt; join ';', @displayParams);
}

# Return prefs object. Get from the db (and cookies) if we haven't already
# got 'em. Will create a new Database object if necessary.
sub prefs {
    my $self = shift;
    my $force = shift;
    if ($force || !defined $self-&gt;{Preferences}) {
        $self-&gt;{Preferences} = Preferences-&gt;new ($self-&gt;db);

        $self-&gt;{Preferences}-&gt;clearCache;     # needed for mod_perl

        # check for special I18N setting
        if (my $theLang = $self-&gt;getParams ('UseLang')) {
            $self-&gt;{Preferences}-&gt;Language ($theLang);
        }

        # check for excluded includes
        if (my $name = $self-&gt;calendarName) {

            my $hash = $self-&gt;{Preferences}-&gt;{Includes};

            # check params for special IncludeOnly, instead of using cookie
            my $incOnly = $self-&gt;getParams ('IncludeOnly');
            if ($incOnly) {
                my @calNames = split /-/, $incOnly;
                my %included = map {$_ =&gt; 1} @calNames;
                foreach (keys %$hash) {
                    $hash-&gt;{$_}-&gt;{Excluded} = !exists $included{$_};
                }
            } else {
                # get additional prefs from cookies (will change if more)
                my $cgi = CGI-&gt;new;
                my $excluded = $cgi-&gt;cookie ("EventFilter-$name") || '';
                my %cookie;
                foreach (split ',', $excluded) {
                    $cookie{$_}++;
                }
                foreach (keys %$hash) {
                    $hash-&gt;{$_}-&gt;{Excluded} = $cookie{$_};
                }
            }
        }
    }
    return $self-&gt;{Preferences};
}

# Return Permissions object. Creates new db if necessary
sub permission {
    my $self = shift;
    my $db = shift;
    $self-&gt;{Permission} = Permissions-&gt;new ($self-&gt;db)
        unless defined $self-&gt;{Permission};
    return $self-&gt;{Permission};
}

# Cache user permission for this operation
sub userPermitted {
    my ($self, $level) = @_;
    $self-&gt;{_userPermissions} ||= {};
    if (!exists $self-&gt;{_userPermissions}-&gt;{$level}) {
        $self-&gt;{_userPermissions}-&gt;{$level} =
            $self-&gt;permission-&gt;permitted ($self-&gt;getUser, $level);
    }
    return $self-&gt;{_userPermissions}-&gt;{$level};
}

# Get Database object. Create a new one if we don't have it yet.
# If we don't have a calendar name, we must be working with the MasterDB
sub db {
    my $self = shift;
    $self-&gt;{Database} = ($self-&gt;calendarName ? Database-&gt;new
                                                          ($self-&gt;calendarName)
                                             : MasterDB-&gt;new)
        unless $self-&gt;{Database};
    return $self-&gt;{Database};
}

# Get or Set. Setting also updates the preferences.
sub I18N {
    my $self = shift;
    my $newLanguage = shift;
    if ($newLanguage) {
        $self-&gt;{I18N} = I18N-&gt;new ($newLanguage);
        $self-&gt;db-&gt;setPreferences ({Language =&gt; $newLanguage});
    } else {
        $self-&gt;{I18N} = I18N-&gt;new ($self-&gt;prefs-&gt;Language)
            unless $self-&gt;{I18N};
    }
    return $self-&gt;{I18N};
}


# Auditing
#  See if we want to be audited, then create an audit obj and do it.
# This works on security classes (View, Add, Edit, Admin). Particular
# operations can override the auditType method for special case auditing (e.g.
# user login)
sub audit {
    my $self = shift;
    my $type = $self-&gt;auditType;
    my @auditTypes;
    my $db = $self-&gt;db;
    if ($type =~ /User/i) {     # use setting from Master if "user" opts.
        $db = MasterDB-&gt;new;
    }
    @auditTypes = $db-&gt;getAuditing ($type);
    return unless @auditTypes;
    my @auditObjs = map {AuditFactory-&gt;create ($_)} @auditTypes;
    foreach (@auditObjs) {
        $_-&gt;perform ($self, $db);
    }
}

sub auditType {           # might be overridden; e.g. UserLogin, UserLogout
    my $self = shift;
    return OperationFactory-&gt;getOpType (ref ($self));
}


# Subclasses should define this method for custom Audit Strings
# Return the string to be logged or mailed or whatever; undef means do nada
# Interface is defined to expect an arg if want short string
sub auditString {
     my $self = shift;
     my $short = shift;         # ignored in this default version

     my ($sec, $min, $hour, $mday, $mon, $year, @etc) = localtime (time);
     my $date = sprintf '%d/%.2d/%.2d %.2d:%.2d:%.2d',
                        $year+1900, $mon+1, $mday, $hour, $min, $sec;
     my $calNames = $self-&gt;calendarName;
     if (defined $self-&gt;{audit_calendars}) {
         $calNames = join ',', @{$self-&gt;{audit_calendars}};
     }
     return "$date " .
            "$ENV{REMOTE_ADDR} " . 
            ($self-&gt;getUsername || '-') . ' ' .
            ($calNames          || '-') . ' ' .
            ref ($self);
}

# Do HTTP Redirect; uncomment 3 lines for problematic IIS/IE combination
sub redir {
    my ($self, $url) = @_;
    my $cgi = CGI-&gt;new;

    # in case empty URL is aliased to this script; fixes double-post
    # problem w/Safari
    $url = "/$url" if ($url =~ /^\?/);

    return $cgi-&gt;redirect ($url)
# Uncomment following lines if redirect problems w/IE and IIS
#         unless ($ENV{HTTP_USER_AGENT} =~ /MSIE/i);
#     return $cgi-&gt;redirect (-uri =&gt; $url,
#                            -nph =&gt; 1);
}

sub cssDefaults {
    my ($self) = @_;
    $self = $self-&gt;new unless (ref $self);
    my $prefs = $self-&gt;prefs;
    my $css;

    my ($body_font, $body_size) = $prefs-&gt;font ('Body');
    my %body_css = (bg =&gt; 'white');
    $body_css{'font-family'} = $body_font if ($body_font);
    $body_css{'font-size'}   = $body_size if ($body_size);

    $css .= $self-&gt;cssString ('body', \%body_css);

    $css .= $self-&gt;cssString ('.PageHeader', {bg          =&gt; '#cccccc',
                                              'font-size' =&gt; 'xx-large',
                                              'font-weight' =&gt; 'bold',
                                              'text-align' =&gt; 'center'});
    $css .= $self-&gt;cssString ('.SectionHeader', {bg           =&gt; 'thistle',
                                                 padding   =&gt; '2px',
                                                 'font-size'   =&gt; 'medium',
                                                 'font-weight' =&gt; 'bold',
                                                 'text-align'  =&gt; 'center'});
    $css .= $self-&gt;cssString ('.ErrorHighlight',   {color =&gt; 'red'});
    $css .= $self-&gt;cssString ('.WarningHighlight', {color =&gt; 'darkred',
                                                    'font-weight' =&gt; 'bold'});
    $css .= $self-&gt;cssString ('.EventTag', {'font-size' =&gt; 'smaller'});

    # EventEditForm only for ShowDay, EventEditDelete, ShowMultiAddEvent, etc.
    $css .= $self-&gt;cssString ('.EntryWidgets', {bg =&gt; '#cccccc'});
    $css .= $self-&gt;cssString ('.InlineHelp', {'font-size'   =&gt; 'smaller',
                                              'margin-left' =&gt; '10px'});
}
sub cssFile {
    my $self = shift;
    $self = $self-&gt;new unless (ref $self);
    return $self-&gt;prefs-&gt;CSS_URL || MasterDB-&gt;new-&gt;getPreferences ('CSS_URL');
}
sub cssString {
    my ($selfOrClass, $name, $styles) = @_;
    my @sizes = ('.6em','.6em','.75em', '1em', '1.2em', '1.5em', '2em', '3em');
    my @foo;
    while (my ($attrib, $value) = each %$styles) {
        next if (!defined $value or $value eq '');
        # convenience thingies
        if ($attrib eq 'bg') {
            $attrib = 'background-color';
        }
        elsif ($attrib eq 'fg') {
            $attrib = 'color';
        }
        elsif ($attrib eq 'font-size' and $value =~ /^[1-7]$/) { # ugg
            # turns out that 1 --&gt; x-small, 6--&gt;xx-large, 7? oh well
            $value = $sizes[$value];
        }
        push @foo, "$attrib: $value";
    }
    return '' unless @foo;
    return "$name { " . join ('; ', @foo) . "}\n";
}

1;
</pre></body></html>