view release on metacpan or  search on metacpan

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

				$count++;
			}
		}

		#croak "process dump\n".Data::Dumper->Dump([\@r]);
		$s->db_update_key('data_imports','data_import_id',$data_import_id,{
			count => $count
			});

		$s->{dbh}->commit;

		unlink $localfile;

		if ($s->{subof_key}) {
			$s->notify("File imported successfully. $count rows processed. ".
				$s->object_link(function => 'display',
					object => $s->{o}{subof},
					params => "$s->{subof_key}=$s->{subof_id}",
					title => 'Continue'));
		} else {
			$s->notify("File imported successfully. $count rows processed. ".
				$s->object_link(function => 'list',
				title => 'Continue'));
		}

		#$s->{content} .= "<pre>".Data::Dumper->Dump([\@debug])."</pre>";
		return;
	}

	# before we can do anything, make sure we have a data_import_id field on this 
	# table, otherwise we can not roll this back or delete what we just imported
	eval {
		$s->db_q("SELECT data_import_id
			FROM $s->{o}{table}
			LIMIT 1
			");
		};
	if ($@) {
		$s->alert("Sorry, you can not import into this object because it does not have a ".
			"data_import_id field in the database table");
		return;
	}

	$s->tt('import.tt', { s => $s, });
}

sub generic_list {
	my $s = shift;

	my $ob = $s->{o}{list_orderby} || 1;
	my @list = $s->db_q("SELECT * FROM $s->{o}{view} ORDER BY $ob",'arrayhash');

	$s->add_action(function => 'create') if (defined($s->{o}{functions}{create}));
	$s->add_action(function => 'sync') if (defined($s->{o}{functions}{sync}));
	$s->add_action(function => 'import') if (defined($s->{o}{functions}{import}));
	$s->add_action(function => 'search') if (defined($s->{o}{functions}{search}));

	$s->tt('list.tt',{ s => $s, list => \@list });
}

sub calendar {
	my $s = shift;
	my $start_day = shift || $s->{datetime}{ymd};
	my $months = shift || 1;

	croak "invalid calendar months value: $months" unless($months =~ m/^\d+$/);
	$months = 12 if ($months > 12);

	my @list = $s->db_q("
		SELECT d.stat_date, extract('dow' from d.stat_date) as dow,
			to_char(d.stat_date, 'Month YYYY') as month_name,
			to_char(d.stat_date, 'DD') as day,
			to_char(d.stat_date, 'YYYY-MM') as month,
			CASE WHEN d.stat_date < date(now()) THEN TRUE ELSE FALSE END as past
		FROM date_values(date(date_trunc('month',date(?))),
			date(date_trunc('month',date(?)) + interval '$months month' - interval '1 day')) d
		ORDER BY d.stat_date
		",'arrayhash',
		v => [ $start_day, $start_day ]);

	my @weeks;
	my %week;
	foreach my $ref (@list) {
		if (keys %week) {
			if ($ref->{dow} == 0) {
				push @weeks, { %week };
				%week = ();
			} elsif ($ref->{month_name} ne $week{month_name}) {
				push @weeks, { %week };
				%week = ();
			}
		}

		$week{month_name} = $ref->{month_name};
		$week{month} = $ref->{month};
		$week{days}{$ref->{dow}}{day} = $ref->{day};
		$week{days}{$ref->{dow}}{date} = $ref->{stat_date};
	}

	push @weeks, { %week };

	my %calendar = (
		weeks => \@weeks,
		dow => {
			0 => { s => 'S', m => 'Sun', l => 'Sunday' },
			1 => { s => 'M', m => 'Mon', l => 'Monday' },
			2 => { s => 'T', m => 'Tue', l => 'Tuesday' },
			3 => { s => 'W', m => 'Wed', l => 'Wednesday' },
			4 => { s => 'T', m => 'Thu', l => 'Thursday' },
			5 => { s => 'F', m => 'Fri', l => 'Friday' },
			6 => { s => 'S', m => 'Sat', l => 'Saturday' },
			},
		);
	return %calendar;
}

####################################
# PRIVATE STUFF
####################################
sub _content_add_menu {
	my $s = shift;

	if ($s->{nomenu}) {
		if ($s->{o}{interface} && $s->{$s->{o}{id}}) {
			my $menu;
			$s->tt('interface_menu.tt', { s => $s }, \$menu)
				unless($s->{nomenu_interface});
			return $menu;
		} else {
			return '';
		}
	} else {
		if ($s->{employee}{admin} && !($s->{object} =~ m/^(me|help)$/)) {
			$s->{employee}{object}{$s->{object}}{permission} = 1;
			(my $args = $s->{args}) =~ s/=/%3D/g;
			$s->add_action(function => 'permission',
				params => "return=$s->{function}&return_args=".$s->escape($args)) 
				unless($s->{env}{HIDE_PERMISSION} || $s->{agent});
		}

		# if we are in autocommit still at this point
		# then it probably means there was an error, so we need
		# to rollback before we can do this query below
		if ($s->{dbh}->{AutoCommit} == 0) {
			$s->{dbh}->rollback;
		}

		# load tabs
		@{$s->{tabs}} = $s->db_q("
			SELECT code, COALESCE(tab_name, name) as name
			FROM objects
			WHERE tab_order IS NOT NULL
			ORDER BY tab_order
			",'arrayhash');

		my $menu;
		$s->tt($s->{o}{menutemplate} || 'menu.tt', { s => $s }, \$menu);
		return $menu;
	}
}

sub _head_add_css {
	my $s = shift;

	return if ($s->{no_css});

	my $stylefile = 'style';
	if ($s->{agent}) {
		$stylefile = "$s->{agent}/$stylefile";
	}

	# in order to help with load times, just include the css directly
	# instead of having them call the request the file separatly
	my $sfile = "/data/$s->{obase}/content/css/$stylefile.css"; 

	# if our object has a specific style file, then use that instead
	$sfile = "/code/$s->{obase}/css/$s->{o}{css}.css" if ($s->{o}{css});


	my $return;
	if (-e $sfile) {
		$return = "<style>";
		open F, $sfile;
		while (<F>) {
			chomp;
			$return .= $_;
		}
		close F;
		$return .= "</style>\n";
	}
	return $return;

#	my $v = (stat("$s->{plib}/css/$stylefile.css"))[9];
#	my $return = qq(\t<link rel="stylesheet" href="/css/$stylefile-r$v.css" />\n);
#
#	# check for a custom stylesheet
#	my $cv = (stat("/data/$s->{obase}/content/custom.css"))[9];
#	if ($cv) {
#		$return .= qq(\t<link rel="stylesheet" href="/custom-r$cv.css" />\n);
#	}
#
#	if ($s->{agent} eq 'iphone') {
#		my $scale = ($s->{allow_zoom}) ? 'yes' : 'no';
#		$return .= qq(\t<meta name="viewport" content="user-scalable=$scale, width=device-width" />\n);
#	}
#
#	return $return;
}

sub add_js {
	my $s = shift;
	my $type = shift;

	$s->{add_js}{$type} = 1;

	return '';
}

sub _head_add_js {
	my $s = shift;

	if (defined($s->{add_js})) {
		# always add prototype
		$s->{add_js}{prototype} = 1;
	}

	my $return = qq(\n<script type="text/javascript" src="/js/prototype.js"></script>\n)
		if ($s->{add_js}{prototype});

	foreach my $k (keys %{$s->{add_js}}) {
		next if ($k eq 'prototype');
		if ($k eq 'scriptaculous') {
			$return .= qq(<script type="text/javascript" src="/js/scriptaculous.js?effects,controls"></script>\n);
		} elsif ($k eq 'calendar') {
			$return .= qq(<script type="text/javascript" src="/js/calendar_date_select/calendar_date_select.js"></script>\n).
			qq(<script type="text/javascript" src="/js/calendar_date_select/format_iso_date.js"></script>\n);
		} else {
			$return .= qq(<script type="text/javascript" src="/js/$k.js"></script>\n);
		}
	}

	$return .= join "\n", @{$s->{head_js}} if (defined($s->{head_js}));

	return $return;
}

sub html_caption_scroll {
	my $s = shift;
	my $caption = shift;
	my $scroll = shift;
	my $title = shift || 'scroll';
	my $bmargin = shift || 5;

	return qq|<div class="floatleft">$caption</div><div id="clink" class="captionlink"><a href="#" onClick="javascript:dscroll(\$('$scroll'),$bmargin); \$('clink').style.display = 'none'; return true;" class="action">$title</a></div>|;
}

sub html_display_link {
	my $s = shift;
	my $object = shift;
	my $id = shift;
	my $name = shift;
	my $keyfield = shift || 'id';

	return $s->html_a("$s->{ubase}/$object/display?$keyfield=$id",$name);
}

sub html_input_calendar {
	my $s = shift;
	my $key = $s->escape(shift);
	my $value = $s->escape(shift);

	$key = "$s->{acfb}::$key" if ($s->{acfb});

	my $cal = $s->add_calendar($key);
	my $str = qq(<input $cal name="$key" value="$value" autocomplete="off" size="12">);

	return $str;
}

sub add_calendar {
	my $s = shift;
	my $id = shift;

	$s->add_js('calendar');

	return qq|id="$id" onclick="javascript: new CalendarDateSelect( \$('$id'), {close_on_click: true, embedded:true, year_range:1} );"|;
}

sub _head_add_title {
	my $s = shift;

	if (ref $s->{title} eq 'ARRAY') {
		my $t = join ' :: ', @{$s->{title}};
		$s->{title} = $t;
	}

	if ($s->{env}{TITLE}) {
		if ($s->{title}) {
			$s->{title} = "$s->{env}{TITLE} :: $s->{title}";
		} else {
			$s->{title} = $s->{env}{TITLE};
		}
	}

	$s->{title} = $s->{uri} unless($s->{title});

	return "<title>$s->{title}</title>\n";
}

sub _interface_auth {
	my $s = shift;

	# make sure we have some things
	croak "id not defined in object $s->{object}" unless($s->{o}{id});
	croak "table not defined in object $s->{object}" unless($s->{o}{table});
	croak "view not defined in object $s->{object}" unless($s->{o}{view});
	croak "interface not defined in object $s->{object}" unless($s->{o}{interface});

	if ($s->{object} eq 'logout' && $s->{cookies}{IL}) {
		$s->db_q("
			UPDATE $s->{o}{table} SET interface_cookie=NULL
			WHERE interface_cookie=?
			",undef,
			v => [ $s->{cookies}{IL} ],
			);

		#$s->{raw_path} = '/';
		#$s->{uri} =~ s/logout//;
	}

	SWITCH: {
		last if ($s->_interface_check_cookie());
		last if ($s->_interface_check_login());
	}

	#$s->{content} .= "<pre>".Data::Dumper->Dump([$s])."</pre>";

	return 1 if ($s->{$s->{o}{id}});

	$s->{nomenu} = 1; 
	$s->{title} = 'Login';

	$s->tt('interface_login.tt',{ s => $s });