verify results from the CPAN

Apache-SdnFw


	my @list;
	push @list, $seg_code;
	foreach my $eref (@{$elements}) {
		next if ($eref->{element_order} > $max_order); # do not do elements higher
		my $n = $eref->{element_order};
		my $value = (defined($hashref->{$n}))
			? $hashref->{$n}
			: '';
		$value =~ s/\*//g;

		if ($eref->{element_type} eq 'DT') {
			if ($eref->{min_length} == 6) {
				$value =~ s/^20//;
			}
			$value =~ s/-//g;
		}

		if ($eref->{element_type} eq 'TM') {
			$value =~ s/\D//;
		}

		if (defined($hashref->{$n})) {
			if ($eref->{min_length} > 1) {
				if (length $value < $eref->{min_length}) {
					if ($eref->{element_type} eq 'AN') {
						while (length $value < $eref->{min_length}) {
							$value .= ' ';
						}
					} else {
						while (length $value < $eref->{min_length}) {
							$value = "0$value";
						}
					}
				}
			}
		}

		if ($eref->{max_length}) {
			if (length $value > $eref->{max_length}) {
				$value = substr $value, 0, $eref->{max_length};
			}
		}
		push @list, $value;
	}
	
	my $output = (join '*', @list);
	return $output;
}

sub _max_order {
	my $hashref = shift;

	my $order = 0;
	foreach my $k (keys %{$hashref}) {
		$order = $k if ($k > $order);
	}
	return $order;
}

sub verify_x12 {
	my $s = shift;
	my $vendor = shift;
	my $dataref = shift;

	# all we do here right now is make sure our header envelope matches who we think
	# is sending to use, and who they thing they are sending to....

	my %check = (
		partner_edi_identifier => 'ISA08',
		partner_edi_qualifier => 'ISA07',
		vendor_code => 'ISA06',
		vendor_code_qual => 'ISA05',
		);

	foreach my $k (keys %check) {
		my $value = $dataref->{$check{$k}};
		$value =~ s/\s//g;
		croak "No $k to compare" unless($vendor->{$k});
		croak "Database $k value $vendor->{$k} != X12 $check{$k} value $value"
			if ($vendor->{$k} ne $value);
	}
}

sub parse_x12 {
	my $s = shift;
	my $vendor = shift;
	my $input = shift;

#print "Input=$input\n";

	$vendor->{element_sep} = '\*' if ($vendor->{element_sep} eq '*');
	# kill cr
	$input =~ s/\r//g;
	if ($vendor->{segment_term}) {
		# if we have an actual character terminator, then kill all newlines
		$input =~ s/\n//g unless($vendor->{segment_term} eq "\n");
	} else {
		# use newline as our terminator
		$vendor->{segment_term} = "\n";
	}

#print "Input2=$input\n";
	my @data;
	foreach my $seg (split $vendor->{segment_term}, $input) {
		my @e = split $vendor->{element_sep}, $seg;
		push @data, [ @e ];
	}

#print " ".Data::Dumper->Dump([\@data]);

	my %x;
	my %work;
	unless($vendor->{partner_edi_identifier} && $vendor->{partner_edi_qualifier}) {
		croak "Partner $vendor->{partner_id}} has unknown identifier or qualifier";
	}

	my $dt;
	my $i_ref = undef;
	my $g_ref = undef;
	my $s_ref = undef;

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


sub object_link {
	my $s = shift;
	my %args = @_;

	my $object = $args{object} || $s->{object};
	my $function = $args{function};
	my $params = $args{params};
	my $title = $args{title} || $function;

	# this nice little thing uppercases each word of the title
	$title = join ' ', map {ucfirst} split / /, $title;

	$params = '?'.$params if ($params);

	my $html;
	$s->tt('objectlink.tt', { s => $s, args => {
		object => $object,
		function => $function,
		params => $params,
		title => $title }
		}, \$html);

	return $html;
}

sub set_dbparams {
	my $s = shift;
	my %args = @_;

	foreach my $k (keys %args) {
		if ($k eq 'limit') {
			if ($s->{in}{limit} =~ m/^\d{1,3}$/) { # max limit is 999
				$s->{limit} = $s->{in}{limit};
			} else {
				$s->{limit} = $args{$k};
			}
		} elsif ($k eq 'offset') {
			if ($s->{in}{offset} =~ m/^\d+$/) { 
				$s->{offset} = $s->{in}{offset};
			} else {
				$s->{offset} = $args{$k};
			}
		} elsif ($k eq 'orderdir') {
			if ($s->{in}{orderdir} eq 'desc') {
				$s->{orderdir} = 'desc';
			} elsif ($s->{in}{orderdir} eq 'asc') {
				$s->{orderdir} = 'asc';
			} else {
				$s->{orderdir} = $args{$k};
			}
		} else {
			if ($s->{in}{orderby}) {
				$s->{in}{orderby} =~ s/[^a-z_]//g;
			}
			$s->{orderby} = $s->{in}{orderby} || $args{$k};
		}
	}
}

sub verify_date {

=head2 verify_date

 my $truefalse = $s->verify_date($date,$mindays,$maxdays);

Make sure a date is in a given range of days from today.

=cut

	my $s = shift;
	my $date = shift;
	my $mindays = shift;
	my $maxdays = shift;

	return 1 unless($date);

	my $ok = $s->db_q("
		SELECT CASE WHEN date(?) BETWEEN date(now() + interval '$mindays day')
			AND date(now() + interval '$maxdays day') THEN TRUE ELSE FALSE END
		",'scalar',
		v => [ $date ]);

	return $ok;
}

sub verify_zipcode {

=head2 verify_zipcode

 my $truefalse = $s->verify_zipcode(\$zip,[\$state],[\$city],[\$country]);

Check the zipcode database for the given zipcode.  If optional references
are included in call and zipcode is valid, these scalar references are
populated with the database information.

=cut

	my $s = shift;
	my $ref = shift;
	my $state = shift;
	my $city = shift;
	my $country = shift;

	$$ref =~ s/^\s+//;
	$$ref =~ s/\s+$//;
	$$ref = uc $$ref;

	if ($$ref =~ m/^([A-Z]\d[A-Z])(\d[A-Z]\d)$/) {
		# canada zipcode, add space in between
		$$ref = "$1 $2";
	}

	my %hash = $s->db_q("
		SELECT z.zipcode, z.state, z.city
		FROM zipcodes z
		WHERE z.zipcode=?
		",'hash',
		v => [ $$ref ]);

	if ($hash{zipcode}) {
		$$state = $hash{state} if (defined($state));
		if (defined($city)) {
			$$city = $hash{city} unless($$city);
		}
		return 1;
	} elsif (defined($country)) {
		my %c = $s->db_q("
			SELECT *
			FROM countries
			WHERE country=?
			",'hash',
			v => [ $$country ]);
		if ($$ref eq '' && $c{country}) {
			return 1;
		} else {
			return 0;
		}
	} else {
		return 0;
	}
}

sub verify_email {

=head2 verify_email

 my $truefalse = $s->verify_email($email);

=cut

	my $s = shift;
	my $ref = shift;

	$$ref =~ s/^\s+//;
	$$ref =~ s/\s+$//;
	$$ref = lc $$ref;

	if ($$ref =~ /^[\.a-zA-Z&0-9_-]*\@(.*\.[a-zA-Z]*)$/) {
		return 1;
	} else {
		return 0;
	}
}

sub verify_regex {

=head2 verify_regex

 my $truefalse = $s->verify_regex($regex);

=cut

	my $s = shift;
	my $regex = shift;

	eval {
		my $reg = qr/^$regex$/;
		};
	
	if ($@) {
		return 0;
	} else {
		return 1;
	}
}

sub verify_phone {

=head2 verify_phone 

 my $truefalse = $s->verify_phone(\$number,[\$other]);

Checks that $number is only numbers and it 10 digits.  Changes
input scalar reference to clean it up.  If $other scalar reference
is provided, and nothing is in $number, then function returns true
which is somewhat of a bypass for non 10 digit phone verification.

=cut

	my $s = shift;
	my $ref = shift;
	my $other = shift;

	$$ref =~ s/\D//g;

	if (length($$ref) == 0 && defined($other)) {
		if ($$other ne '') {
			$$ref = 0;
			return 1;
		}
	}

	return 0 unless(length($$ref) == 10);

	return 1;
}

sub html_orderby {

=head2 html_orderby

 my $html = $s->html_orderby($key,[desc || asc],$params);

=cut

	my $s = shift;
	my $key = shift;
	my $direction = shift;
	my $params = shift;

	if ($s->{in}{"$key $direction"}) {
		return '';
	} elsif ($direction eq 'desc') {
		return $s->html_a("$s->{ubase}/$s->{object}/$s->{function}?ob=$key $direction&$params",'v');
	} elsif ($direction eq 'asc') {
		return $s->html_a("$s->{ubase}/$s->{object}/$s->{function}?ob=$key $direction&$params",'^');
	}
}

sub html_font {

=head2 html_font

 my $html = $s->html_font($text,$size);

=cut

	my $s = shift;
	my $text = shift;
	my $size = shift;

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

		",'arrayhash',
		v => [ $ref, $s->{in}{$s->{o}{id}} ]);

	$s->add_action(function => 'display',
		params => "$s->{o}{id}=$s->{in}{$s->{o}{id}}") if (defined($s->{o}{functions}{display}));

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

sub generic_delete {
	my $s = shift;

	return unless($s->check_in_id());

	my %hash = $s->db_q("SELECT * FROM $s->{o}{view} WHERE $s->{o}{id}=?",'hash',
		v => [ $s->{in}{$s->{o}{id}} ]);

	$s->db_q("DELETE FROM $s->{o}{table}
		WHERE $s->{o}{id}=?
		",undef,
		v => [ $s->{in}{$s->{o}{id}} ]);

	# figure out where we should take them next?
	my $continue;
	if ($s->{o}{subof}) {
		foreach my $f (@{$s->{o}{fields}}) {
			if ($f->{r} eq $s->{o}{subof}) {
				$continue = $s->object_link(
					object => $f->{r},
					function => 'display',
					params => "$f->{i}=$hash{$f->{i}}",
					title => 'Continue');
				last;
			}
		}	
	}

	$continue = $s->object_link(function => 'list',
		title => 'Continue') unless($continue);

	$s->notify("$s->{object} $s->{in}{$s->{o}{id}} deleted. $continue");
}

sub generic_save {
	my $s = shift;

	my %hash;
	my ($city, $state);
	foreach my $ref (@{$s->{o}{fields}}) {
		my $kname = $ref->{i} || $ref->{k};
		next if ($ref->{noedit} && $s->{in}{$s->{o}{id}} =~ m/^\d+$/);

		# if a boolean field is NOT NULL, then make sure it's set to false
		# otherwise the database will blow a cork below on the update statement
		if ($ref->{boolean} && $ref->{notnull} && !defined($s->{in}{$ref->{k}})) {
			$s->{in}{$ref->{k}} = 0;
		}

		$hash{$kname} = $s->{in}{$kname};

		if ($ref->{verify} eq "zipcode" && $hash{$kname}) {
			unless($s->verify_zipcode(\$hash{$kname},\$state,\$city)) {
				croak "$hash{$kname} is not a valid zipcode";
			}
		}

		if ($ref->{verify} eq 'regex' && $hash{$kname}) {
			unless($s->verify_regex($hash{$kname})) {
				croak "$hash{$kname} is not a valid regular expression";
			}
		}

		if ($ref->{verify} eq "phone" && $hash{$kname}) {
			unless($s->verify_phone(\$hash{$kname})) {
				croak "$hash{$kname} is not a valid phone number";
			}
		}

		if ($ref->{verify} eq "email" && $hash{$kname}) {
			unless($s->verify_email(\$hash{$kname})) {
				croak "$hash{$kname} is not a valid email";
			}
		}
	}

	$hash{city} = $city if (defined($hash{city}) && $city);
	$hash{state} = $state if (defined($hash{state}) && $state);

	$s->{dbh}->begin_work;

	if ($s->{in}{$s->{o}{id}} =~ m/^\d+$/) {
		# save an existing record
		$s->db_update_key($s->{o}{table},$s->{o}{id},$s->{in}{$s->{o}{id}},\%hash);
	} else {
		# create a new record
		if (defined($s->{o}{create_session_extra})) {
			my $key = $s->{o}{create_session_extra};
			$hash{$key} = $s->{session_data}{$key};
		}
		$s->{in}{$s->{o}{id}} = $s->db_insert($s->{o}{table},\%hash,$s->{o}{id});
	}

	if ($s->{o}{relations}) {
		foreach my $ref (@{$s->{o}{relations}}) {
			my %existing = $s->db_q("
				SELECT $ref->{k}, $ref->{n} FROM $ref->{t}_v
				WHERE $s->{o}{id}=?",
				'keyval',
				v => [ $s->{in}{$s->{o}{id}} ]);
			# delete rows
			foreach my $id (keys %existing) {
				unless(defined($s->{in}{"$ref->{t}:$id"})) {
					$s->db_q("
						DELETE FROM $ref->{t}
						WHERE $s->{o}{id}=?
						AND $ref->{k}=?
						",undef,
						v => [ $s->{in}{$s->{o}{id}}, $id ]);
				}
			}
			# insert new rows
			foreach my $k (keys %{$s->{in}}) {
				if ($k =~ m/^$ref->{t}:(\S+)$/) {
					my $id = $1;
					unless(defined($existing{$id})) {
						$s->db_insert($ref->{t}, {
							$s->{o}{id} => $s->{in}{$s->{o}{id}},
							$ref->{k} => $id,
							});
					}
				}
			}
		}
	}

	$s->{dbh}->commit;

	$s->{redirect} = "$s->{ubase}/$s->{object}/display?$s->{o}{id}=$s->{in}{$s->{o}{id}}";
}

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


		my $data_import_id = $s->db_insert('data_imports',{
			table_name => $s->{o}{table},
			employee_id => $s->{employee_id},
			count => 0,
			},'data_import_id');

		if ($s->{in}{clear}) {
			my $where;
			if ($s->{subof_key}) {
				$where = " WHERE $s->{subof_key}=$s->{subof_id}";
			}
			if (defined($s->{o}{create_session_extra})) {
				my $key = $s->{o}{create_session_extra};
				$where = " WHERE $key = $s->{session_data}{$key}";
			}
			eval { $s->db_q("DELETE FROM $s->{o}{table}$where"); };
			if ($@) {
				$s->alert("Sorry, could not delete all the existing $s->{object}s");
				return;
			}
		}

		my @r = $s->csv_to_array($file);
		my $count;
		my %default;
		foreach my $k (keys %{$s->{in}}) {
			if ($k =~ m/^default:([^:]+)$/) {
				my $fn = $1;
				if ($s->{in}{"default:$fn:null"}) {
					# override only null values
					$default{null}{$fn} = $s->{in}{$k} if ($s->{in}{$k});
				} else {
					# only override everyting
					$default{all}{$fn} = $s->{in}{$k} if ($s->{in}{$k});
				}
			}
		}

		if (defined($s->{o}{create_session_extra})) {
			my $key = $s->{o}{create_session_extra};
			$default{all}{$key} = $s->{session_data}{$key};
		}

		#$s->alert("<pre>".Data::Dumper->Dump([\%default])."</pre>");
		#return;

		#my @debug;
		for my $i ( 1 .. $#r ) {
			my %import;
			foreach my $n (keys %fmap) {
				$import{$fmap{$n}} = $r[$i][$n-1];
			}

			# clean up....
			foreach my $k (keys %import) {
				$import{$k} =~ s/(\s+|,)$//; # strip trailing spaces and other crap like commas
				$import{$k} =~ s/^\s+//; # strip leading
			}

			# verify....
			foreach my $f (@{$s->{o}{fields}}) {
				if ($import{$f->{k}} && $f->{verify}) {
					if ($f->{verify} eq 'phone') {
						unless($s->verify_phone(\$import{$f->{k}})) {
							$import{$f->{k}} = '';
						}
					} elsif ($f->{verify} eq 'email') {
						unless($s->verify_email(\$import{$f->{k}})) {
							$import{$f->{k}} = '';
						}
					} elsif ($f->{verify} eq 'zipcode') {
						unless($s->verify_zipcode(\$import{$f->{k}},\$import{state},\$import{city})) {
							$import{$f->{k}} = '';
							$import{state} = '';
							$import{city} = '';
						}
					}
				}
			}

			# override values from the file it they were defined
			# in the default values area
			foreach my $k (keys %{$default{all}}) {
				$import{$k} = $default{all}{$k};
			}

			foreach my $k (keys %{$default{null}}) {
				$import{$k} = $default{null}{$k} unless($import{$k});
			}


			#push @debug, { %import };
			$import{data_import_id} = $data_import_id;

			# add any required subof key
			$import{$s->{subof_key}} = $s->{subof_id} if ($s->{subof_key});
			eval { $s->db_insert($s->{o}{table},\%import); };
			if ($@) {
				$s->alert("Error while processing line $i of file: $@\n".
					"<pre>".Data::Dumper->Dump([\%import])."</pre>");
				$s->{dbh}->rollback;
				return;
			} else {
				$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;
	}

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

				$s->db_update_key($s->{o}{table},$s->{o}{id},$hash{$s->{o}{id}},{
					interface_cookie => '',
					});
			}
		} else {
			push @{$s->{r}{set_cookie}}, 'IL=; path="/";';
		}
	}

	return 0;
}

sub _interface_cookie_key {
	my $s = shift;
	my %args = @_;

	my $expire;
	if ($s->{env}{ETERNAL_COOKIE}) {
		$expire = $s->{server_name}; # just add a little more to try and make this unique
	} else {
		$expire = time2str('%x',time());
	}
	return md5_hex("84Fw$args{id}YouSuck$args{passwd}7f2$expire");
}

sub _employee_permissions {
	my $s = shift;

	# build a data structure we can use in add_action to determine if
	# we should even show something to someone

	# first get a list of all actions that are not assigned to a group
	# which means everyone can do them
	# then append to this the actions that this specific person can do
	my @list = $s->db_q("
		SELECT a.a_object, a.a_function
		FROM actions a
			LEFT JOIN group_actions ga ON a.action_id=ga.action_id
		WHERE ga.group_id IS NULL
		UNION
		SELECT a.a_object, a.a_function
		FROM employee_groups eg
			JOIN group_actions ga ON eg.group_id=ga.group_id
			JOIN actions a ON ga.action_id=a.action_id
		WHERE eg.employee_id=?
		",'arrayhash',
		c => "employeepermission$s->{employee_id}",
		cache_for => '60',
		v => [ $s->{employee_id} ]);

	# now, from this list, lets make a data structure we can use
	foreach my $ref (@list) {
		$s->{employee}{object}{$ref->{a_object}}{$ref->{a_function}} = 1;
	}
}

sub _authenticate {
	my $s = shift;

	if ($s->{in}{forgot_email}) {
		if ($s->verify_email(\$s->{in}{forgot_email})) {
			my %employee = $s->db_q("
				SELECT *
				FROM employees
				WHERE email=?
				",'hash',
				v => [ $s->{in}{forgot_email} ]);

			if ($employee{employee_id}) {
				my $new = int(rand(1)*100000);
				$s->db_q("
					UPDATE employees SET passwd=?
					WHERE employee_id=?
					",undef,
					v => [ $new, $employee{employee_id} ]);

				$s->sendmail(to => $employee{email},
					from => 'root@'.$s->{server_name},
					subject => 'Password Reset',
					body => "Your password at $s->{server_name} has has been reset\n\n".
						"username: $employee{login}\n".
						"password: $new\n\n".
						"Please login, and then go change your password.");

				$s->{error}{login} = "Your password has been reset and sent to $employee{email}";
			} else {
				$s->{error}{login} = "Unknown email";
				$s->{in}{forgot} = 1;
			}
		} else {
			$s->{error}{login} = "That is not a valid email";
			$s->{in}{forgot} = 1;
		}
	}	

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

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

	SWITCH: {
		last if ($s->_check_api());
		last if ($s->_check_cookie());
		last if ($s->_check_login());
	}

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

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

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

	unless($s->{in}{ori_args}) {

( run in 1.663 second using v1.01-cache-2.11-cpan-0d23b851a93 )