File Coverage

blib/lib/MSDOS/Descript.pm

Criterion	Covered	Total	%
statement	77	80	96.2
branch	23	44	52.2
condition	7	11	63.6
subroutine	14	16	87.5
pod	9	9	100.0
total	130	160	81.2

#---------------------------------------------------------------------
package MSDOS::Descript;
#
# Copyright 1997-2008 Christopher J. Madsen
#
# Author: Christopher J. Madsen
# Created: 09 Nov 1997
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: Manage 4DOS style DESCRIPT.ION files
#---------------------------------------------------------------------

require 5.006;
use strict;
use warnings;
use Carp qw(croak);
use Tie::CPHash ();
use vars qw($VERSION $hide_descriptions);

#=====================================================================
# Package Startup:

BEGIN
{
    $VERSION = '1.04';

    # RECOMMEND PREREQ: MSDOS::Attrib
    # Try to load MSDOS::Attrib, but keep going without it:
    $hide_descriptions = do { local $@; eval { require MSDOS::Attrib; 1 } };

    MSDOS::Attrib->import('set_attribs') if $hide_descriptions;
} # end BEGIN

#=====================================================================
# Methods:
#---------------------------------------------------------------------
# Constructor

sub new
{
    my $self = {};
    $self->{file} = $_[1] || '.';
    $self->{file} =~ s![/\\]?$!/DESCRIPT.ION! if -d $self->{file};
    tie %{$self->{desc}},'Tie::CPHash';
    bless $self, $_[0];
    $self->read;
    return $self;
} # end new

#---------------------------------------------------------------------
# Destructor:

sub DESTROY
{
    $_[0]->update if $_[0]->{autoupdate};
} # end DESTROY

#---------------------------------------------------------------------
# Enable or disable automatic updates:

sub autoupdate
{
    $_[0]->{autoupdate} = (($#_ > 0) ? $_[1] : 1);
} # end autoupdate

#---------------------------------------------------------------------
# Return true if the descriptions have changed:

sub changed
{
  $_[0]->{changed};
} # end changed

#---------------------------------------------------------------------
# Read or update the description for a file:
#
# If DESC is the null string or undef, then delete FILE's description.

sub description
{
    my ($self, $file, $desc) = @_;

    $file =~ s/\.+$//;          # Trailing dots don't count in MS-DOS
    if ($#_ > 1) {
        my $old = $self->{desc}{$file};
        if (not defined($desc) or $desc eq '') {
            $self->{changed} = 1 if defined delete $self->{desc}{$file};
        } else {
            $self->{desc}{$file} = $desc;
            $self->{changed} = 1 if not defined $old or $old ne $desc;
        }
        return $old;
    }
    $self->{desc}{$file};
} # end description

#---------------------------------------------------------------------
# Transfer the description when a file is renamed:

sub rename
{
    my ($self, $old, $new) = @_;
    $old =~ s/\.+$//;           # Trailing dots don't count in MS-DOS
    $new =~ s/\.+$//;
    my $desc = delete $self->{desc}{$old};
    if (defined $desc) {
        $self->{desc}{$new} = $desc;
        $self->{changed} = 1;
    }
} # end rename

#---------------------------------------------------------------------
# Read the 4DOS description file:

sub read
{
    my ($self,$in) = @_;
    $in = $self->{file} unless $in;

    %{$self->{desc}} = ();
    $self->read_add($in);

    delete $self->{changed} if $in eq $self->{file};
} # end read

#---------------------------------------------------------------------
# Add descriptions from a file to the current database:
#
# Input:
#   IN:  The name of the file to read

sub read_add
{
    my ($self,$in) = @_;

    if (-r $in) {
        open(DESCRIPT, $in) or croak "Unable to open $in";
        while () {
            m/^\"([^\"]+)\" (.+)$/ or m/^([^ ]+) (.+)$/ or die;
            $self->{desc}{$1} = $2;
        }
        close DESCRIPT;
    }

    $self->{changed} = 1;
} # end read_add

#---------------------------------------------------------------------
# Write the 4DOS description file:
#
# Sets the CHANGED flag to 0 if writing to our FILE.

sub write
{
    my ($self, $out) = @_;
    $out = $self->{file} unless $out;
    my ($file, $desc);

    unlink $out;
    if (keys %{$self->{desc}}) {
        open(DESCRIPT,">$out") or croak "Unable to open $out for writing";
        while (($file,$desc) = each %{$self->{desc}}) {
            next unless $desc;
            $file = '"' . $file . '"' if $file =~ /\s/;
            print DESCRIPT $file,' ',$desc,"\n";
        }
        close DESCRIPT;
        set_attribs('+h',$out) if $hide_descriptions;
    }
    $self->{changed} = 0 if $out eq $self->{file};
} # end write

#---------------------------------------------------------------------
# Save changes to descriptions:

sub update
{
    $_[0]->write if $_[0]->changed;
} # end update

#=====================================================================
# Package Return Value:

1;

__END__