view release on metacpan or  search on metacpan

examples/upload.pl  view on Meta::CPAN

#!/ford/thishost/unix/div/ap/bin/xperl -w

#use blib;

use strict;
use Sys::Hostname;
use IO::Handle;
use File::Path;
use X11::Motif;
use Date::DateCalc;
use PDM;

use lib qw(.);

use Outline qw(:flags);
use CPSC;

STDERR->autoflush(1);

my @rwx = ( '---', '--x', '-w-', '-wx', 'r--', 'r-x', 'rw-', 'rwx' );
my %uid_to_name = ();
my %gid_to_name = ();

my @today = localtime(time);
		$today[5] += 1900;
		$today[4] += 1;

my @month_name = qw(error Jan Feb Mar Apr May Jun
		          Jul Aug Sep Oct Nov Dec);
my @weekday_name = qw(error Mon Tue Wed Thu Fri Sat Sun);

my %folder_type_name = ( 'a' => 'Acoustic',
			 'c' => 'CFD',
			 'd' => 'Fatigue',
			 'f' => 'NVH',
			 'g' => 'Design Parameters',
			 'k' => 'Kinematic',
			 'r' => 'Fracture Mechanics',
			 's' => 'Stress',
			 't' => 'Thermal',
			 'v' => 'VSA',
			 'p' => 'Performance' );

my $hostname = Sys::Hostname::hostname();
my @userinfo = getpwuid($<);

my $cp_prg = find_executable("cp");

my $metaphase_login;
my $metaphase_password;
my $metaphase_home_db;
my $metaphase_current_db;
my $metaphase_current_project;
my $metaphase_staging_path;
my $metaphase_staging_name;
my $metaphase_session;

my %class_type_long_name = ( 'MstrGeom' => 'Design Geometry',
			     'DrvdGeom' => 'Derived Geometry' );
my %class_type_short_name = ();
my %metaphase_class_info = ();

my %opposite_side = ( 'Left' => 'Right', 'Right' => 'Left' );
my %opposite_side_class = ( 'Left' => 'Class2', 'Right' => 'Class1' );

my $font_size = 180;

#my $font_family_v_r = '-*-lucida-medium-r';
#my $font_family_v_i = '-*-lucida-medium-i';
#my $font_family_f_r = '-*-lucidatypewriter-medium-r';

#my $font_family_v_r = '-*-new century schoolbook-medium-r';
#my $font_family_v_i = '-*-new century schoolbook-medium-i';
#my $font_family_f_r = '-*-courier-medium-r';

my $font_family_v_r = '-*-helvetica-medium-r';
my $font_family_v_i = '-*-helvetica-medium-o';
my $font_family_f_r = '-*-courier-medium-r';

my $menu_font =  "$font_family_v_i-*-*-*-$font_size-*-*-*-*-*-*";
my $label_font = "$font_family_v_r-*-*-*-$font_size-*-*-*-*-*-*";
my $input_font = "$font_family_f_r-*-*-*-$font_size-*-*-*-*-*-*";

my $toplevel = X::Toolkit::initialize('APDataManager');
change $toplevel -title => 'AP Data Manager';

$toplevel->set_inherited_resources("*fontList" => $label_font,
				   "*menubar*fontList" => $menu_font,
				   "*menupopup*fontList" => $menu_font,
				   "*XmTextField.fontList" => $input_font,
				   "*menubar*background" => '#d0d0d0',
				   "*background" => '#d0d0d0',
				   "*foreground" => '#000000');

my $form = give $toplevel -Form;

my $menubar = give $form -MenuBar, -name => 'menubar';
my $menu;
my $submenu;

$menu = give $menubar -Menu, -name => 'File';
	$submenu = give $menu -Menu, -text => 'Create New';
		   give $submenu -Button, -text => 'Folder', -command => \&do_create_new_folder;
		   give $submenu -Button, -text => 'File';
		   give $submenu -Button, -text => 'Note';

examples/upload.pl  view on Meta::CPAN

	if ($query ne '') {
	    push @queries, $query;
	}
    }

    return @queries;
}

sub canonical_file_type {
    my($mode, $filename) = @_;
    my $type;

    if (($mode & 0xF000) == 0x4000) {
	$type = 'directory';
    }
    else {
	$type = 'file';
    }

    $type;
}


sub canonical_file_date {
    my $then = shift;
    my @time = localtime($then);

    if ($then > time - 7776000) {
	my $hour = $time[2];
	my $tod;

	if    ($hour >= 12) { $hour -= 12; $tod = 'pm' }
	else                { $tod = 'am' }
	if    ($hour == 0)  { $hour = 12 }

	"$weekday_name[$time[6]+1] $month_name[$time[4]+1] $time[3], $hour:$time[1] $tod";
    }
    else {
	"$month_name[$time[4]+1] $time[3], ".(1900+$time[5]);
    }
}

sub canonical_file_size {
    my($mode, $links, $size) = @_;

    if (($mode & 0xF000) == 0x4000) {
	$size = '';
    }
    else {
	$size = sprintf('%.2f K', $size / 1024);
	while ($size =~ s/^(-?\d+)(\d{3})/$1,$2/) { }
    }

    $size;
}

sub canonical_file_owner {
    my($uid, $gid) = @_;

    if (!exists $uid_to_name{$uid}) {
	my @info = getpwuid($uid);
	$uid_to_name{$uid} = $info[0];
    }
    $uid = $uid_to_name{$uid};

    if (!exists $gid_to_name{$gid}) {
	my @info = getgrgid($gid);
	$gid_to_name{$gid} = $info[0];
    }
    $gid = $gid_to_name{$gid};

    "$uid/$gid";
}

sub canonical_file_permissions {
    my($mode) = @_;

    my $perms = $rwx[$mode & 7];
    $mode >>= 3;
    $perms = $rwx[$mode & 7] . $perms;
    $mode >>= 3;
    $perms = $rwx[$mode & 7] . $perms;

    $perms;
}

sub canonical_version {
    my($class, $obj, $element) = @_;

    my $ver = $metaphase_session->GetAttribute($obj, 'Sequence');

    if (exists $metaphase_class_info{$class}{'Revision'}) {
	$ver = $metaphase_session->GetAttribute($obj, 'Revision') . '/' . $ver;
    }

    $ver;
}

sub canonical_type {
    my($class, $obj, $element) = @_;

    my $type = $class_type_short_name{$class};

    if (!defined $type) {
	if (exists $metaphase_class_info{$class}{'WorkingRelativePath'}) {
	    my $props = get_all_props($class, $obj, $element);
	    if ($props) {
		$type = $props->{'T'};
		if (defined $type) {
		    $type .= '/'.$props->{'S'};
		}
		else {
		    $type = 'data';
		}
		if (defined $type && defined($props->{'V'})) {
		    $type .= ';'.$props->{'V'};
		}
	    }
	    else {
		$type = $class . ':' . $metaphase_session->GetAttribute($obj, 'm0MIMEType');
		if (defined $type) {