view release on metacpan or  search on metacpan

lib/Apache/SdnFw/lib/Core.pm  view on Meta::CPAN

	}

	# add some common time things to the object
	$s->{datetime}{time} = time();
	$s->{datetime}{nice} = time2str('%m/%d/%y %l:%M%P %Z',$s->{datetime}{time});
	$s->{datetime}{ymd} = time2str('%Y-%m-%d',$s->{datetime}{time});
	$s->{datetime}{edi_ymd} = time2str('%Y%m%d',$s->{datetime}{time});
	$s->{datetime}{edi_hms} = time2str('%H%M%S',$s->{datetime}{time});
	$s->{datetime}{edi_hm} = time2str('%H%M',$s->{datetime}{time});
	$s->{datetime}{dow} = time2str('%w',$s->{datetime}{time});
	$s->{datetime}{ymdhms} = time2str('%Y%m%d%H%M%S',$s->{datetime}{time});
	($s->{datetime}{year},$s->{datetime}{month},$s->{datetime}{day}) = split '-', $s->{datetime}{ymd};

	# move a few of these into common spots
	$s->{obase} = $s->{env}{OBJECT_BASE};
	$s->{ubase} = $s->{env}{BASE_URL};
	$s->{cbase} = "$s->{env}{HTTPD_ROOT}/$s->{obase}";
	$s->{self_url} = ($s->{env}{FORCE_HTTPS} ? 'https' : 'http').'://'.
		$s->{server_name}.$s->{ubase};

	return $s;
}

#########################
# PROCESS
#########################

=head2 process
 
 $s->process();

 We should be sending back the following
 $s->{r} => (
	file_path => if we want to send back a file handle
	filename => to force the name of the file going back
	content => raw string data to dump back upstream
	error => error string to display or log
	return_code => to just send back a raw return code
	set_cookie => [
		array of cookies to send back
		],
	redirect => redirect to this url
 	)

=cut

sub process {
	my $s = shift;

	if ($s->{env}{FORCE_HTTPS} && !$s->{env}{HTTPS}) {
		$s->{r}{redirect} = "https://$s->{server_name}$s->{uri}";
		$s->{r}{redirect} .= "?$s->{args}" if ($s->{args});
		return;
	}

	# populate a unique variable that can be used on all form variables
	# to kill autocomplete

	$s->{acfb} = md5_hex("$s->{object}$s->{function}$s->{employee_id}".time);

	# the way this works is we look at the url, then decide if we need
	# to processes further by connecting to the database
	# or if we should just punt and return back a file handle
	if ($s->{uri} =~ m/^$s->{ubase}(.*)$/) {
		$s->{raw_path} = $1 || '/';
		$s->run();

		if ($s->{return_code}) {
			$s->{r}{return_code} = $s->{return_code};
			return;
		}

		if ($s->{in}{debug} && $s->{env}{DEV}) {
			#delete $s->{content};
			$s->{content} = Data::Dumper->Dump([$s]);
			$s->{content_type} = 'text/plain';
		}

		# always make the content type xml for api
		$s->{content_type} = 'text/xml' if ($s->{api} || $s->{o}{perl_dump});

		# move the content type back to the return hash
		$s->{r}{content_type} = $s->{content_type};

		# set some things for logging purposes
		$s->{r}{log_user} = $s->{log_user} || '-';
		$s->{r}{log_location} = $s->{log_location} || '-';

		if ($s->{redirect}) {
			# if we have any messages to display, dump them to session and then
			# pick them back up on the redirect
			if ($s->{message}) {
				$s->session_add('message',$s->{message});
			}
			$s->{r}{redirect} = $s->{redirect};
			return;
		}

		# add the top menu to everything unless for some reason we are not text/html
		if ($s->{content_type} eq 'text/html' && !$s->{in}{print}) {
			$s->{r}{content} = $s->_content_add_menu();

			# if the object has a template, then put the returned content
			# into that menu
			if (defined($s->{o}{template})) {
				my $out;
				$s->tt($s->{o}{template}, { s => $s },\$out);
				$s->{r}{content} .= $out;
			} else {
				$s->{r}{content} .= $s->{message} if ($s->{message});
				if ($s->{o}{footer}) {
					$s->tt($s->{o}{footer}, { s => $s });
				}
				$s->{r}{content} .= $s->{content};
			}
		} elsif ($s->{api}) {
			$s->{r}{content} = qq(<?xml version="1.0" ?>\n<response>\n);
			$s->{r}{content} .= "<object>$s->{object}</object>\n" if ($s->{object});
			$s->{r}{content} .= "<function>$s->{function}</function>\n" if ($s->{function});
			$s->{r}{content} .= $s->{message} if ($s->{message});
			$s->{r}{content} .= $s->{content};
			$s->{r}{content} .= '</response>';
		} elsif ($s->{o}{perl_dump}) {
			$s->{r}{content} = qq(<?xml version="1.0" ?>\n);
			my $dump = new XML::Dumper;
			$s->{r}{content} .= $dump->pl2xml(\%{$s->{perl_dump}});
		} else {
			$s->{r}{content} = $s->{content};
		}
		# add some stuff to head like stylesheet or other things 
		# which modules might have added, but only if our content type is still text/html
		if ($s->{content_type} eq 'text/html') {
			unless($s->{nohead}) {
				$s->{r}{head} = $s->_head_add_title();
				$s->{r}{head} .= $s->_head_add_css();
				$s->{r}{head} .= $s->_head_add_js();
			}
			$s->{r}{head} .= $s->{head} if ($s->{head});
			$s->{r}{head} .= $s->{o}{head} if ($s->{o}{head});
			$s->{r}{body} = $s->{body} if ($s->{body});

			if (defined($s->{o}{headers})) {
				foreach my $k (keys %{$s->{o}{headers}}) {
					$s->{r}{headers}{$k} = $s->{o}{headers}{$k};
				}
			}
		}

		return;
	} else {
		# use the server name to decide where to find content
		$s->{r}{file_path} = "$s->{env}{DOCUMENT_ROOT}/$s->{server_name}$s->{uri}";
		$s->{r}{file_path} .= "index.html" if ($s->{r}{file_path} =~ m/\/$/);

		unless(-e $s->{r}{file_path}) {
			$s->{r}{return_code} = "NOT_FOUND";
			return;
		}

		# override our content type because we are sending back a file
		$s->{r}{content_type} = $s->mime_type();
		return;
	}
}

sub tt {

=head2 tt

 $s->tt($fname,$args,[$string])

$fname can be a path to a file, or a string reference, $args is a hash ref with
values of information that is passed to template toolkit.  $string can be a 
reference to a string variable, or to an array ref, in which case the results
are pushed into that array.  If $string is not defined, then the results are
appended to $s->{content}.

 $s->tt('object/template.tt', { s => $s, hash => \%hash });
 $s->tt('object/template.tt', { s => $s, list => \@list },\$output);
 $s->tt(\$template, { s => $s },\@output);

=cut

	my $s = shift;
	my $fname = shift;
	my $args = shift;
	my $string = shift;

	#my $agentfname;
	#if ($s->{agent}) {
	#	($fname = $agentfname) =~ s/([^\/]+\.tt)$/$s->{agent}\/$1/;
	#}

	$fname .= '.xml' if ($s->{api});

	if (defined $string) {
		if (ref $string eq 'ARRAY') {
			my $tmp;
			$s->{tt}->process($fname,$args,\$tmp) || croak $s->{tt}->error();
			push @{$string}, $tmp;
		} else {
			$s->{tt}->process($fname,$args,$string) || croak $s->{tt}->error();
		}
	} else {
		$s->{tt}->process($fname,$args) || croak $s->{tt}->error();
	}

}

=head2 update_and_log