# System.pm: System Web Service package RDA::Web::System; # $Id: System.pm,v 1.26 2015/05/08 18:23:43 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Web/System.pm,v 1.26 2015/05/08 18:23:43 RDA Exp $ # # Change History # 20150508 MSC Improve the documentation. =head1 NAME RDA::Web::System - System Web Service =head1 SYNOPSIS require RDA::Web::System; =head1 DESCRIPTION The objects of the C class are used to display system results from a zipped or expanded report package. The following methods are available: =cut use strict; BEGIN { use Exporter; use RDA::Text qw(get_string); use RDA::Driver::Archive qw($DFT_SET); use RDA::Driver::Sgml qw(encode); use RDA::Driver::Web qw(decode_uri encode_uri fmt_date fmt_mode %MIMES); use RDA::Handle::Block; use RDA::Object; use RDA::Object::Rda; } # Define the global public variables use vars qw($STRINGS $VERSION @DELETE @ISA); $VERSION = sprintf('%d.%02d', q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/); @DELETE = qw(_ctl); @ISA = qw(Exporter); # Define the global constants my $DOC = q{}; my $EOL = qq{\015\012}; my $NAM = q{system}; # Define the main tabs my @tb_tab = ( ['rda', 'TabRda', '/rda/%s/', 'rda_menu'], # Text:TabRda ['explorer', 'TabExplorer', '/explorer/%s/', 'exp_dir'], # Text:TabExplorer ['system', 'TabSystem', '/system/%s', 'sys_dir'], # Text:TabSystem ['tool', 'TabTool', '/tool/%s', 'tool_menu'], # Text:TabTool ['package', 'TabPackage', '/package/%s', 'pkg_dir'], # Text:TabPackage ['help', 'TabHelp', '/help/man', 'rda_man'], # Text:TabHelp ); my %tb_dsc = ( Cygwin => {cls => 'RDA::Local::Windows', cnv => \&_w_convert, itm => \&_w_item, lnk => \&_w_link, nat => \&_w_native, nrm => \&_w_norm, top => \&_w_top, uri => \&_w_uri, }, Unix => {cls => 'RDA::Local::Unix', cnv => \&_u_convert, itm => \&_u_item, lnk => \&_u_link, nat => \&_u_native, nrm => \&_u_norm, top => \&_u_top, uri => \&_u_uri, }, Vms => {cls => 'RDA::Local::Vms', cnv => \&_v_convert, itm => \&_v_item, lnk => \&_v_link, nat => \&_v_native, nrm => \&_v_norm, top => \&_v_top, uri => \&_v_uri, }, Windows => {cls => 'RDA::Local::Windows', cnv => \&_w_convert, itm => \&_w_item, lnk => \&_w_link, nat => \&_w_native, nrm => \&_w_norm, top => \&_w_top, uri => \&_w_uri, }, ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Web::System-Enew($req,$agt,$svc)> The object constructor. This method enables you to specify the request, the agent and service hash references as arguments. C is represented by a blessed hash reference. The following special key is used: =over 12 =item S< B<'_agt'> > Reference to the agent object =item S< B<'_cfg'> > Reference to the RDA software configuration =item S< B<'_css'> > Style definition =item S< B<'_ctl'> > Reference to the archive control object =item S< B<'_dft'> > Platform of the default result set =item S< B<'_not'> > Page notice definition =item S< B<'_pre'> > URL prefix =item S< B<'_pth'> > Archive path =item S< B<'_svc'> > Service hash =item S< B<'_web'> > Reference to the Web rendering object =back Internal keys are prefixed by an underscore. The associated data are stored in a control hash containing the following keys: =over 11 =item S< B<'dsc'> > Platform-specific descriptor =item S< B<'idx'> > File tree =item S< B<'max'> > Maximum customer file management level =item S< B<'oid'> > Result set identifier =item S< B<'slf'> > Reference to the result set control object =item S< B<'tab'> > Tab definition =back =cut sub new { my ($cls, $req, $agt, $svc) = @_; my ($cfg, $pth, @att); # Validate the archive $cfg = $agt->get_config; if ($req->get_first('private')) { if (defined($pth = $req->get_first('archive')) || defined($pth = $agt->get_info('zip'))) { return unless (-f $pth || -d $pth) && -r $pth; @att = (_pth => $pth); } else { return unless defined($pth = $agt->get_collector->get_data) && -d $pth && -r $pth; @att = (_dft => $cfg->get_family, _pth => $pth); } } else { @att = (_ctl => $agt->get_registry('WEB.ARC', \&RDA::Driver::Archive::new, 'RDA::Driver::Archive', ## no critic (Call) $agt)); } # Create the service object and return its reference return bless { _agt => $agt, _cfg => $cfg, _css => $req->get_first('css'), _not => $req->get_first('notice'), _pre => $req->get_first('prefix', q{}), _svc => $svc, _web => RDA::Driver::Web->new($agt->get_config), @att, }, ref($cls) || $cls; } =head2 S<$h-Edelete_object> This method deletes the display object. =cut sub delete_object { RDA::Object::dump_caller($_[0], 'Web') if $RDA::Object::DELETE; undef %{$_[0]}; undef $_[0]; return; } =head2 S<$h-Erequest($ofh,$met,$url)> This method executes a display request. It returns 0 on successful completion. Otherwise, it returns a non-zero value. =cut sub request ## no critic (Complex) { my ($slf, $ofh, $met, $req) = @_; my ($buf, $dat, $det, $ifh, $nam, $new, $rel, $ttl); # Get the archive control object $slf->{'_ctl'} = $slf->{'_agt'}->get_registry('WEB.ARC', \&RDA::Driver::Archive::new, 'RDA::Driver::Archive', ## no critic (Call) $slf->{'_agt'}, $slf->{'_pth'}, 1) unless exists($slf->{'_ctl'}); # Select the package if ($req =~ s{\A([\dA-Fa-f]{32}(?:-\d+)?)(?:\/|\z)}{}) { return 10 unless ($dat = $slf->{'_ctl'}->get_data($NAM, $1)); $dat->{'dsc'} = $tb_dsc{$dat->{'slf'}->get_family}; } else { return 10 unless ($dat = $slf->{'_ctl'}->get_data($NAM, $DFT_SET)); $dat->{'dsc'} = $tb_dsc{exists($slf->{'_dft'}) ? $slf->{'_dft'} : $dat->{'slf'}->get_family}; } # Define the available tabs and analyze the result set on first use unless (exists($dat->{'tab'})) { my ($svc, $tab, $url, $tid); # Define the tabs $dat->{'tab'} = $tab = []; $svc = $slf->{'_svc'}; foreach my $rec (@tb_tab) { ($nam, $ttl, $url, $tid) = @{$rec}; push(@{$tab}, [get_string($ttl), sprintf($url, $dat->{'oid'}), $tid]) if exists($svc->{$nam}); } # Build the directory tree $dat->{'max'} = 3 unless exists($dat->{'max'}); foreach my $nam ($dat->{'slf'}->get_files('I')) { _extract_index($slf, $dat, $ifh) if defined($ifh = $dat->{'slf'}->find_handle($nam)); } foreach my $nam ($dat->{'slf'}->get_files('D')) { _extract_stat($slf, $dat, $ifh) if defined($ifh = $dat->{'slf'}->find_handle($nam)); } } # Validate the request $req = decode_uri($req); return _dsp_cfm($ofh, $slf, $dat, $req) if $req =~ s/^cfm\///; return _dsp_file($ofh, $slf, $dat, $req) if $req =~ s/^file\///; return 1 if $req =~ m{(^|\/)\.+(\/|\z)}; ($nam, $ttl, $det, $rel) = eval {_dsp_dir($slf, $dat, $req)}; return [$slf->{'_agt'}->add_error($@)->pop_errors(1)] if $@; return 2 unless defined($det); # Generate the page $buf = q{HTTP/1.0 200 OK}.$EOL .q{Content-Type: text/html; charset=UTF-8}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $buf, length($buf)); eval { $slf->{'_web'}->render($ofh, { css => $slf->{'_css'}, det => $det, nam => $nam, not => $slf->{'_not'}, pre => $slf->{'_pre'}, rel => $rel, tab => $dat->{'tab'}, ttl => $ttl, }); }; syswrite($ofh, $@, length($@)) if $@; # Indicate a successful completion return 0; } # --- Page generation routines ------------------------------------------------ # Treat a CFM request sub _dsp_cfm { my ($ofh, $slf, $dat, $req) = @_; my ($buf); # Force rediscovery if ($req =~ m/^(\d)$/) { $dat->{'max'} = $1; delete($dat->{'idx'}); delete($dat->{'tab'}); } # Redirect to the new result set $buf = q{HTTP/1.0 302 OK}.$EOL .q{Location: }.$slf->{'_pre'}.q{/system/}.$dat->{'oid'}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $buf, length($buf)); # Indicate a successful completion return 0; } # Treat a directory request sub _dsp_dir ## no critic (Complex) { my ($slf, $dat, $req) = @_; my ($buf, $cls, $cur, $dir, $dsp, $fct, $flg, $lnk, $mod, $nam, $oid, $pth, $rec, $ref, $rel, $siz, $sta, $ttl, @dir, @rel, %dir); # Determine the node return ('sys_none', $req, [[\&_write, q{
}.get_string('None')]]) unless exists($dat->{'idx'}); return ('sys_unknown', $req, [[\&_write, q{
}.get_string('Unknown', $req)]]) unless defined($cur = _get_node($dat, $req)); # Generate the report body $cls = $dat->{'dsc'}->{'cls'}; $dsp = $dat->{'dsc'}->{'itm'}; $fct = $dat->{'dsc'}->{'nrm'}; $oid = $dat->{'oid'}; @dir = _get_directory($cur); $dir = &{$dat->{'dsc'}->{'nat'}}($dat, @dir, q{}); $ttl = @dir ? get_string('TtlSubDir', $dir) : get_string('TtlTopDir'); $buf = qq{

$ttl

\n\n} .q{} .q{} .q{} .q{} .q{} .q{} .q{} .qq{\n}; foreach my $key (sort keys(%{$cur->[1]})) { $rec = $cur->[1]->{$key}; $lnk = q{}; $ref = ref($sta = $rec->[0]); $flg = (ref($rec->[1]) ne 'HASH') ? -1 : ($key ne q{.}) ? 1 : 0; if ($ref eq 'ARRAY') { $mod = fmt_mode($sta->[2]); $siz = ($mod =~ m/^[bc]/) ? sprintf(q{%d, %d}, $sta->[3] >> 8, $sta->[3] & 255) ## no critic (Bit) : $sta->[7]; $buf .= qq{} .q{} .q{} .q{} .qq{} .q{}; if (defined($pth = $sta->[13])) { $lnk = q{ → }.encode( &{$dat->{'dsc'}->{'lnk'}}(_dec_path($pth))); if (defined($pth = $sta->[14])) { $pth = $cls->dirname(&$fct(_dec_path($pth))); $dir{$pth} = 1 if $pth ne $dir; } } } elsif ($ref eq 'HASH') { $buf .= q{} .q{} .q{} .q{} .q{} .q{}; $lnk = q{ → }.encode(&$fct($sta->{'lnk'})) if exists($sta->{'lnk'}); } else { next unless $flg; $sta = q{}; (undef, $sta) = split(/\//, $rec->[1], 3)if !$flg && defined($rec->[1]); $buf .= q{} .q{} .q{} .q{} .qq{} .q{}; } $nam = encode(length($key) ? &$dsp($key) : q{/}); $buf .= q{\n}; } $buf .= q{
ModeLinksUIDGIDSizeLast ModificationName
$mod}.$sta->[3].q{}.$sta->[4].q{}.$sta->[5].q{$siz}.fmt_date($sta->[9]).q{
}.$sta->{'mod'} .q{}.$sta->{'nbl'}.q{}.$sta->{'usr'}.q{}.$sta->{'grp'}.q{}.$sta->{'siz'}.q{}.$sta->{'dat'}.q{
}.(($flg > 0) ? q{d} : q{}).q{$sta} .(($flg > 0) ? q{$nam} : ($flg && defined($rec->[1])) ? q{$nam} : $nam) .qq{$lnk

}.get_string('Warning'); # Generate related links $fct = $dat->{'dsc'}->{'uri'}; push(@rel, [[get_string('SctSystem'), [map {[encode($_), &$fct($oid, $_), 'sys']} sort @dir]]]) if (@dir = keys(%dir)); push(@rel, [[get_string('SctCfm'), [map {[encode(get_string('Level', $_)), qq{/system/$oid/cfm/$_}, qq{cfm_$_}]} grep {$_ != $dat->{'max'}} qw(0 1 2 3) ]]]) unless defined($cur->[3]); $rel = [@rel] if @rel; # Return the report descriptor $nam = 'sys_dir_'.$req; $nam =~ s/[_\W]+/_/g; $nam =~ s/_$//; return ($nam, $ttl, [[\&_write, $buf]], $rel); } # Treat a file request sub _dsp_file { my ($ofh, $slf, $dat, $req) = @_; my ($blk, $bfh, $buf, $cur, $hdr, $ifh, $lgt, $suf, $typ); return 3 unless exists($dat->{'idx'}) ## no critic (Unless) && defined($cur = _get_node($dat, $req)) && defined($blk = $cur->[1]) && ref($blk) ne 'HASH'; $blk = [split(/\//, $blk, 6)]; return 4 if (defined($blk->[4]) ? $blk->[4] : 2) > $dat->{'max'}; if ($blk->[1]) { # Open the file return 5 unless defined($ifh = $dat->{'slf'}->find_report($blk->[2], $blk->[3])); binmode($ifh); return 6 unless ($bfh = RDA::Handle::Block->new($ifh, $blk->[0], $blk->[1])); # Determine the MIME type $lgt = 0; if ($req =~ m/\.([a-z][a-z0-9]*)$/i && exists($MIMES{$suf = lc($1)})) { $typ = $MIMES{$suf}; } else { $lgt = $bfh->sysread($buf, 4096); $typ = ( $buf =~ m/[^\b\f\n\r\t\040-\176]/) ? 'application/octet-stream' : 'text/plain'; } # Generate the page $hdr = q{HTTP/1.0 200 OK}.$EOL .qq{Content-Type: $typ; charset=UTF-8}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $hdr, length($hdr)); syswrite($ofh, $buf, $lgt) if $lgt; while ($lgt = $bfh->sysread($buf, 4096)) { syswrite($ofh, $buf, $lgt); } $bfh->close; $ifh->close; } else { # Generate an empty page $hdr = q{HTTP/1.0 200 OK}.$EOL .q{Content-Type: text/plain; charset=UTF-8}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $hdr, length($hdr)); } # Indicate a successful completion return 0; } # Get directory sub _get_directory { my ($cur) = @_; my (@bas); for (;;) ## no critic (Loop) { return @bas unless defined($cur->[3]); unshift(@bas, $cur->[3]); $cur = $cur->[1]->{q{..}}; } } # Get URI sub _get_uri { my ($cur, $pre, @bas) = @_; for (;;) ## no critic (Loop) { return encode_uri($pre, @bas) unless defined($cur->[3]); unshift(@bas, $cur->[-1]); $cur = $cur->[1]->{q{..}}; } } # Write the buffer sub _write { my ($ofh, $buf) = @_; return syswrite($ofh, $buf, length($buf)); } # --- Explorer report management routines ------------------------------------- # Add a directory entry sub _add_dir { my ($dat, $pth, $alt) = @_; my ($cur, $fct, $fil, $lvl, $new, $syn, @dir, @syn); @dir = split(/\//, $pth, -1); # Needs all fields to support '/' if (defined($alt)) { @syn = split(/\//, $alt, -1); # Needs all fields to support '/' @syn = () unless (scalar @dir) == (scalar @syn); } $cur = $dat->{'idx'}; $fct = $dat->{'dsc'}->{'cnv'}; $lvl = 0; foreach my $itm (@dir) { $syn = shift(@syn); next unless length($itm) || $lvl == 0; die get_string('BAD_DIR', $pth) unless ref($cur->[1]) eq 'HASH'; # Check for tree improvement $itm = &$fct($cur, $itm, $itm); if (defined($syn)) { $syn = &$fct($cur, $syn, $syn); if ($syn ne $itm && exists($cur->[1]->{$syn})) { if (exists($cur->[1]->{$itm})) { _merge_nodes($cur->[1]->{$itm}, delete($cur->[1]->{$syn}), $pth); } else { $cur->[1]->{$itm} = $new = delete($cur->[1]->{$syn}); $new->[3] = $itm; } $cur->[2]->{lc($syn)} = $itm; } } # Create new node when needed unless (exists($cur->[1]->{$itm})) { $cur->[1]->{$itm} = $new = [undef, {}, {}, $itm]; $new->[1]->{q{.}} = $new; $new->[1]->{q{..}} = $cur; $new->[4] = &{$dat->{'dsc'}->{'top'}}($itm) unless $lvl; if (defined($syn)) { $syn = &$fct($cur, $syn, $syn); $cur->[2]->{lc($syn)} = $itm if $syn ne $itm; } } # Make it the current node $cur = $cur->[1]->{$itm}; $lvl++; } return $cur; } # Add a file entry sub _add_file { my ($dat, $pth) = @_; my ($cur, $dir, $fil, $lvl, $sub, @dir); if ($pth =~ m{^(.*/)(.*)$}) { ($cur, $fil) = (_add_dir($dat, $1), $2); die get_string('BAD_DIR', $pth) unless ref($cur->[1]) eq 'HASH'; } else { ($cur, $fil) = ($dat->{'idx'}, $pth); } # Return an existing record if (defined($sub = &{$dat->{'dsc'}->{'cnv'}}($cur, $fil))) { $cur = $cur->[1]->{$sub}; if (ref($cur->[1]) eq 'HASH') { die get_string('BAD_FILE', $pth) if (scalar keys(%{$cur->[1]})) > 2; $cur->[1] = []; } return $cur; } # Create a new file node return $cur->[1]->{$fil} = []; } # Decode a path sub _dec_path { my ($pth) = @_; $pth = RDA::Object::decode($1) if $pth =~ m/^"([^"]*)"$/; return $pth; } # Extract index information sub _extract_index { my ($slf, $dat, $ifh) = @_; my ($cls, $cmd, $fct, $max, $pth, $typ, @blk, @cmd, @rec); # Create the file tree $dat->{'idx'} = [undef, {}, {}] unless exists($dat->{'idx'}); # Load the index information eval { $cls = $dat->{'dsc'}->{'cls'}; $fct = $dat->{'dsc'}->{'nrm'}; $max = $dat->{'max'}; while (<$ifh>) { ($typ, @rec) = split(/\|/, $_, -1); # Needs all fields for the pop pop(@rec); if ($typ eq 'S') { _add_dir($dat, &$fct($pth), &$fct(_dec_path($rec[1]))) if $cls->is_absolute($pth = _dec_path($rec[0])); } elsif ($typ eq 'F') { @blk = split(/\//, $rec[1], 6); _add_file($dat, &$fct(_dec_path($rec[2])))->[1] = $rec[1] if $rec[3] eq 'F' && defined($blk[1]) && (defined($blk[4]) ? $blk[4] : 2) <= $max; } elsif ($typ eq 'C') { $cmd = _dec_path($rec[2]); next unless $cmd =~ m{^/usr/bin/ls\s+-(\w+)\s+(.*)}; $cmd = [$rec[1], $1, $2]; push(@cmd, $cmd) unless index($1, 'l') < 0 ## no critic (Unless) || $rec[1] =~ m{^\d+/0/}; } } }; $slf->{'_agt'}->add_error($@) if $@; $ifh->close; # Parse the ls outputs eval { foreach my $cmd (@cmd) { _extract_ls($dat, (index($cmd->[1], 'd') < 0) ? \&_ext_ll : \&_ext_ld, $fct, $cmd->[0], split(/\s+/, $cmd->[2])); } }; return; } # Extract file information from /bin/ls -ld output sub _extract_ls { my ($dat, $ext, $fct, $blk, $dir) = @_; my ($bfh, $fil, $ifh, $off, $siz, $typ); ($off, $siz, $typ, $fil) = split(/\//, $blk); if ($ifh = $dat->{'slf'}->find_report($typ, $fil)) { binmode($ifh); if ($bfh = RDA::Handle::Block->new($ifh, $off, $siz)) { &$ext($dat, $fct, $bfh, $dir); $bfh->close; } $ifh->close; } return; } sub _ext_ld { my ($dat, $fct, $bfh) = @_; while (<$bfh>) { my ($cur, $lnk, $sta); s/[\n\r\s]+$//; $lnk = $1 if s/\s+->\s+(.*)$//; next unless m{^((\S)\S+)\s+(\d+)\s+(\S+)\s+(\S+)\s+((\d*,\s*)?\d+)\s+(.*?)\s+(/.*)$}; $sta = { dat => $8, grp => $5, nbl => $3, mod => $1, siz => $6, usr => $4, }; $cur = ($2 eq 'd') ? _add_dir($dat, &$fct($9)) : _add_file($dat, &$fct($9)); $cur->[0] = $sta unless ref($cur->[0]); $cur->[0]->{'lnk'} = $lnk if defined($lnk); } return; } sub _ext_ll { my ($dat, $fct, $bfh, $dir) = @_; while (<$bfh>) { my ($cur, $lnk, $sta); s/[\n\r\s]+$//; if (m/^$/) ## no critic (Fixed) { $dir = undef; next; } unless (defined($dir)) { $dir = $1 if m{^(/.*):$}; next; } next if m/^total:/i; $lnk = $1 if s/\s+->\s+(.*)$//; next unless m{^((\S)\S+)\s+(\d+)\s+(\S+)\s+(\S+)\s+((\d*,\s*)?\d+)\s(.{11}.*?)\s(.*)}; $sta = { dat => $8, grp => $5, nbl => $3, mod => $1, siz => $6, usr => $4, }; $cur = ($2 eq 'd') ? _add_dir($dat, &$fct("$dir/$9")) : _add_file($dat, &$fct("$dir/$9")); $cur->[0] = $sta unless ref($cur->[0]); $cur->[0]->{'lnk'} = $lnk if defined($lnk); } return; } # Extract file status information sub _extract_stat { my ($slf, $dat, $ifh) = @_; my ($alt, $cur, $fct, $pth, @sta); # Create the file tree $dat->{'idx'} = [undef, {}, {}] unless exists($dat->{'idx'}); # Load the metadata file eval { $fct = $dat->{'dsc'}->{'nrm'}; while (<$ifh>) { ($pth, @sta) = split(/\|/, $_, -1); # Needs all fields for the pop pop(@sta); next unless @sta; ((($sta[2] & 0170000) == 040000) ## no critic (Bit,Number,Zero) ? _add_dir($dat, &$fct(_dec_path($pth))) : _add_file($dat, &$fct(_dec_path($pth))))->[0] = [@sta]; } }; $slf->{'_agt'}->add_error($@) if $@; $ifh->close; return; } # Get a node sub _get_node { my ($dat, $nam) = @_; my ($cur, $fct, $lvl, $typ, @sub); # Determine the search root ($typ, @sub) = split(/\//, $nam); if ($typ eq 'root') { unshift(@sub, q{}); } elsif ($typ eq 'drive') { $typ = shift(@sub) || 'C'; unshift(@sub, uc($typ).q{:}); } # Search for the node $cur = $dat->{'idx'}; $fct = $dat->{'dsc'}->{'cnv'}; $lvl = 0; foreach my $sub (@sub) { next unless $lvl == 0 || length($sub); return unless ref($cur->[1]) eq 'HASH'; return unless defined($sub = &$fct($cur, $sub)); $cur = $cur->[1]->{$sub}; ++$lvl; } return $cur; } # Merge nodes sub _merge_nodes { my ($dst, $src, $pth) = @_; my ($cur, @key); # Merge directory information $dst->[0] = $src->[0] unless defined($dst->[0]); # Merge entries if (ref($src->[1]) eq 'HASH') { delete($src->[1]->{q{.}}); delete($src->[1]->{q{..}}); if (@key = keys(%{$src->[1]})) { die get_string('BAD_DIR', $pth) unless ref($dst->[1]) eq 'HASH'; foreach my $key (@key) { $cur = $src->[1]->{$key}; $cur->[1]->{q{..}} = $dst if ref($cur->[1]) eq 'HASH'; if (exists($dst->[1]->{$key})) { _merge_nodes($dst->[1]->{$key}, $cur, $pth); } else { $dst->[1]->{$key} = $cur; } } foreach my $key (keys(%{$src->[2]})) { $dst->[2]->{$key} = $src->[2]->{$key}; } } } elsif (ref($dst->[1]) eq 'HASH') { die get_string('BAD_FILE', $pth) if (scalar @{$dst->[1]}) > 2; $dst->[1] = $src->[1]; $dst->[2] = undef; } else { push(@{$dst->[1]}, @{$src->[1]}); } # Delete the source entry undef @{$src}; return; } # --- UNIX-specific routines -------------------------------------------------- # Convert the directory element sub _u_convert { my ($cur, $sub, $dft) = @_; return exists($cur->[1]->{$sub}) ? $sub : $dft; } # Normalize the directory entry sub _u_item { return shift; } # Normalize the link sub _u_link { return shift; } # Create a native path sub _u_native { my ($dat, @pth) = @_; return $dat->{'dsc'}->{'cls'}->cat_dir(@pth); } # Normalize the path sub _u_norm { return shift; } # Determine the top element sub _u_top { my ($str) = @_; return ($str eq q{}) ? 'root' : $str; } # Generate the URL sub _u_uri { my ($oid, $pth) = @_; my ($top, @sub); ($top, @sub) = split(/\//, $pth, -1); return ($top eq q{}) ? join(q{/}, '/system', $oid, 'root', @sub) : join(q{/}, '/system', $oid, 'dir', $top, @sub); } # --- VMS-specific routines --------------------------------------------------- # Convert the directory element sub _v_convert { my ($cur, $sub, $dft) = @_; my ($ref, $tbl); $tbl = $cur->[1]; return $sub if exists($tbl->{$sub}); $ref = lc($sub); foreach my $dir (keys(%{$tbl})) { return $dir if lc($dir) eq $ref; } return $dft; } # Normalize the directory entry sub _v_item { my ($nam) = @_; return ($nam eq q{.}) ? undef : ($nam eq q{..}) ? q{[-]} : ($nam =~ m/[\:\.]/) ? $nam : $nam.q{.DIR}; } # Normalize the link sub _v_link { return shift; } # Create a native path sub _v_native { my ($dat, $drv, @pth) = @_; my ($dir, $nam); $nam = pop(@pth); if ($drv eq 'root') { $drv = q{}; } elsif ($drv !~ m/:$/) { unshift(@pth, $drv); $drv = q{}; } $dir = q{[}.join(q{.}, @pth).q{]}; $dir =~ s/\[\]//g; return $drv.$dir.$nam; } # Normalize the path sub _v_norm { my ($pth) = @_; my (@tbl); push(@tbl, $1) if $pth =~ s/^([^:]*:)//; while ($pth =~ s/\[(.*?)\]//) { push(@tbl, split(/\./, $1)); } push(@tbl, $pth) if length($pth); return join(q{/}, @tbl); } # Determine the top element sub _v_top { my ($str) = @_; return ($str eq q{}) ? 'root' : ($str =~ m/^(.*)\:$/) ? "drive/$1" : $str; } # Generate the URL sub _v_uri { my ($oid, $pth) = @_; my ($top, @sub); push(@sub, $1) if $pth =~ s/^([^:]*:)//; while ($pth =~ s/\[(.*?)\]//) { push(@sub, split(/\./, $1)); } push(@sub, $pth) if length($pth); $top = shift(@sub); return ($top eq q{}) ? join(q{/}, '/system', $oid, 'root', @sub) : ($top =~ m/^(.*)\:$/) ? join(q{/}, '/system', $oid, 'drive', $top, @sub) : join(q{/}, '/system', $oid, 'dir', $top, @sub); } # --- Windows-specific routines ----------------------------------------------- # Convert the directory element sub _w_convert { my ($cur, $sub, $dft) = @_; my ($ref, $tbl); $tbl = $cur->[1]; return $sub if exists($tbl->{$sub}); $ref = lc($sub); return $cur->[2]->{$ref} if exists($cur->[2]->{$ref}); foreach my $dir (keys(%{$tbl})) { return $dir if lc($dir) eq $ref; } return $dft; } # Normalize the directory entry sub _w_item { return shift; } # Normalize the link sub _w_link { my ($pth) = @_; $pth =~ s{\\}{/}g; $pth =~ s{^/cygdrive/([a-z])/}{\u$1:/}i; $pth =~ s{^([a-z]):}{\u$1:}; $pth =~ s{/}{\\}g if $pth =~ m{^([A-Z]:|//\w+/)}; return $pth; } # Create a native path sub _w_native { my ($dat, @pth) = @_; my ($pth); return (@pth && $pth[0] =~ m/:$/) ? $dat->{'dsc'}->{'cls'}->cat_native(@pth, q{}) : length($pth = join(q{/}, @pth)) ? $pth : q{/}; } # Normalize the path sub _w_norm { my ($pth) = @_; $pth =~ s{\\}{/}g; $pth =~ s{^/cygdrive/([a-z])/}{\u$1:/}i; $pth =~ s{^([a-z]):}{\u$1:}; return $pth; } # Determine the top element sub _w_top { my ($str) = @_; return ($str eq q{}) ? 'root' : ($str =~ m/^([A-Za-z]):$/) ? 'drive/'.lc($1) : $str; } # Generate the URL sub _w_uri { my ($oid, $pth) = @_; my ($top, @sub); $pth =~ s{\\}{/}g; $pth =~ s{^/cygdrive/([a-z])/}{$1:/}i; ($top, @sub) = split(/\//, $pth, -1); return ($top eq q{}) ? join(q{/}, '/system', $oid, 'root', @sub) : ($top =~ m/^([A-Za-z]):$/) ? join(q{/}, '/system', $oid, 'drive', lc($1), @sub) : join(q{/}, '/system', $oid, 'dir', $top, @sub); } 1; __END__ =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L, L, L =head1 COPYRIGHT NOTICE Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved. =head1 TRADEMARK NOTICE Oracle and Java are registered trademarks of Oracle and/or its affiliates. Other names may be trademarks of their respective owners. =cut