← Back to branch summary

~ubuntu-branches/ubuntu/vivid/libxml-bare-perl/vivid

« back to all changes in this revision

Viewing changes to Bare.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur, Jonathan Yu, Ryan Niebur, Nathan Handler
  • Date: 2009-08-12 09:42:24 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20090812094224-bo487a59xgom7d8l
Tags: 0.45-1
[ Jonathan Yu ]
* New upstream release
  + UTF-8 handling fixed
  + Self-closing nodes are now printed by the XML function
* Added myself to Uploaders and Copyright
* Use new debhelper 7 short rules format
* Standards-Version 3.8.2 (no changes)
* Rewrote control description
* New upstream release
  + Prevent XML corruption during XML saving
  + Fix strange compilation problems by removing line number defines

[ Ryan Niebur ]
* add debian/clean
* Add myself to Uploaders

[ Nathan Handler ]
* debian/watch: Update to ignore development releases.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bare.pm
3
3
use Carp;
4
4
use strict;
5
5
use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
 
6
use utf8;
6
7
require Exporter;
7
8
require DynaLoader;
8
9
@ISA = qw(Exporter DynaLoader);
9
10
 
10
11
 
11
 
$VERSION = "0.43";
 
12
$VERSION = "0.45";
12
13
 
13
14
 
14
15
use vars qw($VERSION *AUTOLOAD);
27
28
 
28
29
=head1 VERSION
29
30
 
30
 
0.42
 
31
0.45
31
32
 
32
33
=cut
33
34
 
500
501
  my $root = shift;
501
502
  my %ret;
502
503
  foreach my $name ( keys %$root ) {
503
 
    my $val = $root->{$name}{'value'} || '';
 
504
    next if( $name =~ m|^_| || $name eq 'comment' || $name eq 'value' );
 
505
    my $val = xval $root->{$name};
504
506
    $ret{ $name } = $val;
505
507
  }
506
508
  return \%ret;
515
517
  my $self = shift;
516
518
  return if( ! $self->{ 'xml' } );
517
519
  
518
 
  open  F, '>' . $self->{ 'file' };
519
 
  print F $self->xml( $self->{'xml'} );
 
520
  my $xml = $self->xml( $self->{'xml'} );
 
521
  
 
522
  my $len;
 
523
  {
 
524
    use bytes;  
 
525
    $len = length( $xml );
 
526
  }
 
527
  return if( !$len );
 
528
  
 
529
  open  F, '>:utf8', $self->{ 'file' };
 
530
  print F $xml;
 
531
  
 
532
  seek( F, 0, 2 );
 
533
  my $cursize = tell( F );
 
534
  if( $cursize != $len ) { # concurrency; we are writing a smaller file
 
535
    warn "Truncating File $self->{'file'}";
 
536
    truncate( F, $len );
 
537
  }
 
538
  seek( F, 0, 2 );
 
539
  $cursize = tell( F );
 
540
  if( $cursize != $len ) { # still not the right size even after truncate??
 
541
    die "Write problem; $cursize != $len";
 
542
  }
520
543
  close F;
521
544
}
522
545
 
550
573
 
551
574
sub obj2xml {
552
575
  my ( $objs, $name, $pad, $level, $pdex ) = @_;
553
 
  
554
576
  $level  = 0  if( !$level );
555
 
  $pad    = '' if(  $level == 1 );
 
577
  $pad    = '' if(  $level <= 2 );
556
578
  my $xml = '';
557
579
  my $att = '';
558
580
  my $imm = 1;
561
583
  my @dex = sort { 
562
584
    my $oba = $objs->{ $a };
563
585
    my $obb = $objs->{ $b };
564
 
    if( !$oba ) { return 0; }
565
 
    if( !$obb ) { return 0; }
 
586
    my $posa = 0;
 
587
    my $posb = 0;
566
588
    $oba = $oba->[0] if( ref( $oba ) eq 'ARRAY' );
567
589
    $obb = $obb->[0] if( ref( $obb ) eq 'ARRAY' );
568
 
    if( ref( $oba ) eq 'HASH' && ref( $obb ) eq 'HASH' ) {
569
 
      my $posa = $oba->{'_pos'}*1;
570
 
      my $posb = $obb->{'_pos'}*1;
571
 
      if( !$posa ) { $posa = 0; }
572
 
      if( !$posb ) { $posb = 0; }
573
 
      return $posa <=> $posb;
574
 
    }
575
 
    return 0;
 
590
    if( ref( $oba ) eq 'HASH' ) { $posa = $oba->{'_pos'} || 0; }
 
591
    if( ref( $obb ) eq 'HASH' ) { $posb = $obb->{'_pos'} || 0; }
 
592
    return $posa <=> $posb;
576
593
  } keys %$objs;
577
594
  for my $i ( @dex ) {
578
595
    my $obj  = $objs->{ $i } || '';
621
638
  my $pad2 = $imm ? '' : $pad;
622
639
  my $cr = $imm ? '' : "\n";
623
640
  if( substr( $name, 0, 1 ) ne '_' ) {
624
 
    if( $name ) { $xml = $pad . '<' . $name . $att . '>' . $cr . $xml . $pad2 . '</' . $name . '>'; }
625
 
    return $xml."\n" if( $level );
 
641
    if( $name ) {
 
642
      if( $xml ) {
 
643
        $xml = $pad . '<' . $name . $att . '>' . $cr . $xml . $pad2 . '</' . $name . '>';
 
644
      }
 
645
      else {
 
646
        $xml = $pad . '<' . $name . $att . ' />';
 
647
      }
 
648
    }
 
649
    return $xml."\n" if( $level > 1 );
626
650
    return $xml;
627
651
  }
628
652
  return '';
653
677
  my @dex = sort { 
654
678
    my $oba = $objs->{ $a };
655
679
    my $obb = $objs->{ $b };
656
 
    if( !$oba ) { return 0; }
657
 
    if( !$obb ) { return 0; }
 
680
    my $posa = 0;
 
681
    my $posb = 0;
658
682
    $oba = $oba->[0] if( ref( $oba ) eq 'ARRAY' );
659
683
    $obb = $obb->[0] if( ref( $obb ) eq 'ARRAY' );
660
 
    if( ref( $oba ) eq 'HASH' && ref( $obb ) eq 'HASH' ) {
661
 
      my $posa = $oba->{'_pos'}*1;
662
 
      my $posb = $obb->{'_pos'}*1;
663
 
      if( !$posa ) { $posa = 0; }
664
 
      if( !$posb ) { $posb = 0; }
665
 
      return $posa <=> $posb;
666
 
    }
667
 
    return 0;
 
684
    if( ref( $oba ) eq 'HASH' ) { $posa = $oba->{'_pos'} || 0; }
 
685
    if( ref( $obb ) eq 'HASH' ) { $posb = $obb->{'_pos'} || 0; }
 
686
    return $posa <=> $posb;
668
687
  } keys %$objs;
669
688
  
670
689
  if( $objs->{'_cdata'} ) {